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