/[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 26 by dpavlin, Wed Apr 1 16:59:09 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    
11    use IO::Socket::INET;
12    
13    my $meteor_server = '192.168.1.13:4671';
14    my $meteor_fh;
15    
16    sub meteor {
17            my @a = @_;
18            push @a, scalar localtime() if $a[0] =~ m{^info};
19    
20            if ( ! defined $meteor_fh ) {
21                    $meteor_fh = IO::Socket::INET->new( $meteor_server )
22                            || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
23                    $meteor_fh = 0; # don't try again
24            }
25    
26            warn ">> meteor ",dump( @a );
27            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
28    }
29    
30  my $debug = 0;  my $debug = 0;
31    
32    my $device    = "/dev/ttyUSB0";
33    my $baudrate  = "19200";
34    my $databits  = "8";
35    my $parity        = "none";
36    my $stopbits  = "1";
37    my $handshake = "none";
38    
39  my $response = {  my $response = {
40          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
41          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 48  my $response = {
48          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
49  };  };
50    
51    GetOptions(
52            'd|debug+'    => \$debug,
53            'device=s'    => \$device,
54            'baudrate=i'  => \$baudrate,
55            'databits=i'  => \$databits,
56            'parity=s'    => \$parity,
57            'stopbits=i'  => \$stopbits,
58            'handshake=s' => \$handshake,
59            'meteor=s'    => \$meteor_server,
60    ) or die $!;
61    
62    my $verbose = $debug > 0 ? $debug-- : 0;
63    
64  =head1 NAME  =head1 NAME
65    
66  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
67    
68  =head1 SYNOPSIS  =head1 SYNOPSIS
69    
70  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
71    
72  =head1 DESCRIPTION  =head1 DESCRIPTION
73    
# Line 39  L<Device::SerialPort(3)> Line 79  L<Device::SerialPort(3)>
79    
80  L<perl(1)>  L<perl(1)>
81    
82    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
83    
84  =head1 AUTHOR  =head1 AUTHOR
85    
86  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 92  it under the same terms ans Perl itself.
92    
93  =cut  =cut
94    
95  # your serial port.  my $tags_data;
96  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
97    
98  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
99    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
100  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
101  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
102  $databits=$port->databits($databits);  $databits=$port->databits($databits);
103  $parity=$port->parity($parity);  $parity=$port->parity($parity);
104  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
105    
106  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
107    
108  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
109  $port->lookclear();  $port->lookclear();
# Line 79  $port->read_char_time(5); Line 116  $port->read_char_time(5);
116    
117  # initial hand-shake with device  # initial hand-shake with device
118    
119  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
120       '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 {
121          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
122            print "hardware version $hw_ver\n";
123            meteor( 'info', "Found reader hardware $hw_ver" );
124  });  });
125    
126  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?',
127       '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() }  );
128    
129  # start scanning for tags  # start scanning for tags
130    
131  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
132       '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
133  dispatch(                  my $rest = shift || die "no rest?";
134           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
135                  sub {  
136                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
137                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
138                            update_visible_tags();
139                            meteor( 'info-none-in-range' );
140                            $tags_data = {};
141                    } else {
142    
143                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
144    
145                          my $tl = length( $tags );                          my $tl = length( $tags );
146                          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;
147    
148                          my @tags;                          my @tags;
149                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
150                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
151                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
152    
153                            meteor( 'info-in-range', join(' ',@tags));
154    
155                            update_visible_tags( @tags );
156                  }                  }
157  ) }          }
158    ) while(1);
159    #) foreach ( 1 .. 100 );
160    
 ) foreach ( 1 .. 100 );  
161    
 cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  
