/[RFID]/3m-810.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 30 - (hide annotations)
Mon Apr 6 13:18:55 2009 UTC (14 years, 11 months ago) by dpavlin
File MIME type: text/plain
File size: 13252 byte(s)
program from file works now

1 dpavlin 1 #!/usr/bin/perl
2    
3     use Device::SerialPort qw (:STAT);
4     use strict;
5     use warnings;
6    
7     use Data::Dump qw/dump/;
8 dpavlin 2 use Carp qw/confess/;
9 dpavlin 19 use Getopt::Long;
10 dpavlin 29 use File::Slurp;
11 dpavlin 1
12 dpavlin 23 use IO::Socket::INET;
13    
14 dpavlin 25 my $meteor_server = '192.168.1.13:4671';
15 dpavlin 26 my $meteor_fh;
16 dpavlin 23
17     sub meteor {
18 dpavlin 25 my @a = @_;
19     push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21 dpavlin 26 if ( ! defined $meteor_fh ) {
22 dpavlin 27 warn "# open connection to $meteor_server";
23     $meteor_fh = IO::Socket::INET->new(
24     PeerAddr => $meteor_server,
25     Timeout => 1,
26     ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
27 dpavlin 26 $meteor_fh = 0; # don't try again
28     }
29    
30 dpavlin 25 warn ">> meteor ",dump( @a );
31 dpavlin 26 print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
32 dpavlin 23 }
33    
34 dpavlin 4 my $debug = 0;
35    
36 dpavlin 19 my $device = "/dev/ttyUSB0";
37     my $baudrate = "19200";
38     my $databits = "8";
39     my $parity = "none";
40     my $stopbits = "1";
41     my $handshake = "none";
42    
43 dpavlin 29 my $program_path = './program/';
44    
45 dpavlin 1 my $response = {
46     'd500090400110a0500027250' => 'version?',
47     'd60007fe00000500c97b' => 'no tag in range',
48    
49     'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
50     'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
51     'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
52    
53     'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
54     'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
55     };
56    
57 dpavlin 19 GetOptions(
58 dpavlin 22 'd|debug+' => \$debug,
59 dpavlin 19 'device=s' => \$device,
60     'baudrate=i' => \$baudrate,
61     'databits=i' => \$databits,
62     'parity=s' => \$parity,
63     'stopbits=i' => \$stopbits,
64     'handshake=s' => \$handshake,
65 dpavlin 26 'meteor=s' => \$meteor_server,
66 dpavlin 19 ) or die $!;
67    
68 dpavlin 22 my $verbose = $debug > 0 ? $debug-- : 0;
69    
70 dpavlin 1 =head1 NAME
71    
72     3m-810 - support for 3M 810 RFID reader
73    
74     =head1 SYNOPSIS
75    
76 dpavlin 19 3m-810.pl --device /dev/ttyUSB0
77 dpavlin 1
78     =head1 DESCRIPTION
79    
80     Communicate with 3M 810 RFID reader and document it's protocol
81    
82     =head1 SEE ALSO
83    
84     L<Device::SerialPort(3)>
85    
86     L<perl(1)>
87    
88 dpavlin 15 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
89    
90 dpavlin 1 =head1 AUTHOR
91    
92     Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
93    
94     =head1 COPYRIGHT AND LICENSE
95    
96     This program is free software; you may redistribute it and/or modify
97     it under the same terms ans Perl itself.
98    
99     =cut
100    
101 dpavlin 23 my $tags_data;
102     my $visible_tags;
103    
104 dpavlin 19 my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
105     warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
106 dpavlin 1 $handshake=$port->handshake($handshake);
107     $baudrate=$port->baudrate($baudrate);
108     $databits=$port->databits($databits);
109     $parity=$port->parity($parity);
110     $stopbits=$port->stopbits($stopbits);
111    
112 dpavlin 22 print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
113 dpavlin 1
114     # Just in case: reset our timing and buffers
115     $port->lookclear();
116     $port->read_const_time(100);
117     $port->read_char_time(5);
118    
119     # Turn on parity checking:
120     #$port->stty_inpck(1);
121     #$port->stty_istrip(1);
122    
123 dpavlin 4 # initial hand-shake with device
124    
125 dpavlin 20 cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
126     'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
127 dpavlin 23 my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
128     print "hardware version $hw_ver\n";
129 dpavlin 25 meteor( 'info', "Found reader hardware $hw_ver" );
130 dpavlin 2 });
131 dpavlin 1
132 dpavlin 20 cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?',
133     'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } );
134 dpavlin 1
135 dpavlin 4 # start scanning for tags
136 dpavlin 1
137 dpavlin 20 cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags, retry $_",
138     'D6 00 0F FE 00 00 05 ', sub { # 01 E00401003123AA26 941A # seen, serial length: 8
139     my $rest = shift || die "no rest?";
140     my $nr = ord( substr( $rest, 0, 1 ) );
141    
142     if ( ! $nr ) {
143     print "no tags in range\n";
144 dpavlin 22 update_visible_tags();
145 dpavlin 25 meteor( 'info-none-in-range' );
146 dpavlin 24 $tags_data = {};
147 dpavlin 20 } else {
148    
149 dpavlin 5 my $tags = substr( $rest, 1 );
150 dpavlin 1
151 dpavlin 5 my $tl = length( $tags );
152     die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
153    
154     my @tags;
155 dpavlin 16 push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
156 dpavlin 8 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
157 dpavlin 22 print "$nr tags in range: ", join(',', @tags ) , "\n";
158 dpavlin 16
159 dpavlin 25 meteor( 'info-in-range', join(' ',@tags));
160    
161 dpavlin 22 update_visible_tags( @tags );
162 dpavlin 5 }
163 dpavlin 20 }
164 dpavlin 24 ) while(1);
165     #) foreach ( 1 .. 100 );
166 dpavlin 5
167 dpavlin 22
168    
169     sub update_visible_tags {
170     my @tags = @_;
171    
172     my $last_visible_tags = $visible_tags;
173     $visible_tags = {};
174    
175     foreach my $tag ( @tags ) {
176     if ( ! defined $last_visible_tags->{$tag} ) {
177 dpavlin 25 if ( defined $tags_data->{$tag} ) {
178     # meteor( 'in-range', $tag );
179     } else {
180     meteor( 'read', $tag );
181     read_tag( $tag );
182     }
183 dpavlin 22 $visible_tags->{$tag}++;
184     } else {
185     warn "## using cached data for $tag" if $debug;
186     }
187     delete $last_visible_tags->{$tag}; # leave just missing tags
188 dpavlin 29
189     if ( -e "$program_path/$tag" ) {
190     meteor( 'write', $tag );
191     write_tag( $tag );
192     }
193 dpavlin 22 }
194    
195     foreach my $tag ( keys %$last_visible_tags ) {
196 dpavlin 23 my $data = delete $tags_data->{$tag};
197     print "removed tag $tag with data ",dump( $data ),"\n";
198 dpavlin 25 meteor( 'removed', $tag );
199 dpavlin 22 }
200    
201     warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
202     }
203    
204 dpavlin 28 my $tag_data_block;
205 dpavlin 22
206 dpavlin 28 sub read_tag_data {
207     my ($start_block,$rest) = @_;
208     die "no rest?" unless $rest;
209     warn "## DATA [$start_block] ", dump( $rest ) if $debug;
210     my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
211     my $blocks = ord(substr($rest,8,1));
212     $rest = substr($rest,9); # leave just data blocks
213     foreach my $nr ( 0 .. $blocks - 1 ) {
214     my $block = substr( $rest, $nr * 6, 6 );
215     warn "## block ",as_hex( $block ) if $debug;
216     my $ord = unpack('v',substr( $block, 0, 2 ));
217     my $expected_ord = $nr + $start_block;
218     die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
219     my $data = substr( $block, 2 );
220     die "data payload should be 4 bytes" if length($data) != 4;
221     warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
222     $tag_data_block->{$tag}->[ $ord ] = $data;
223     }
224     $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
225     print "DATA $tag ",dump( $tags_data ), "\n";
226     }
227    
228 dpavlin 16 sub read_tag {
229     my ( $tag ) = @_;
230 dpavlin 1
231 dpavlin 22 confess "no tag?" unless $tag;
232    
233 dpavlin 16 print "read_tag $tag\n";
234 dpavlin 1
235 dpavlin 20 cmd(
236 dpavlin 28 "D6 00 0D 02 $tag 00 03 1CC4", "read $tag offset: 0 blocks: 3",
237 dpavlin 20 "D6 00 0F FE 00 00 05 01 $tag 941A", sub {
238     print "FIXME: tag $tag ready?\n";
239     },
240     "D6 00 1F 02 00", sub { # $tag 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n";
241 dpavlin 28 read_tag_data( 0, @_ );
242     },
243     );
244    
245     cmd(
246     "D6 00 0D 02 $tag 03 04 3970", "read $tag offset: 3 blocks: 4",
247     "D6 00 25 02 00", sub { # $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
248     read_tag_data( 3, @_ );
249 dpavlin 20 }
250     );
251 dpavlin 1
252 dpavlin 16 }
253    
254 dpavlin 29 sub write_tag {
255     my ($tag) = @_;
256    
257     my $path = "$program_path/$tag";
258    
259     my $data = read_file( $path );
260    
261 dpavlin 30 $data = substr($data,0,16);
262 dpavlin 29
263 dpavlin 30 my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
264    
265     print "write_tag $tag = $data ",dump( $hex_data );
266    
267 dpavlin 29 cmd(
268 dpavlin 30 "D6 00 26 04 $tag 00 06 00 04 11 00 01 $hex_data 00 00 00 00 FD3B", "write $tag",
269 dpavlin 29 "D6 00 0D 04 00 $tag 06 AFB1", sub { assert() },
270     ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
271    
272     my $to = $path;
273     $to .= '.' . time();
274    
275     rename $path, $to;
276     print ">> $to\n";
277    
278 dpavlin 30 delete $tags_data->{$tag}; # force re-read of tag
279 dpavlin 29 }
280    
281 dpavlin 19 exit;
282    
283 dpavlin 1 for ( 1 .. 3 ) {
284    
285     # ++-->type 00-0a
286     # D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4
287     # D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7
288     # D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F
289    
290     cmd(' D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00 8843', "write offset 0, block: 7 -- 0000000000 $_" );
291     warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
292    
293     }
294     warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
295    
296     cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
297    
298     cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
299     'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
300     cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
301     'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
302    
303     cmd('D6 00 26 04 E00401003123AA26 00 06 00 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 A98B', 'blank offset: 0 blocks: 6',
304     'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
305    
306     undef $port;
307     print "Port closed\n";
308    
309     sub writechunk
310     {
311     my $str=shift;
312     my $count = $port->write($str);
313 dpavlin 19 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
314 dpavlin 1 }
315    
316     sub as_hex {
317     my @out;
318     foreach my $str ( @_ ) {
319     my $hex = unpack( 'H*', $str );
320 dpavlin 2 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
321 dpavlin 8 $hex =~ s/\s+$//;
322 dpavlin 1 push @out, $hex;
323     }
324 dpavlin 8 return join(' | ', @out);
325 dpavlin 1 }
326    
327     sub read_bytes {
328     my ( $len, $desc ) = @_;
329     my $data = '';
330     while ( length( $data ) < $len ) {
331     my ( $c, $b ) = $port->read(1);
332 dpavlin 28 die "no bytes on port: $!" unless defined $b;
333 dpavlin 1 #warn "## got $c bytes: ", as_hex($b), "\n";
334     $data .= $b;
335     }
336     $desc ||= '?';
337 dpavlin 4 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
338 dpavlin 1 return $data;
339     }
340    
341 dpavlin 5 our $assert;
342 dpavlin 2
343 dpavlin 5 # my $rest = skip_assert( 3 );
344     sub skip_assert {
345     assert( 0, shift );
346     }
347    
348 dpavlin 2 sub assert {
349     my ( $from, $to ) = @_;
350    
351 dpavlin 5 $from ||= 0;
352 dpavlin 4 $to = length( $assert->{expect} ) if ! defined $to;
353    
354 dpavlin 2 my $p = substr( $assert->{payload}, $from, $to );
355     my $e = substr( $assert->{expect}, $from, $to );
356 dpavlin 3 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
357 dpavlin 5
358     # return the rest
359     return substr( $assert->{payload}, $to );
360 dpavlin 2 }
361    
362 dpavlin 15 use Digest::CRC;
363    
364     sub crcccitt {
365     my $bytes = shift;
366     my $crc = Digest::CRC->new(
367     # midified CCITT to xor with 0xffff instead of 0x0000
368     width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
369     ) or die $!;
370     $crc->add( $bytes );
371     pack('n', $crc->digest);
372     }
373    
374 dpavlin 8 # my $checksum = checksum( $bytes );
375     # my $checksum = checksum( $bytes, $original_checksum );
376     sub checksum {
377     my ( $bytes, $checksum ) = @_;
378    
379 dpavlin 15 my $xor = crcccitt( substr($bytes,1) ); # skip D6
380     warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
381 dpavlin 10
382 dpavlin 16 my $len = ord(substr($bytes,2,1));
383 dpavlin 17 my $len_real = length($bytes) - 1;
384 dpavlin 16
385 dpavlin 17 if ( $len_real != $len ) {
386     print "length wrong: $len_real != $len\n";
387     $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
388     }
389    
390 dpavlin 8 if ( defined $checksum && $xor ne $checksum ) {
391 dpavlin 10 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
392 dpavlin 16 return $bytes . $xor;
393 dpavlin 8 }
394 dpavlin 16 return $bytes . $checksum;
395 dpavlin 8 }
396    
397 dpavlin 20 our $dispatch;
398    
399 dpavlin 1 sub readchunk {
400 dpavlin 2 sleep 1; # FIXME remove
401    
402 dpavlin 1 # read header of packet
403     my $header = read_bytes( 2, 'header' );
404 dpavlin 2 my $length = read_bytes( 1, 'length' );
405     my $len = ord($length);
406 dpavlin 1 my $data = read_bytes( $len, 'data' );
407    
408 dpavlin 2 my $payload = substr( $data, 0, -2 );
409     my $payload_len = length($data);
410     warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
411 dpavlin 8
412 dpavlin 2 my $checksum = substr( $data, -2, 2 );
413 dpavlin 20 checksum( $header . $length . $payload , $checksum );
414 dpavlin 1
415 dpavlin 22 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
416 dpavlin 2
417     $assert->{len} = $len;
418     $assert->{payload} = $payload;
419    
420 dpavlin 20 my $full = $header . $length . $data; # full
421     # find longest match for incomming data
422     my ($to) = grep {
423     my $match = substr($payload,0,length($_));
424     m/^\Q$match\E/
425     } sort { length($a) <=> length($b) } keys %$dispatch;
426     warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
427 dpavlin 2
428 dpavlin 20 if ( defined $to ) {
429     my $rest = substr( $payload, length($to) );
430     warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
431     $dispatch->{ $to }->( $rest );
432     } else {
433     print "NO DISPATCH for ",dump( $full ),"\n";
434     }
435    
436 dpavlin 2 return $data;
437 dpavlin 1 }
438    
439 dpavlin 2 sub str2bytes {
440     my $str = shift || confess "no str?";
441 dpavlin 5 my $b = $str;
442 dpavlin 17 $b =~ s/\s+//g;
443     $b =~ s/(..)/\\x$1/g;
444     $b = "\"$b\"";
445 dpavlin 5 my $bytes = eval $b;
446 dpavlin 2 die $@ if $@;
447 dpavlin 5 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
448 dpavlin 2 return $bytes;
449     }
450    
451     sub cmd {
452 dpavlin 20 my $cmd = shift || confess "no cmd?";
453     my $cmd_desc = shift || confess "no description?";
454     my @expect = @_;
455    
456 dpavlin 2 my $bytes = str2bytes( $cmd );
457    
458 dpavlin 16 # fix checksum if needed
459     $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
460    
461 dpavlin 22 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
462 dpavlin 2 $assert->{send} = $cmd;
463     writechunk( $bytes );
464    
465 dpavlin 20 while ( @expect ) {
466     my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
467     my $coderef = shift @expect || confess "no coderef?";
468     confess "not coderef" unless ref $coderef eq 'CODE';
469    
470     next if defined $dispatch->{ $pattern };
471    
472     $dispatch->{ substr($pattern,3) } = $coderef;
473     warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
474 dpavlin 2 }
475 dpavlin 20
476     readchunk;
477 dpavlin 2 }
478    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26