/[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 19 by dpavlin, Fri Oct 3 15:38:08 2008 UTC revision 25 by dpavlin, Sun Mar 29 01:05:49 2009 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10    
11    use IO::Socket::INET;
12    
13    my $meteor_server = '192.168.1.13:4671';
14    
15    my $meteor = IO::Socket::INET->new( $meteor_server )
16             || die "can't connect to meteor $meteor_server: $!";
17    
18    sub meteor {
19            my @a = @_;
20            push @a, scalar localtime() if $a[0] =~ m{^info};
21    
22            warn ">> meteor ",dump( @a );
23            print $meteor "ADDMESSAGE test ",join('|',@a),"\n";
24    }
25    
26  my $debug = 0;  my $debug = 0;
27    
28  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 30  my $response = { Line 45  my $response = {
45  };  };
46    
47  GetOptions(  GetOptions(
48          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
49          'device=s'    => \$device,          'device=s'    => \$device,
50          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
51          'databits=i'  => \$databits,          'databits=i'  => \$databits,
# Line 39  GetOptions( Line 54  GetOptions(
54          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
55  ) or die $!;  ) or die $!;
56    
57    my $verbose = $debug > 0 ? $debug-- : 0;
58    
59  =head1 NAME  =head1 NAME
60    
61  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
# Line 70  it under the same terms ans Perl itself. Line 87  it under the same terms ans Perl itself.
87    
88  =cut  =cut
89    
90    my $tags_data;
91    my $visible_tags;
92    
93  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";
94  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
95  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 98  $databits=$port->databits($databits);
98  $parity=$port->parity($parity);  $parity=$port->parity($parity);
99  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
100    
101  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
102    
103  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
104  $port->lookclear();  $port->lookclear();
# Line 91  $port->read_char_time(5); Line 111  $port->read_char_time(5);
111    
112  # initial hand-shake with device  # initial hand-shake with device
113    
114  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
115       '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 {
116          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
117            print "hardware version $hw_ver\n";
118            meteor( 'info', "Found reader hardware $hw_ver" );
119  });  });
120    
121  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?',
122       '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() }  );
123    
124  # start scanning for tags  # start scanning for tags
125    
126  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
127       '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
128  dispatch(                  my $rest = shift || die "no rest?";
129           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
130                  sub {  
131                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
132                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
133                            update_visible_tags();
134                            meteor( 'info-none-in-range' );
135                            $tags_data = {};
136                    } else {
137    
138                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
139    
140                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 116  dispatch( Line 143  dispatch(
143                          my @tags;                          my @tags;
144                          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 );
145                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
146                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
147    
148                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
149    
150                            update_visible_tags( @tags );
151                  }                  }
152  ) }          }
153    ) while(1);
154    #) foreach ( 1 .. 100 );
155    
156    
157    
158    sub update_visible_tags {
159            my @tags = @_;
160    
161            my $last_visible_tags = $visible_tags;
162            $visible_tags = {};
163    
164            foreach my $tag ( @tags ) {
165                    if ( ! defined $last_visible_tags->{$tag} ) {
166                            if ( defined $tags_data->{$tag} ) {
167    #                               meteor( 'in-range', $tag );
168                            } else {
169                                    meteor( 'read', $tag );
170                                    read_tag( $tag );
171                            }
172                            $visible_tags->{$tag}++;
173                    } else {
174                            warn "## using cached data for $tag" if $debug;
175                    }
176                    delete $last_visible_tags->{$tag}; # leave just missing tags
177            }
178    
179            foreach my $tag ( keys %$last_visible_tags ) {
180                    my $data = delete $tags_data->{$tag};
181                    print "removed tag $tag with data ",dump( $data ),"\n";
182                    meteor( 'removed', $tag );
183            }
184    
185  ) foreach ( 1 .. 100 );          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
186    }
187    
 my $read_cached;  
188    
189  sub read_tag {  sub read_tag {
190          my ( $tag ) = @_;          my ( $tag ) = @_;
191    
192            confess "no tag?" unless $tag;
193    
194          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
195    
196          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          cmd(
197                          "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',
198  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 {
199                            print "FIXME: tag $tag ready?\n";
200                    },
201                    "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";
202                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
203                          warn "## DATA ", dump( $rest ) if $debug;                          warn "## DATA ", dump( $rest ) if $debug;
204                          my $blocks = ord(substr($rest,0,1));                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
205                            my $blocks = ord(substr($rest,8,1));
206                            $rest = substr($rest,9); # leave just data blocks
207                          my @data;                          my @data;
208                          foreach my $nr ( 0 .. $blocks - 1 ) {                          foreach my $nr ( 0 .. $blocks - 1 ) {
209                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  my $block = substr( $rest, $nr * 6, 6 );
210                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "## block ",as_hex( $block ) if $debug;
211                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                                  my $ord   = unpack('v',substr( $block, 0, 2 ));
212                                  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 215  dispatch(      "D6 00  1F  02 00   $tag   ",
215                                  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;
216                                  $data[ $ord ] = $data;                                  $data[ $ord ] = $data;
217                          }                          }
218                          $read_cached->{ $tag } = join('', @data);                          $tags_data->{ $tag } = join('', @data);
219                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";                          print "DATA $tag ",dump( $tags_data ), "\n";
220                  })                  }
221          });          );
222    
223          #        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
224  if (0) {  if (0) {
# Line 248  sub assert { Line 312  sub assert {
312          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
313  }  }
314    
 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;  
         }  
 }  
   
315  use Digest::CRC;  use Digest::CRC;
316    
317  sub crcccitt {  sub crcccitt {
# Line 304  sub checksum { Line 347  sub checksum {
347          return $bytes . $checksum;          return $bytes . $checksum;
348  }  }
349    
350  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
351    
352    sub readchunk {
353          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
354    
355          # read header of packet          # read header of packet
# Line 320  sub readchunk { Line 363  sub readchunk {
363          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
364    
365          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
366          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
367    
368          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;
369    
370          $assert->{len}      = $len;          $assert->{len}      = $len;
371          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
372    
373          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
374            # find longest match for incomming data
375            my ($to) = grep {
376                    my $match = substr($payload,0,length($_));
377                    m/^\Q$match\E/
378            } sort { length($a) <=> length($b) } keys %$dispatch;
379            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
380    
381            if ( defined $to ) {
382                    my $rest = substr( $payload, length($to) );
383                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
384                    $dispatch->{ $to }->( $rest );
385            } else {
386                    print "NO DISPATCH for ",dump( $full ),"\n";
387            }
388    
389          return $data;          return $data;
390  }  }
# Line 345  sub str2bytes { Line 402  sub str2bytes {
402  }  }
403    
404  sub cmd {  sub cmd {
405          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
406            my $cmd_desc = shift || confess "no description?";
407            my @expect = @_;
408    
409          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
410    
411          # fix checksum if needed          # fix checksum if needed
412          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
413    
414          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
415          $assert->{send} = $cmd;          $assert->{send} = $cmd;
416          writechunk( $bytes );          writechunk( $bytes );
417    
418          if ( $expect ) {          while ( @expect ) {
419                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
420                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
421                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
422    
423                    next if defined $dispatch->{ $pattern };
424    
425                    $dispatch->{ substr($pattern,3) } = $coderef;
426                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
427          }          }
428    
429            readchunk;
430  }  }
431    
Legend:
Removed from v.19  
changed lines
  Added in v.25
  ViewVC Help
Powered by ViewVC 1.1.26