/[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 2 by dpavlin, Sun Sep 28 14:05:43 2008 UTC revision 20 by dpavlin, Fri Oct 3 21:25:02 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;
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?',
# Line 19  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  =head1 NAME  =head1 NAME
43    
44  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
45    
46  =head1 SYNOPSIS  =head1 SYNOPSIS
47    
48  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
49    
50  =head1 DESCRIPTION  =head1 DESCRIPTION
51    
# Line 37  L<Device::SerialPort(3)> Line 57  L<Device::SerialPort(3)>
57    
58  L<perl(1)>  L<perl(1)>
59    
60    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
61    
62  =head1 AUTHOR  =head1 AUTHOR
63    
64  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 70  it under the same terms ans Perl itself.
70    
71  =cut  =cut
72    
73  # your serial port.  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
74  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";  
75  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
76  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
77  $databits=$port->databits($databits);  $databits=$port->databits($databits);
# Line 75  $port->read_char_time(5); Line 89  $port->read_char_time(5);
89  #$port->stty_inpck(1);  #$port->stty_inpck(1);
90  #$port->stty_istrip(1);  #$port->stty_istrip(1);
91    
92  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
93       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
94          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
95          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
96          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
97  });  });
98    
99  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?',
100  #     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() }  );
101    
102    # start scanning for tags
103    
104    cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
105         'D6 00  07   FE  00 00  05     00  C97B', sub {
106                    assert();
107                    print "no tag in range\n";
108    
109  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",          },
110       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
111                    my $rest = shift || die "no rest?";
112                    my $nr = ord( substr( $rest, 0, 1 ) );
113    
114  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen                  if ( ! $nr ) {
115                            print "no tags in range\n";
116                    } else {
117    
118  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );                          my $tags = substr( $rest, 1 );
119    
120  #     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 $tl = length( $tags );
121  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";                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
122    
123  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );                          my @tags;
124                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
125                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
126                            print "seen $nr tags: ", join(',', @tags ) , "\n";
127    
128  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00                            # read data from tag
129  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          read_tag( $_ ) foreach @tags;
130  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
131                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";                  }
132  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";          }
133    ) foreach ( 1 .. 100 );
134    
135    my $read_cached;
136    
137    sub read_tag {
138            my ( $tag ) = @_;
139    
140            return if $read_cached->{ $tag }++;
141            
142            print "read_tag $tag\n";
143    
144            cmd(
145                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
146                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
147                            print "FIXME: tag $tag ready?\n";
148                    },
149                    "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";
150                            my $rest = shift || die "no rest?";
151                            warn "## DATA ", dump( $rest ) if $debug;
152                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
153                            my $blocks = ord(substr($rest,8,1));
154                            $rest = substr($rest,9); # leave just data blocks
155                            my @data;
156                            foreach my $nr ( 0 .. $blocks - 1 ) {
157                                    my $block = substr( $rest, $nr * 6, 6 );
158                                    warn "## block ",as_hex( $block ) if $debug;
159                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
160                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
161                                    my $data  = substr( $block, 2 );
162                                    die "data payload should be 4 bytes" if length($data) != 4;
163                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
164                                    $data[ $ord ] = $data;
165                            }
166                            $read_cached->{ $tag } = join('', @data);
167                            print "DATA $tag ",dump( $read_cached ), "\n";
168                    }
169            );
170    
171            #        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
172    if (0) {
173            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
174    
175            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
176            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
177            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
178    }
179            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
180    
181    }
182    
183    exit;
184    
185  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
186    
# Line 133  sub writechunk Line 212  sub writechunk
212  {  {
213          my $str=shift;          my $str=shift;
214          my $count = $port->write($str);          my $count = $port->write($str);
215          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
216  }  }
217    
218  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 220  sub as_hex {
220          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
221                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
222                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
223                    $hex =~ s/\s+$//;
224                  push @out, $hex;                  push @out, $hex;
225          }          }
226          return join('  ', @out);          return join(' | ', @out);
227  }  }
228    
229  sub read_bytes {  sub read_bytes {
# Line 155  sub read_bytes { Line 235  sub read_bytes {
235                  $data .= $b;                  $data .= $b;
236          }          }
237          $desc ||= '?';          $desc ||= '?';
238          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
239          return $data;          return $data;
240  }  }
241    
242  my $assert;  our $assert;
243    
244    # my $rest = skip_assert( 3 );
245    sub skip_assert {
246            assert( 0, shift );
247    }
248    
249  sub assert {  sub assert {
250          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
251    
252          warn "# assert ", dump( $assert );          $from ||= 0;
253            $to = length( $assert->{expect} ) if ! defined $to;
254    
255          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
256          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
257          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), "\t[$from-$to]\n" if $e ne $p;          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
258    
259            # return the rest
260            return substr( $assert->{payload}, $to );
261  }  }
262    
263  sub readchunk {  use Digest::CRC;
264          my ( $parser ) = @_;  
265    sub crcccitt {
266            my $bytes = shift;
267            my $crc = Digest::CRC->new(
268                    # midified CCITT to xor with 0xffff instead of 0x0000
269                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
270            ) or die $!;
271            $crc->add( $bytes );
272            pack('n', $crc->digest);
273    }
274    
275    # my $checksum = checksum( $bytes );
276    # my $checksum = checksum( $bytes, $original_checksum );
277    sub checksum {
278            my ( $bytes, $checksum ) = @_;
279    
280            my $xor = crcccitt( substr($bytes,1) ); # skip D6
281            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
282    
283            my $len = ord(substr($bytes,2,1));
284            my $len_real = length($bytes) - 1;
285    
286            if ( $len_real != $len ) {
287                    print "length wrong: $len_real != $len\n";
288                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
289            }
290    
291            if ( defined $checksum && $xor ne $checksum ) {
292                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
293                    return $bytes . $xor;
294            }
295            return $bytes . $checksum;
296    }
297    
298    our $dispatch;
299    
300    sub readchunk {
301          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
302    
303          # read header of packet          # read header of packet
# Line 181  sub readchunk { Line 305  sub readchunk {
305          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
306          my $len = ord($length);          my $len = ord($length);
307          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
308    
309          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
310          my $payload_len = length($data);          my $payload_len = length($data);
311          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
312    
313          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
314          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
315    
316          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";
317    
318          $assert->{len}      = $len;          $assert->{len}      = $len;
319          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
320    
321          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
322            # find longest match for incomming data
323            my ($to) = grep {
324                    my $match = substr($payload,0,length($_));
325                    m/^\Q$match\E/
326            } sort { length($a) <=> length($b) } keys %$dispatch;
327            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
328    
329            if ( defined $to ) {
330                    my $rest = substr( $payload, length($to) );
331                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
332                    $dispatch->{ $to }->( $rest );
333            } else {
334                    print "NO DISPATCH for ",dump( $full ),"\n";
335            }
336    
337          return $data;          return $data;
338  }  }
339    
340  sub str2bytes {  sub str2bytes {
341          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
342          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
343          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
344          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
345          my $bytes = eval $str;          $b = "\"$b\"";
346            my $bytes = eval $b;
347          die $@ if $@;          die $@ if $@;
348            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
349          return $bytes;          return $bytes;
350  }  }
351    
352  sub cmd {  sub cmd {
353          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
354            my $cmd_desc = shift || confess "no description?";
355            my @expect = @_;
356    
357          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
358    
359            # fix checksum if needed
360            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
361    
362          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
363          $assert->{send} = $cmd;          $assert->{send} = $cmd;
364          writechunk( $bytes );          writechunk( $bytes );
365    
366          if ( $expect ) {          while ( @expect ) {
367                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
368                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
369                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
370    
371                    next if defined $dispatch->{ $pattern };
372    
373                    $dispatch->{ substr($pattern,3) } = $coderef;
374                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
375          }          }
376    
377            readchunk;
378  }  }
379    
Legend:
Removed from v.2  
changed lines
  Added in v.20
  ViewVC Help
Powered by ViewVC 1.1.26