/[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 30 by dpavlin, Mon Apr 6 13:18:55 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;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
103    
104  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  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  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
107  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
108  $databits=$port->databits($databits);  $databits=$port->databits($databits);
109  $parity=$port->parity($parity);  $parity=$port->parity($parity);
110  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
111    
112  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
113    
114  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
115  $port->lookclear();  $port->lookclear();
# Line 75  $port->read_char_time(5); Line 120  $port->read_char_time(5);
120  #$port->stty_inpck(1);  #$port->stty_inpck(1);
121  #$port->stty_istrip(1);  #$port->stty_istrip(1);
122    
123  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
124       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
125          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
126          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
127          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
128            print "hardware version $hw_ver\n";
129            meteor( 'info', "Found reader hardware $hw_ver" );
130  });  });
131    
132  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?',
133  #     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() }  );
134    
135    # start scanning for tags
136    
137    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                            update_visible_tags();
145                            meteor( 'info-none-in-range' );
146                            $tags_data = {};
147                    } else {
148    
149                            my $tags = substr( $rest, 1 );
150    
151                            my $tl = length( $tags );
152                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
153    
154                            my @tags;
155                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
156                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
157                            print "$nr tags in range: ", join(',', @tags ) , "\n";
158    
159                            meteor( 'info-in-range', join(' ',@tags));
160    
161                            update_visible_tags( @tags );
162                    }
163            }
164    ) while(1);
165    #) foreach ( 1 .. 100 );
166    
167    
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                            if ( defined $tags_data->{$tag} ) {
178    #                               meteor( 'in-range', $tag );
179                            } else {
180                                    meteor( 'read', $tag );
181                                    read_tag( $tag );
182                            }
183                            $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    
189                    if ( -e "$program_path/$tag" ) {
190                                    meteor( 'write', $tag );
191                                    write_tag( $tag );
192                    }
193            }
194    
195            foreach my $tag ( keys %$last_visible_tags ) {
196                    my $data = delete $tags_data->{$tag};
197                    print "removed tag $tag with data ",dump( $data ),"\n";
198                    meteor( 'removed', $tag );
199            }
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    my $tag_data_block;
205    
206    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    sub read_tag {
229            my ( $tag ) = @_;
230    
231            confess "no tag?" unless $tag;
232    
233            print "read_tag $tag\n";
234    
235            cmd(
236                    "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
237                    "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                            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                    }
250            );
251    
252    }
253    
254    sub write_tag {
255            my ($tag) = @_;
256    
257            my $path = "$program_path/$tag";
258    
259  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",          my $data = read_file( $path );
      'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );  
260    
261  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen          $data = substr($data,0,16);
262    
263  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
264    
265  #     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          print "write_tag $tag = $data ",dump( $hex_data );
 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";  
266    
267  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          cmd(
268                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
269                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
270            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
271    
272  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            my $to = $path;
273  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          $to .= '.' . time();
274  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
275                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          rename $path, $to;
276  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";          print ">> $to\n";
277    
278            delete $tags_data->{$tag};      # force re-read of tag
279    }
280    
281    exit;
282    
283  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
284    
# Line 133  sub writechunk Line 310  sub writechunk
310  {  {
311          my $str=shift;          my $str=shift;
312          my $count = $port->write($str);          my $count = $port->write($str);
313          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
314  }  }
315    
316  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 318  sub as_hex {
318          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
319                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
320                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
321                    $hex =~ s/\s+$//;
322                  push @out, $hex;                  push @out, $hex;
323          }          }
324          return join('  ', @out);          return join(' | ', @out);
325  }  }
326    
327  sub read_bytes {  sub read_bytes {
# Line 151  sub read_bytes { Line 329  sub read_bytes {
329          my $data = '';          my $data = '';
330          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
331                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
332                    die "no bytes on port: $!" unless defined $b;
333                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
334                  $data .= $b;                  $data .= $b;
335          }          }
336          $desc ||= '?';          $desc ||= '?';
337          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
338          return $data;          return $data;
339  }  }
340    
341  my $assert;  our $assert;
342    
343    # my $rest = skip_assert( 3 );
344    sub skip_assert {
345            assert( 0, shift );
346    }
347    
348  sub assert {  sub assert {
349          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
350    
351            $from ||= 0;
352            $to = length( $assert->{expect} ) if ! defined $to;
353    
354          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
355          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
356          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;
357    
358            # return the rest
359            return substr( $assert->{payload}, $to );
360  }  }
361    
362  sub readchunk {  use Digest::CRC;
363          my ( $parser ) = @_;  
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    # my $checksum = checksum( $bytes );
375    # my $checksum = checksum( $bytes, $original_checksum );
376    sub checksum {
377            my ( $bytes, $checksum ) = @_;
378    
379            my $xor = crcccitt( substr($bytes,1) ); # skip D6
380            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
381    
382            my $len = ord(substr($bytes,2,1));
383            my $len_real = length($bytes) - 1;
384    
385            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            if ( defined $checksum && $xor ne $checksum ) {
391                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
392                    return $bytes . $xor;
393            }
394            return $bytes . $checksum;
395    }
396    
397    our $dispatch;
398    
399    sub readchunk {
400          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
401    
402          # read header of packet          # read header of packet
# Line 179  sub readchunk { Line 404  sub readchunk {
404          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
405          my $len = ord($length);          my $len = ord($length);
406          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
407    
408          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
409          my $payload_len = length($data);          my $payload_len = length($data);
410          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
411    
412          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
413          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
414    
415          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;
416    
417          $assert->{len}      = $len;          $assert->{len}      = $len;
418          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
419    
420          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          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    
428            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          return $data;          return $data;
437  }  }
438    
439  sub str2bytes {  sub str2bytes {
440          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
441          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
442          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
443          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
444          my $bytes = eval $str;          $b = "\"$b\"";
445            my $bytes = eval $b;
446          die $@ if $@;          die $@ if $@;
447            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
448          return $bytes;          return $bytes;
449  }  }
450    
451  sub cmd {  sub cmd {
452          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
453            my $cmd_desc = shift || confess "no description?";
454            my @expect = @_;
455    
456          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
457    
458          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
459            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
460    
461            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
462          $assert->{send} = $cmd;          $assert->{send} = $cmd;
463          writechunk( $bytes );          writechunk( $bytes );
464    
465          if ( $expect ) {          while ( @expect ) {
466                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
467                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
468                  readchunk( $coderef );                  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          }          }
475    
476            readchunk;
477  }  }
478    
Legend:
Removed from v.3  
changed lines
  Added in v.30
  ViewVC Help
Powered by ViewVC 1.1.26