/[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 6 by dpavlin, Sun Sep 28 18:19:37 2008 UTC revision 22 by dpavlin, Sat Oct 4 11:55:30 2008 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  my $debug = 0;  my $debug = 0;
12    
13    my $device    = "/dev/ttyUSB0";
14    my $baudrate  = "19200";
15    my $databits  = "8";
16    my $parity        = "none";
17    my $stopbits  = "1";
18    my $handshake = "none";
19    
20  my $response = {  my $response = {
21          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
22          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 29  my $response = {
29          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
30  };  };
31    
32    GetOptions(
33            'd|debug+'    => \$debug,
34            'device=s'    => \$device,
35            'baudrate=i'  => \$baudrate,
36            'databits=i'  => \$databits,
37            'parity=s'    => \$parity,
38            'stopbits=i'  => \$stopbits,
39            'handshake=s' => \$handshake,
40    ) or die $!;
41    
42    my $verbose = $debug > 0 ? $debug-- : 0;
43    
44  =head1 NAME  =head1 NAME
45    
46  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
47    
48  =head1 SYNOPSIS  =head1 SYNOPSIS
49    
50  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
51    
52  =head1 DESCRIPTION  =head1 DESCRIPTION
53    
# Line 39  L<Device::SerialPort(3)> Line 59  L<Device::SerialPort(3)>
59    
60  L<perl(1)>  L<perl(1)>
61    
62    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
63    
64  =head1 AUTHOR  =head1 AUTHOR
65    
66  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 72  it under the same terms ans Perl itself.
72    
73  =cut  =cut
74    
75  # your serial port.  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
76  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
   
 my $port=new Device::SerialPort($device) || die "new($device): $!\n";  
77  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
78  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
79  $databits=$port->databits($databits);  $databits=$port->databits($databits);
80  $parity=$port->parity($parity);  $parity=$port->parity($parity);
81  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
82    
83  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
84    
85  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
86  $port->lookclear();  $port->lookclear();
# Line 79  $port->read_char_time(5); Line 93  $port->read_char_time(5);
93    
94  # initial hand-shake with device  # initial hand-shake with device
95    
96  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
97       '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 {
98          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
99  });  });
100    
101  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?',
102       '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() }  );
103    
104  # start scanning for tags  # start scanning for tags
105    
106  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
107       '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
108  dispatch(                  my $rest = shift || die "no rest?";
109           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
110                  sub {  
111                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
112                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
113                            update_visible_tags();
114                    } else {
115    
116                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
117    
118                          my $tl = length( $tags );                          my $tl = length( $tags );
119                          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;
120    
121                          my @tags;                          my @tags;
122                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
123                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags );                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
124                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
125                  }  
126  ) }                          update_visible_tags( @tags );
127    
128                    }
129            }
130  ) foreach ( 1 .. 100 );  ) foreach ( 1 .. 100 );
131    
 cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  
132    
 #     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  
 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";  