162    
163  #     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  sub update_visible_tags {
164  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";          my @tags = @_;
165    
166  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          my $last_visible_tags = $visible_tags;
167            $visible_tags = {};
168    
169            foreach my $tag ( @tags ) {
170                    if ( ! defined $last_visible_tags->{$tag} ) {
171                            if ( defined $tags_data->{$tag} ) {
172    #                               meteor( 'in-range', $tag );
173                            } else {
174                                    meteor( 'read', $tag );
175                                    read_tag( $tag );
176                            }
177                            $visible_tags->{$tag}++;
178                    } else {
179                            warn "## using cached data for $tag" if $debug;
180                    }
181                    delete $last_visible_tags->{$tag}; # leave just missing tags
182            }
183    
184  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            foreach my $tag ( keys %$last_visible_tags ) {
185  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA                  my $data = delete $tags_data->{$tag};
186  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36                  print "removed tag $tag with data ",dump( $data ),"\n";
187                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";                  meteor( 'removed', $tag );
188  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";          }
189    
190            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
191    }
192    
193    
194    sub read_tag {
195            my ( $tag ) = @_;
196    
197            confess "no tag?" unless $tag;
198    
199            print "read_tag $tag\n";
200    
201            cmd(
202                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
203                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
204                            print "FIXME: tag $tag ready?\n";
205                    },
206                    "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";
207                            my $rest = shift || die "no rest?";
208                            warn "## DATA ", dump( $rest ) if $debug;
209                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
210                            my $blocks = ord(substr($rest,8,1));
211                            $rest = substr($rest,9); # leave just data blocks
212                            my @data;
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                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
218                                    my $data  = substr( $block, 2 );
219                                    die "data payload should be 4 bytes" if length($data) != 4;
220                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
221                                    $data[ $ord ] = $data;
222                            }
223                            $tags_data->{ $tag } = join('', @data);
224                            print "DATA $tag ",dump( $tags_data ), "\n";
225                    }
226            );
227    
228            #        D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4
229    if (0) {
230            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
231    
232            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
233            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
234            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
235    }
236            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
237    
238    }
239    
240    exit;
241    
242  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
243    
# Line 153  sub writechunk Line 269  sub writechunk
269  {  {
270          my $str=shift;          my $str=shift;
271          my $count = $port->write($str);          my $count = $port->write($str);
272          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
273  }  }
274    
275  sub as_hex {  sub as_hex {
# Line 201  sub assert { Line 317  sub assert {
317          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
318  }  }
319    
320  our $dispatch;  use Digest::CRC;
321  sub dispatch {  
322          my ( $pattern, $coderef ) = @_;  sub crcccitt {
323          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
324          my $l = length($patt);          my $crc = Digest::CRC->new(
325          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
326          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
327            ) or die $!;
328          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
329                  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;  
         }  
330  }  }
331    
332  # my $checksum = checksum( $bytes );  # my $checksum = checksum( $bytes );
# Line 224  sub dispatch { Line 334  sub dispatch {
334  sub checksum {  sub checksum {
335          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
336    
337          my $xor = $checksum; # FIXME          my $xor = crcccitt( substr($bytes,1) ); # skip D6
338            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
339    
340            my $len = ord(substr($bytes,2,1));
341            my $len_real = length($bytes) - 1;
342    
343            if ( $len_real != $len ) {
344                    print "length wrong: $len_real != $len\n";
345                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
346            }
347    
348          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
349                  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";
350                    return $bytes . $xor;
351          }          }
352            return $bytes . $checksum;
353  }  }
354    
355  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
356    
357    sub readchunk {
358          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
359    
360          # read header of packet          # read header of packet
# Line 247  sub readchunk { Line 368  sub readchunk {
368          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
369    
370          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
371          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
372    
373          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;
374    
375          $assert->{len}      = $len;          $assert->{len}      = $len;
376          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
377    
378          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
379            # find longest match for incomming data
380            my ($to) = grep {
381                    my $match = substr($payload,0,length($_));
382                    m/^\Q$match\E/
383            } sort { length($a) <=> length($b) } keys %$dispatch;
384            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
385    
386            if ( defined $to ) {
387                    my $rest = substr( $payload, length($to) );
388                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
389                    $dispatch->{ $to }->( $rest );
390            } else {
391                    print "NO DISPATCH for ",dump( $full ),"\n";
392            }
393    
394          return $data;          return $data;
395  }  }
# Line 262  sub readchunk { Line 397  sub readchunk {
397  sub str2bytes {  sub str2bytes {
398          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
399          my $b = $str;          my $b = $str;
400          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
401          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
402          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
403          my $bytes = eval $b;          my $bytes = eval $b;
404          die $@ if $@;          die $@ if $@;
405          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 273  sub str2bytes { Line 407  sub str2bytes {
407  }  }
408    
409  sub cmd {  sub cmd {
410          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
411            my $cmd_desc = shift || confess "no description?";
412            my @expect = @_;
413    
414          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
415    
416          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
417            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
418    
419            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
420          $assert->{send} = $cmd;          $assert->{send} = $cmd;
421          writechunk( $bytes );          writechunk( $bytes );
422    
423          if ( $expect ) {          while ( @expect ) {
424                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
425                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
426                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
427    
428                    next if defined $dispatch->{ $pattern };
429    
430                    $dispatch->{ substr($pattern,3) } = $coderef;
431                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
432          }          }
433    
434            readchunk;
435  }  }
436    
Legend:
Removed from v.10  
changed lines
  Added in v.26
  ViewVC Help
Powered by ViewVC 1.1.26