/[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

Diff of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 3 by dpavlin, Sun Sep 28 14:06:59 2008 UTC revision 32 by dpavlin, Mon Apr 6 21:28:02 2009 UTC
# Line 6  use warnings; Line 6  use warnings;
6    
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9    use Getopt::Long;
10    use File::Slurp;
11    
12    use IO::Socket::INET;
13    
14    my $meteor_server = '192.168.1.13:4671';
15    my $meteor_fh;
16    
17    sub meteor {
18            my @a = @_;
19            push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21            if ( ! defined $meteor_fh ) {
22                    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                    $meteor_fh = 0; # don't try again
28            }
29    
30            warn ">> meteor ",dump( @a );
31            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
32    }
33    
34    my $debug = 0;
35    
36    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    my $program_path = './program/';
44    
45  my $response = {  my $response = {
46          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 19  my $response = { Line 54  my $response = {
54          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
55  };  };
56    
57    GetOptions(
58            'd|debug+'    => \$debug,
59            'device=s'    => \$device,
60            'baudrate=i'  => \$baudrate,
61            'databits=i'  => \$databits,
62            'parity=s'    => \$parity,
63            'stopbits=i'  => \$stopbits,
64            'handshake=s' => \$handshake,
65            'meteor=s'    => \$meteor_server,
66    ) or die $!;
67    
68    my $verbose = $debug > 0 ? $debug-- : 0;
69    
70  =head1 NAME  =head1 NAME
71    
72  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
73    
74  =head1 SYNOPSIS  =head1 SYNOPSIS
75    
76  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
77    
78  =head1 DESCRIPTION  =head1 DESCRIPTION
79    
# Line 37  L<Device::SerialPort(3)> Line 85  L<Device::SerialPort(3)>
85    
86  L<perl(1)>  L<perl(1)>
87    
88    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
89    
90  =head1 AUTHOR  =head1 AUTHOR
91    
92  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
# Line 48  it under the same terms ans Perl itself. Line 98  it under the same terms ans Perl itself.
98    
99  =cut  =cut
100    
101  # your serial port.  my $tags_data;
102  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
103  $device    ||= "/dev/ttyUSB0";  
104  $baudrate  ||= "19200";  my $item_type = {
105  $databits  ||= "8";          1 => 'Book',
106  $parity    ||= "none";          6 => 'CD/CD ROM',
107  $stopbits  ||= "1";          2 => 'Magazine',
108  $handshake ||= "none";          13 => 'Book with Audio Tape',
109            9 => 'Book with CD/CD ROM',
110            0 => 'Other',
111    
112            5 => 'Video',
113            4 => 'Audio Tape',
114            3 => 'Bound Journal',
115            8 => 'Book with Diskette',
116            7 => 'Diskette',
117    };
118    
119  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  warn "## known item type: ",dump( $item_type ) if $debug;
120    
121    my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
122    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
123  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
124  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
125  $databits=$port->databits($databits);  $databits=$port->databits($databits);
126  $parity=$port->parity($parity);  $parity=$port->parity($parity);
127  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
128    
129  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
130    
131  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
132  $port->lookclear();  $port->lookclear();
# Line 75  $port->read_char_time(5); Line 137  $port->read_char_time(5);
137  #$port->stty_inpck(1);  #$port->stty_inpck(1);
138  #$port->stty_istrip(1);  #$port->stty_istrip(1);
139    
140  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
141       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
142          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
143          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
144          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
145            print "hardware version $hw_ver\n";
146            meteor( 'info', "Found reader hardware $hw_ver" );
147  });  });
148    
149  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
150  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
151    
152    # start scanning for tags
153    
154    cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
155             'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
156                    my $rest = shift || die "no rest?";
157                    my $nr = ord( substr( $rest, 0, 1 ) );
158    
159                    if ( ! $nr ) {
160                            print "no tags in range\n";
161                            update_visible_tags();
162                            meteor( 'info-none-in-range' );
163                            $tags_data = {};
164                    } else {
165    
166                            my $tags = substr( $rest, 1 );
167    
168                            my $tl = length( $tags );
169                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
170    
171                            my @tags;
172                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
173                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
174                            print "$nr tags in range: ", join(',', @tags ) , "\n";
175    
176                            meteor( 'info-in-range', join(' ',@tags));
177    
178                            update_visible_tags( @tags );
179                    }
180            }
181    ) while(1);
182    #) foreach ( 1 .. 100 );
183    
184    
185    
186    sub update_visible_tags {
187            my @tags = @_;
188    
189            my $last_visible_tags = $visible_tags;
190            $visible_tags = {};
191    
192            foreach my $tag ( @tags ) {
193                    if ( ! defined $last_visible_tags->{$tag} ) {
194                            if ( defined $tags_data->{$tag} ) {
195    #                               meteor( 'in-range', $tag );
196                            } else {
197                                    meteor( 'read', $tag );
198                                    read_tag( $tag );
199                            }
200                            $visible_tags->{$tag}++;
201                    } else {
202                            warn "## using cached data for $tag" if $debug;
203                    }
204                    delete $last_visible_tags->{$tag}; # leave just missing tags
205    
206                    if ( -e "$program_path/$tag" ) {
207                                    meteor( 'write', $tag );
208                                    write_tag( $tag );
209                    }
210            }
211    
212            foreach my $tag ( keys %$last_visible_tags ) {
213                    my $data = delete $tags_data->{$tag};
214                    print "removed tag $tag with data ",dump( $data ),"\n";
215                    meteor( 'removed', $tag );
216            }
217    
218            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
219    }
220    
221    my $tag_data_block;
222    
223    sub read_tag_data {
224            my ($start_block,$rest) = @_;
225            die "no rest?" unless $rest;
226            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
227            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
228            my $blocks = ord(substr($rest,8,1));
229            $rest = substr($rest,9); # leave just data blocks
230            foreach my $nr ( 0 .. $blocks - 1 ) {
231                    my $block = substr( $rest, $nr * 6, 6 );
232                    warn "## block ",as_hex( $block ) if $debug;
233                    my $ord   = unpack('v',substr( $block, 0, 2 ));
234                    my $expected_ord = $nr + $start_block;
235                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
236                    my $data  = substr( $block, 2 );
237                    die "data payload should be 4 bytes" if length($data) != 4;
238                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
239                    $tag_data_block->{$tag}->[ $ord ] = $data;
240            }
241            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
242    
243            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
244            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
245    }
246    
247    sub read_tag {
248            my ( $tag ) = @_;
249    
250            confess "no tag?" unless $tag;
251    
252            print "read_tag $tag\n";
253    
254            cmd(
255                    "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
256                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
257                            print "FIXME: tag $tag ready?\n";
258                    },
259                    "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";
260                            read_tag_data( 0, @_ );
261                    },
262            );
263    
264            cmd(
265                    "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
266                    "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
267                            read_tag_data( 3, @_ );
268                    }
269            );
270    
271            my $data = $tags_data->{$tag} || die "no data for $tag";
272            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
273            my $set   = ( $set_item & 0xf0 ) >> 4;
274            my $total = ( $set_item & 0x0f );
275            my $branch  = $br_lib >> 20;
276            my $library = $br_lib & 0x000fffff;
277            print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom\n";
278    
279    }
280    
281  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  sub write_tag {
282       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );          my ($tag) = @_;
283    
284  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen          my $path = "$program_path/$tag";
285    
286  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          my $data = read_file( $path );
287    
288  #     D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4          $data = substr($data,0,16);
 warn "D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";  
