/[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 19 by dpavlin, Fri Oct 3 15:38:08 2008 UTC revision 21 by dpavlin, Fri Oct 3 21:47:24 2008 UTC
# Line 70  it under the same terms ans Perl itself. Line 70  it under the same terms ans Perl itself.
70    
71  =cut  =cut
72    
73    my $tags_data;
74    my $visible_tags;
75    
76  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
77  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
78  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 91  $port->read_char_time(5); Line 94  $port->read_char_time(5);
94    
95  # initial hand-shake with device  # initial hand-shake with device
96    
97  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
98       '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 {
99          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
100  });  });
101    
102  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?',
103       '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() }  );
104    
105  # start scanning for tags  # start scanning for tags
106    
107  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
108       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {       'D6 00  07   FE  00 00  05     00  C97B', sub {
109  dispatch(                  assert();
110           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  print "no tag in range\n";
111                  sub {  
112                          my $rest = shift || die "no rest?";          },
113                          my $nr = ord( substr( $rest, 0, 1 ) );           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
114                    my $rest = shift || die "no rest?";
115                    my $nr = ord( substr( $rest, 0, 1 ) );
116    
117                    if ( ! $nr ) {
118                            print "no tags in range\n";
119                    } else {
120    
121                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
122    
123                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 118  dispatch( Line 128  dispatch(
128                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
129                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "seen $nr tags: ", join(',', @tags ) , "\n";
130    
131                          # read data from tag                          my $removed_tags = $visible_tags;
132                          read_tag( $_ ) foreach @tags;                          $visible_tags = {};
133    
134                  }                          foreach my $tag ( @tags ) {
135  ) }                                  next if $visible_tags->{$tag}++;
136                                    read_tag( $tag );
137                                    if ( delete $removed_tags->{$tag} ) {
138                                            print "removed tag $tag\n";
139                                    }
140                            }
141    
142                    }
143            }
144  ) foreach ( 1 .. 100 );  ) foreach ( 1 .. 100 );
145    
 my $read_cached;  
   
146  sub read_tag {  sub read_tag {
147          my ( $tag ) = @_;          my ( $tag ) = @_;
148    
149          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
150    
151          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          cmd(
152                          "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
153  dispatch(       "D6 00  1F  02 00   $tag   ", sub { # 03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
154                            print "FIXME: tag $tag ready?\n";
155                    },
156                    "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";
157                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
158                          warn "## DATA ", dump( $rest ) if $debug;                          warn "## DATA ", dump( $rest ) if $debug;
159                          my $blocks = ord(substr($rest,0,1));                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
160                            my $blocks = ord(substr($rest,8,1));
161                            $rest = substr($rest,9); # leave just data blocks
162                          my @data;                          my @data;
163                          foreach my $nr ( 0 .. $blocks - 1 ) {                          foreach my $nr ( 0 .. $blocks - 1 ) {
164                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  my $block = substr( $rest, $nr * 6, 6 );
165                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "## block ",as_hex( $block ) if $debug;
166                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                                  my $ord   = unpack('v',substr( $block, 0, 2 ));
167                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
# Line 151  dispatch(      "D6 00  1F  02 00   $tag   ", Line 170  dispatch(      "D6 00  1F  02 00   $tag   ",
170                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
171                                  $data[ $ord ] = $data;                                  $data[ $ord ] = $data;
172                          }                          }
173                          $read_cached->{ $tag } = join('', @data);                          $tags_data->{ $tag } = join('', @data);
174                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";                          print "DATA $tag ",dump( $tags_data ), "\n";
175                  })                  }
176          });          );
177    
178          #        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
179  if (0) {  if (0) {
# Line 248  sub assert { Line 267  sub assert {
267          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
268  }  }
269    
 our $dispatch;  
 sub dispatch {  
         my ( $pattern, $coderef ) = @_;  
   
         $dispatch->{ $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;  
         }  
 }  
   
270  use Digest::CRC;  use Digest::CRC;
271    
272  sub crcccitt {  sub crcccitt {
# Line 304  sub checksum { Line 302  sub checksum {
302          return $bytes . $checksum;          return $bytes . $checksum;
303  }  }
304    
305  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
306    
307    sub readchunk {
308          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
309    
310          # read header of packet          # read header of packet
# Line 320  sub readchunk { Line 318  sub readchunk {
318          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
319    
320          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
321          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
322    
323          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";
324    
325          $assert->{len}      = $len;          $assert->{len}      = $len;
326          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
327    
328          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
329            # find longest match for incomming data
330            my ($to) = grep {
331                    my $match = substr($payload,0,length($_));
332                    m/^\Q$match\E/
333            } sort { length($a) <=> length($b) } keys %$dispatch;
334            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
335    
336            if ( defined $to ) {
337                    my $rest = substr( $payload, length($to) );
338                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
339                    $dispatch->{ $to }->( $rest );
340            } else {
341                    print "NO DISPATCH for ",dump( $full ),"\n";
342            }
343    
344          return $data;          return $data;
345  }  }
# Line 345  sub str2bytes { Line 357  sub str2bytes {
357  }  }
358    
359  sub cmd {  sub cmd {
360          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
361            my $cmd_desc = shift || confess "no description?";
362            my @expect = @_;
363    
364          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
365    
366          # fix checksum if needed          # fix checksum if needed
# Line 355  sub cmd { Line 370  sub cmd {
370          $assert->{send} = $cmd;          $assert->{send} = $cmd;
371          writechunk( $bytes );          writechunk( $bytes );
372    
373          if ( $expect ) {          while ( @expect ) {
374                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
375                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
376                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
377    
378                    next if defined $dispatch->{ $pattern };
379    
380                    $dispatch->{ substr($pattern,3) } = $coderef;
381                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
382          }          }
383    
384            readchunk;
385  }  }
386    
Legend:
Removed from v.19  
changed lines
  Added in v.21
  ViewVC Help
Powered by ViewVC 1.1.26