133    
134  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  my $tags_data;
135    my $visible_tags;
136    
137    sub update_visible_tags {
138            my @tags = @_;
139    
140            my $last_visible_tags = $visible_tags;
141            $visible_tags = {};
142    
143            foreach my $tag ( @tags ) {
144                    if ( ! defined $last_visible_tags->{$tag} ) {
145                            read_tag( $tag );
146                            $visible_tags->{$tag}++;
147                    } else {
148                            warn "## using cached data for $tag" if $debug;
149                    }
150                    delete $last_visible_tags->{$tag}; # leave just missing tags
151            }
152    
153            foreach my $tag ( keys %$last_visible_tags ) {
154                    print "removed tag $tag with data ",dump( delete $tags_data->{$tag} ),"\n";
155            }
156    
157            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
158    }
159    
160    
161    sub read_tag {
162            my ( $tag ) = @_;
163    
164            confess "no tag?" unless $tag;
165    
166            return if defined $tags_data->{$tag};
167    
168            print "read_tag $tag\n";
169    
170  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            cmd(
171  #                                                                      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',
172  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 {
173                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";                          print "FIXME: tag $tag ready?\n";
174  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";                  },
175                    "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";
176                            my $rest = shift || die "no rest?";
177                            warn "## DATA ", dump( $rest ) if $debug;
178                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
179                            my $blocks = ord(substr($rest,8,1));
180                            $rest = substr($rest,9); # leave just data blocks
181                            my @data;
182                            foreach my $nr ( 0 .. $blocks - 1 ) {
183                                    my $block = substr( $rest, $nr * 6, 6 );
184                                    warn "## block ",as_hex( $block ) if $debug;
185                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
186                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
187                                    my $data  = substr( $block, 2 );
188                                    die "data payload should be 4 bytes" if length($data) != 4;
189                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
190                                    $data[ $ord ] = $data;
191                            }
192                            $tags_data->{ $tag } = join('', @data);
193                            print "DATA $tag ",dump( $tags_data ), "\n";
194                    }
195            );
196    
197            #        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
198    if (0) {
199            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
200    
201            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
202            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
203            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
204    }
205            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
206    
207    }
208    
209    exit;
210    
211  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
212    
# Line 153  sub writechunk Line 238  sub writechunk
238  {  {
239          my $str=shift;          my $str=shift;
240          my $count = $port->write($str);          my $count = $port->write($str);
241          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
242  }  }
243    
244  sub as_hex {  sub as_hex {
# Line 161  sub as_hex { Line 246  sub as_hex {
246          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
247                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
248                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
249                    $hex =~ s/\s+$//;
250                  push @out, $hex;                  push @out, $hex;
251          }          }
252          return join('  ', @out);          return join(' | ', @out);
253  }  }
254    
255  sub read_bytes {  sub read_bytes {
# Line 200  sub assert { Line 286  sub assert {
286          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
287  }  }
288    
289  our $dispatch;  use Digest::CRC;
290  sub dispatch {  
291          my ( $pattern, $coderef ) = @_;  sub crcccitt {
292          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
293          my $l = length($patt);          my $crc = Digest::CRC->new(
294          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
295          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
296            ) or die $!;
297          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
298                  warn "## no dispatch, payload expected" if $debug;          pack('n', $crc->digest);
299          } elsif ( $p eq $patt ) {  }
300                  # if matched call with rest of payload  
301                  $coderef->( substr( $assert->{payload}, $l ) );  # my $checksum = checksum( $bytes );
302          } else {  # my $checksum = checksum( $bytes, $original_checksum );
303                  warn "## dispatch ignored" if $debug;  sub checksum {
304            my ( $bytes, $checksum ) = @_;
305    
306            my $xor = crcccitt( substr($bytes,1) ); # skip D6
307            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
308    
309            my $len = ord(substr($bytes,2,1));
310            my $len_real = length($bytes) - 1;
311    
312            if ( $len_real != $len ) {
313                    print "length wrong: $len_real != $len\n";
314                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
315          }          }
316    
317            if ( defined $checksum && $xor ne $checksum ) {
318                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
319                    return $bytes . $xor;
320            }
321            return $bytes . $checksum;
322  }  }
323    
324  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
325    
326    sub readchunk {
327          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
328    
329          # read header of packet          # read header of packet
# Line 228  sub readchunk { Line 331  sub readchunk {
331          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
332          my $len = ord($length);          my $len = ord($length);
333          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
334    
335          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
336          my $payload_len = length($data);          my $payload_len = length($data);
337          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
338    
339          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
340          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
341    
342          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;
343    
344          $assert->{len}      = $len;          $assert->{len}      = $len;
345          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
346    
347          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
348            # find longest match for incomming data
349            my ($to) = grep {
350                    my $match = substr($payload,0,length($_));
351                    m/^\Q$match\E/
352            } sort { length($a) <=> length($b) } keys %$dispatch;
353            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
354    
355            if ( defined $to ) {
356                    my $rest = substr( $payload, length($to) );
357                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
358                    $dispatch->{ $to }->( $rest );
359            } else {
360                    print "NO DISPATCH for ",dump( $full ),"\n";
361            }
362    
363          return $data;          return $data;
364  }  }
# Line 250  sub readchunk { Line 366  sub readchunk {
366  sub str2bytes {  sub str2bytes {
367          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
368          my $b = $str;          my $b = $str;
369          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
370          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
371          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
372          my $bytes = eval $b;          my $bytes = eval $b;
373          die $@ if $@;          die $@ if $@;
374          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 261  sub str2bytes { Line 376  sub str2bytes {
376  }  }
377    
378  sub cmd {  sub cmd {
379          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
380            my $cmd_desc = shift || confess "no description?";
381            my @expect = @_;
382    
383          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
384    
385          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
386            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
387    
388            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
389          $assert->{send} = $cmd;          $assert->{send} = $cmd;
390          writechunk( $bytes );          writechunk( $bytes );
391    
392          if ( $expect ) {          while ( @expect ) {
393                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
394                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
395                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
396    
397                    next if defined $dispatch->{ $pattern };
398    
399                    $dispatch->{ substr($pattern,3) } = $coderef;
400                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
401          }          }
402    
403            readchunk;
404  }  }
405    
Legend:
Removed from v.6  
changed lines
  Added in v.22
  ViewVC Help
Powered by ViewVC 1.1.26