289    
290  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
291    
292  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            print "write_tag $tag = $data ",dump( $hex_data );
293  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
294  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36          cmd(
295                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";                  "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
296  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";                  "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
297            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
298    
299            my $to = $path;
300            $to .= '.' . time();
301    
302            rename $path, $to;
303            print ">> $to\n";
304    
305            delete $tags_data->{$tag};      # force re-read of tag
306    }
307    
308    exit;
309    
310  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
311    
# Line 133  sub writechunk Line 337  sub writechunk
337  {  {
338          my $str=shift;          my $str=shift;
339          my $count = $port->write($str);          my $count = $port->write($str);
340          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
341  }  }
342    
343  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 345  sub as_hex {
345          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
346                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
347                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
348                    $hex =~ s/\s+$//;
349                  push @out, $hex;                  push @out, $hex;
350          }          }
351          return join('  ', @out);          return join(' | ', @out);
352  }  }
353    
354  sub read_bytes {  sub read_bytes {
# Line 151  sub read_bytes { Line 356  sub read_bytes {
356          my $data = '';          my $data = '';
357          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
358                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
359                    die "no bytes on port: $!" unless defined $b;
360                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
361                  $data .= $b;                  $data .= $b;
362          }          }
363          $desc ||= '?';          $desc ||= '?';
364          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
365          return $data;          return $data;
366  }  }
367    
368  my $assert;  our $assert;
369    
370    # my $rest = skip_assert( 3 );
371    sub skip_assert {
372            assert( 0, shift );
373    }
374    
375  sub assert {  sub assert {
376          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
377    
378            $from ||= 0;
379            $to = length( $assert->{expect} ) if ! defined $to;
380    
381          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
382          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
383          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
384    
385            # return the rest
386            return substr( $assert->{payload}, $to );
387  }  }
388    
389  sub readchunk {  use Digest::CRC;
390          my ( $parser ) = @_;  
391    sub crcccitt {
392            my $bytes = shift;
393            my $crc = Digest::CRC->new(
394                    # midified CCITT to xor with 0xffff instead of 0x0000
395                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
396            ) or die $!;
397            $crc->add( $bytes );
398            pack('n', $crc->digest);
399    }
400    
401    # my $checksum = checksum( $bytes );
402    # my $checksum = checksum( $bytes, $original_checksum );
403    sub checksum {
404            my ( $bytes, $checksum ) = @_;
405    
406            my $xor = crcccitt( substr($bytes,1) ); # skip D6
407            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
408    
409            my $len = ord(substr($bytes,2,1));
410            my $len_real = length($bytes) - 1;
411    
412            if ( $len_real != $len ) {
413                    print "length wrong: $len_real != $len\n";
414                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
415            }
416    
417            if ( defined $checksum && $xor ne $checksum ) {
418                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
419                    return $bytes . $xor;
420            }
421            return $bytes . $checksum;
422    }
423    
424    our $dispatch;
425    
426    sub readchunk {
427          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
428    
429          # read header of packet          # read header of packet
# Line 179  sub readchunk { Line 431  sub readchunk {
431          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
432          my $len = ord($length);          my $len = ord($length);
433          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
434    
435          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
436          my $payload_len = length($data);          my $payload_len = length($data);
437          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
438    
439          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
440          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
441    
442          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
443    
444          $assert->{len}      = $len;          $assert->{len}      = $len;
445          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
446    
447          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
448            # find longest match for incomming data
449            my ($to) = grep {
450                    my $match = substr($payload,0,length($_));
451                    m/^\Q$match\E/
452            } sort { length($a) <=> length($b) } keys %$dispatch;
453            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
454    
455            if ( defined $to ) {
456                    my $rest = substr( $payload, length($to) );
457                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
458                    $dispatch->{ $to }->( $rest );
459            } else {
460                    print "NO DISPATCH for ",dump( $full ),"\n";
461            }
462    
463          return $data;          return $data;
464  }  }
465    
466  sub str2bytes {  sub str2bytes {
467          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
468          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
469          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
470          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
471          my $bytes = eval $str;          $b = "\"$b\"";
472            my $bytes = eval $b;
473          die $@ if $@;          die $@ if $@;
474            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
475          return $bytes;          return $bytes;
476  }  }
477    
478  sub cmd {  sub cmd {
479          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
480            my $cmd_desc = shift || confess "no description?";
481            my @expect = @_;
482    
483          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
484    
485          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
486            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
487    
488            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
489          $assert->{send} = $cmd;          $assert->{send} = $cmd;
490          writechunk( $bytes );          writechunk( $bytes );
491    
492          if ( $expect ) {          while ( @expect ) {
493                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
494                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
495                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
496    
497                    next if defined $dispatch->{ $pattern };
498    
499                    $dispatch->{ substr($pattern,3) } = $coderef;
500                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
501          }          }
502    
503            readchunk;
504  }  }
505    
Legend:
Removed from v.3  
changed lines
  Added in v.32
  ViewVC Help
Powered by ViewVC 1.1.26