/[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 10 by dpavlin, Sun Sep 28 22:15:29 2008 UTC revision 31 by dpavlin, Mon Apr 6 15:19:24 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;  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?',
47          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  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 39  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 50  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    warn "## known item type: ",dump( $item_type ) if $debug;
120    
121  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  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 79  $port->read_char_time(5); Line 139  $port->read_char_time(5);
139    
140  # initial hand-shake with device  # initial hand-shake with device
141    
142  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
143       'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
144          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\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','FIXME: unimplemented', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
151    
152  # start scanning for tags  # start scanning for tags
153    
154  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
155       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
156  dispatch(                  my $rest = shift || die "no rest?";
157           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
158                  sub {  
159                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
160                          my $nr = ord( substr( $rest, 0, 1 ) );                          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 );                          my $tags = substr( $rest, 1 );
167    
168                          my $tl = length( $tags );                          my $tl = length( $tags );
169                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
170    
171                          my @tags;                          my @tags;
172                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
173                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
174                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          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 ( 1 .. 100 );          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  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  sub read_tag {
248            my ( $tag ) = @_;
249    
250  #     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          confess "no tag?" unless $tag;
 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";  
251    
252  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          print "read_tag $tag\n";
253    
254  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            cmd(
255  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
256  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
257                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";                          print "FIXME: tag $tag ready?\n";
258  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";                  },
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    }
272    
273    sub write_tag {
274            my ($tag) = @_;
275    
276            my $path = "$program_path/$tag";
277    
278            my $data = read_file( $path );
279    
280            $data = substr($data,0,16);
281    
282            my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
283    
284            print "write_tag $tag = $data ",dump( $hex_data );
285    
286            cmd(
287                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
288                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
289            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
290    
291            my $to = $path;
292            $to .= '.' . time();
293    
294            rename $path, $to;
295            print ">> $to\n";
296    
297            delete $tags_data->{$tag};      # force re-read of tag
298    }
299    
300    exit;
301    
302  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
303    
# Line 153  sub writechunk Line 329  sub writechunk
329  {  {
330          my $str=shift;          my $str=shift;
331          my $count = $port->write($str);          my $count = $port->write($str);
332          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
333  }  }
334    
335  sub as_hex {  sub as_hex {
# Line 172  sub read_bytes { Line 348  sub read_bytes {
348          my $data = '';          my $data = '';
349          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
350                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
351                    die "no bytes on port: $!" unless defined $b;
352                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
353                  $data .= $b;                  $data .= $b;
354          }          }
# Line 201  sub assert { Line 378  sub assert {
378          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
379  }  }
380    
381  our $dispatch;  use Digest::CRC;
382  sub dispatch {  
383          my ( $pattern, $coderef ) = @_;  sub crcccitt {
384          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
385          my $l = length($patt);          my $crc = Digest::CRC->new(
386          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
387          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
388            ) or die $!;
389          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
390                  warn "## no dispatch, payload expected" if $debug;          pack('n', $crc->digest);
         } elsif ( $p eq $patt ) {  
                 # if matched call with rest of payload  
                 $coderef->( substr( $assert->{payload}, $l ) );  
         } else {  
                 warn "## dispatch ignored" if $debug;  
         }  
391  }  }
392    
393  # my $checksum = checksum( $bytes );  # my $checksum = checksum( $bytes );
# Line 224  sub dispatch { Line 395  sub dispatch {
395  sub checksum {  sub checksum {
396          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
397    
398          my $xor = $checksum; # FIXME          my $xor = crcccitt( substr($bytes,1) ); # skip D6
399            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
400    
401            my $len = ord(substr($bytes,2,1));
402            my $len_real = length($bytes) - 1;
403    
404            if ( $len_real != $len ) {
405                    print "length wrong: $len_real != $len\n";
406                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
407            }
408    
409          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
410                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
411                    return $bytes . $xor;
412          }          }
413            return $bytes . $checksum;
414  }  }
415    
416  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
417    
418    sub readchunk {
419          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
420    
421          # read header of packet          # read header of packet
# Line 247  sub readchunk { Line 429  sub readchunk {
429          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
430    
431          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
432          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
433    
434          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
435    
436          $assert->{len}      = $len;          $assert->{len}      = $len;
437          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
438    
439          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
440            # find longest match for incomming data
441            my ($to) = grep {
442                    my $match = substr($payload,0,length($_));
443                    m/^\Q$match\E/
444            } sort { length($a) <=> length($b) } keys %$dispatch;
445            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
446    
447            if ( defined $to ) {
448                    my $rest = substr( $payload, length($to) );
449                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
450                    $dispatch->{ $to }->( $rest );
451            } else {
452                    print "NO DISPATCH for ",dump( $full ),"\n";
453            }
454    
455          return $data;          return $data;
456  }  }
# Line 262  sub readchunk { Line 458  sub readchunk {
458  sub str2bytes {  sub str2bytes {
459          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
460          my $b = $str;          my $b = $str;
461          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
462          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
463          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
464          my $bytes = eval $b;          my $bytes = eval $b;
465          die $@ if $@;          die $@ if $@;
466          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 273  sub str2bytes { Line 468  sub str2bytes {
468  }  }
469    
470  sub cmd {  sub cmd {
471          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
472            my $cmd_desc = shift || confess "no description?";
473            my @expect = @_;
474    
475          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
476    
477          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
478            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
479    
480            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
481          $assert->{send} = $cmd;          $assert->{send} = $cmd;
482          writechunk( $bytes );          writechunk( $bytes );
483    
484          if ( $expect ) {          while ( @expect ) {
485                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
486                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
487                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
488    
489                    next if defined $dispatch->{ $pattern };
490    
491                    $dispatch->{ substr($pattern,3) } = $coderef;
492                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
493          }          }
494    
495            readchunk;
496  }  }
497    
Legend:
Removed from v.10  
changed lines
  Added in v.31
  ViewVC Help
Powered by ViewVC 1.1.26