/[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 26 by dpavlin, Wed Apr 1 16:59:09 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    my $meteor_fh;
15    
16    sub meteor {
17            my @a = @_;
18            push @a, scalar localtime() if $a[0] =~ m{^info};
19    
20            if ( ! defined $meteor_fh ) {
21                    $meteor_fh = IO::Socket::INET->new( $meteor_server )
22                            || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
23                    $meteor_fh = 0; # don't try again
24            }
25    
26            warn ">> meteor ",dump( @a );
27            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
28    }
29    
30  my $debug = 0;  my $debug = 0;
31    
32  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 30  my $response = { Line 49  my $response = {
49  };  };
50    
51  GetOptions(  GetOptions(
52          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
53          'device=s'    => \$device,          'device=s'    => \$device,
54          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
55          'databits=i'  => \$databits,          'databits=i'  => \$databits,
56          'parity=s'    => \$parity,          'parity=s'    => \$parity,
57          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
58          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
59            'meteor=s'    => \$meteor_server,
60  ) or die $!;  ) or die $!;
61    
62    my $verbose = $debug > 0 ? $debug-- : 0;
63    
64  =head1 NAME  =head1 NAME
65    
66  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 92  it under the same terms ans Perl itself.
92    
93  =cut  =cut
94    
95    my $tags_data;
96    my $visible_tags;
97    
98  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";
99  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
100  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 103  $databits=$port->databits($databits);
103  $parity=$port->parity($parity);  $parity=$port->parity($parity);
104  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
105    
106  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
107    
108  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
109  $port->lookclear();  $port->lookclear();
# Line 91  $port->read_char_time(5); Line 116  $port->read_char_time(5);
116    
117  # initial hand-shake with device  # initial hand-shake with device
118    
119  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
120       '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 {
121          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
122            print "hardware version $hw_ver\n";
123            meteor( 'info', "Found reader hardware $hw_ver" );
124  });  });
125    
126  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?',
127       '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() }  );
128    
129  # start scanning for tags  # start scanning for tags
130    
131  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
132       '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
133  dispatch(                  my $rest = shift || die "no rest?";
134           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
135                  sub {  
136                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
137                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
138                            update_visible_tags();
139                            meteor( 'info-none-in-range' );
140                            $tags_data = {};
141                    } else {
142    
143                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
144    
145                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 116  dispatch( Line 148  dispatch(
148                          my @tags;                          my @tags;
149                          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 );
150                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
151                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
152    
153                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
154    
155                            update_visible_tags( @tags );
156                  }                  }
157  ) }          }
158    ) while(1);
159    #) foreach ( 1 .. 100 );
160    
161    
162    
163    sub update_visible_tags {
164            my @tags = @_;
165    
166            my $last_visible_tags = $visible_tags;
167            $visible_tags = {};
168    
169            foreach my $tag ( @tags ) {
170                    if ( ! defined $last_visible_tags->{$tag} ) {
171                            if ( defined $tags_data->{$tag} ) {
172    #                               meteor( 'in-range', $tag );
173                            } else {
174                                    meteor( 'read', $tag );
175                                    read_tag( $tag );
176                            }
177                            $visible_tags->{$tag}++;
178                    } else {
179                            warn "## using cached data for $tag" if $debug;
180                    }
181                    delete $last_visible_tags->{$tag}; # leave just missing tags
182            }
183    
184            foreach my $tag ( keys %$last_visible_tags ) {
185                    my $data = delete $tags_data->{$tag};
186                    print "removed tag $tag with data ",dump( $data ),"\n";
187                    meteor( 'removed', $tag );
188            }
189    
190  ) foreach ( 1 .. 100 );          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
191    }
192    
 my $read_cached;  
193    
194  sub read_tag {  sub read_tag {
195          my ( $tag ) = @_;          my ( $tag ) = @_;
196    
197            confess "no tag?" unless $tag;
198    
199          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
200    
201          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          cmd(
202                          "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',
203  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 {
204                            print "FIXME: tag $tag ready?\n";
205                    },
206                    "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";
207                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
208                          warn "## DATA ", dump( $rest ) if $debug;                          warn "## DATA ", dump( $rest ) if $debug;
209                          my $blocks = ord(substr($rest,0,1));                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
210                            my $blocks = ord(substr($rest,8,1));
211                            $rest = substr($rest,9); # leave just data blocks
212                          my @data;                          my @data;
213                          foreach my $nr ( 0 .. $blocks - 1 ) {                          foreach my $nr ( 0 .. $blocks - 1 ) {
214                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  my $block = substr( $rest, $nr * 6, 6 );
215                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "## block ",as_hex( $block ) if $debug;
216                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                                  my $ord   = unpack('v',substr( $block, 0, 2 ));
217                                  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 220  dispatch(      "D6 00  1F  02 00   $tag   ",
220                                  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;
221                                  $data[ $ord ] = $data;                                  $data[ $ord ] = $data;
222                          }                          }
223                          $read_cached->{ $tag } = join('', @data);                          $tags_data->{ $tag } = join('', @data);
224                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";                          print "DATA $tag ",dump( $tags_data ), "\n";
225                  })                  }
226          });          );
227    
228          #        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
229  if (0) {  if (0) {
# Line 248  sub assert { Line 317  sub assert {
317          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
318  }  }
319    
 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;  
         }  
 }  
   
320  use Digest::CRC;  use Digest::CRC;
321    
322  sub crcccitt {  sub crcccitt {
# Line 304  sub checksum { Line 352  sub checksum {
352          return $bytes . $checksum;          return $bytes . $checksum;
353  }  }
354    
355  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
356    
357    sub readchunk {
358          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
359    
360          # read header of packet          # read header of packet
# Line 320  sub readchunk { Line 368  sub readchunk {
368          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
369    
370          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
371          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
372    
373          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;
374    
375          $assert->{len}      = $len;          $assert->{len}      = $len;
376          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
377    
378          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
379            # find longest match for incomming data
380            my ($to) = grep {
381                    my $match = substr($payload,0,length($_));
382                    m/^\Q$match\E/
383            } sort { length($a) <=> length($b) } keys %$dispatch;
384            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
385    
386            if ( defined $to ) {
387                    my $rest = substr( $payload, length($to) );
388                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
389                    $dispatch->{ $to }->( $rest );
390            } else {
391                    print "NO DISPATCH for ",dump( $full ),"\n";
392            }
393    
394          return $data;          return $data;
395  }  }
# Line 345  sub str2bytes { Line 407  sub str2bytes {
407  }  }
408    
409  sub cmd {  sub cmd {
410          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
411            my $cmd_desc = shift || confess "no description?";
412            my @expect = @_;
413    
414          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
415    
416          # fix checksum if needed          # fix checksum if needed
417          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
418    
419          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
420          $assert->{send} = $cmd;          $assert->{send} = $cmd;
421          writechunk( $bytes );          writechunk( $bytes );
422    
423          if ( $expect ) {          while ( @expect ) {
424                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
425                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
426                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
427    
428                    next if defined $dispatch->{ $pattern };
429    
430                    $dispatch->{ substr($pattern,3) } = $coderef;
431                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
432          }          }
433    
434            readchunk;
435  }  }
436    
Legend:
Removed from v.19  
changed lines
  Added in v.26
  ViewVC Help
Powered by ViewVC 1.1.26