/[RFID]/cpr-m02.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 /cpr-m02.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 16 by dpavlin, Thu Oct 2 22:53:57 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;  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  =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 52  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 81  $port->read_char_time(5); Line 91  $port->read_char_time(5);
91    
92  # initial hand-shake with device  # initial hand-shake with device
93    
94  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
95       '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 {
96          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\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','FIXME: unimplemented', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
101    
102  # start scanning for tags  # start scanning for tags
103    
104  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
105       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {       'D6 00  07   FE  00 00  05     00  C97B', sub {
106  dispatch(                  assert();
107           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  print "no tag in range\n";
108                  sub {  
109                          my $rest = shift || die "no rest?";          },
110                          my $nr = ord( substr( $rest, 0, 1 ) );           '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                    if ( ! $nr ) {
115                            print "no tags in range\n";
116                    } else {
117    
118                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
119    
120                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 108  dispatch( Line 125  dispatch(
125                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
126                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "seen $nr tags: ", join(',', @tags ) , "\n";
127    
128                          # XXX read first tag                          # read data from tag
129                          read_tag( @tags );                          read_tag( $_ ) foreach @tags;
130    
131                  }                  }
132  ) }          }
   
133  ) foreach ( 1 .. 100 );  ) foreach ( 1 .. 100 );
134    
135  my $read_cached;  my $read_cached;
# Line 121  my $read_cached; Line 137  my $read_cached;
137  sub read_tag {  sub read_tag {
138          my ( $tag ) = @_;          my ( $tag ) = @_;
139    
         print "read_tag $tag\n";  
140          return if $read_cached->{ $tag }++;          return if $read_cached->{ $tag }++;
141            
142            print "read_tag $tag\n";
143    
144          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          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          #        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
         warn "?? D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";  
172  if (0) {  if (0) {
173          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
174    
# Line 139  if (0) { Line 180  if (0) {
180    
181  }  }
182    
183    exit;
184    
185  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
186    
187  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  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 217  sub assert { Line 260  sub assert {
260          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
261  }  }
262    
 our $dispatch;  
 sub dispatch {  
         my ( $pattern, $coderef ) = @_;  
         my $patt = substr( str2bytes($pattern), 3 ); # just payload  
         my $l = length($patt);  
         my $p = substr( $assert->{payload}, 0, $l );  
         warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;  
   
         if ( $assert->{payload} eq $assert->{expect} ) {  
                 warn "## no dispatch, payload expected" if $debug;  
         } elsif ( $p eq $patt ) {  
                 # if matched call with rest of payload  
                 $coderef->( substr( $assert->{payload}, $l ) );  
         } else {  
                 warn "## dispatch ignored" if $debug;  
         }  
 }  
   
263  use Digest::CRC;  use Digest::CRC;
264    
265  sub crcccitt {  sub crcccitt {
# Line 256  sub checksum { Line 281  sub checksum {
281          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
282    
283          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
284          my $len_real = length($bytes);          my $len_real = length($bytes) - 1;
285          print "length wrong: $len_real != $len\n" if $len_real != $len;  
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 ) {          if ( defined $checksum && $xor ne $checksum ) {
292                  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";
# Line 266  sub checksum { Line 295  sub checksum {
295          return $bytes . $checksum;          return $bytes . $checksum;
296  }  }
297    
298  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
299    
300    sub readchunk {
301          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
302    
303          # read header of packet          # read header of packet
# Line 282  sub readchunk { Line 311  sub readchunk {
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          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
315    
316          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";
317    
318          $assert->{len}      = $len;          $assert->{len}      = $len;
319          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
320    
321          $parser->( $len, $payload ) 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  }  }
# Line 297  sub readchunk { Line 340  sub readchunk {
340  sub str2bytes {  sub str2bytes {
341          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
342          my $b = $str;          my $b = $str;
343          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
344          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
345          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
346          my $bytes = eval $b;          my $bytes = eval $b;
347          die $@ if $@;          die $@ if $@;
348          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 308  sub str2bytes { Line 350  sub str2bytes {
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          # fix checksum if needed
# Line 318  sub cmd { Line 363  sub cmd {
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.16  
changed lines
  Added in v.20
  ViewVC Help
Powered by ViewVC 1.1.26