/[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 16 by dpavlin, Thu Oct 2 22:53:57 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 52  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 81  $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 );
# Line 106  dispatch( Line 121  dispatch(
121                          my @tags;                          my @tags;
122                          push @tags, uc(unpack('H16', 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 ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
124                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
125    
126                          # XXX read first tag                          update_visible_tags( @tags );
                         read_tag( @tags );  
127    
128                  }                  }
129  ) }          }
   
130  ) foreach ( 1 .. 100 );  ) foreach ( 1 .. 100 );
131    
132  my $read_cached;  
133    
134    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 {  sub read_tag {
162          my ( $tag ) = @_;          my ( $tag ) = @_;
163    
164            confess "no tag?" unless $tag;
165    
166            return if defined $tags_data->{$tag};
167    
168          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
169    
170          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          cmd(
171                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
172                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
173                            print "FIXME: tag $tag ready?\n";
174                    },
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          #        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";  
198  if (0) {  if (0) {
199          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' );
200    
# Line 139  if (0) { Line 206  if (0) {
206    
207  }  }
208    
209    exit;
210    
211  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
212    
213  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  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 217  sub assert { Line 286  sub assert {
286          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
287  }  }
288    
 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;  
         }  
 }  
   
289  use Digest::CRC;  use Digest::CRC;
290    
291  sub crcccitt {  sub crcccitt {
# Line 256  sub checksum { Line 307  sub checksum {
307          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
308    
309          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
310          my $len_real = length($bytes);          my $len_real = length($bytes) - 1;
311          print "length wrong: $len_real != $len\n" if $len_real != $len;  
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 ) {          if ( defined $checksum && $xor ne $checksum ) {
318                  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 321  sub checksum {
321          return $bytes . $checksum;          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 282  sub readchunk { Line 337  sub readchunk {
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          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
341    
342          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;
343    
344          $assert->{len}      = $len;          $assert->{len}      = $len;
345          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
346    
347          $parser->( $len, $payload ) 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 297  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 308  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          # fix checksum if needed          # fix checksum if needed
386          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
387    
388          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          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.16  
changed lines
  Added in v.22

  ViewVC Help
Powered by ViewVC 1.1.26