/[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 18 by dpavlin, Fri Oct 3 12:31:58 2008 UTC revision 29 by dpavlin, Mon Apr 6 13:10:40 2009 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    use File::Slurp;
11    
12    use IO::Socket::INET;
13    
14    my $meteor_server = '192.168.1.13:4671';
15    my $meteor_fh;
16    
17    sub meteor {
18            my @a = @_;
19            push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21            if ( ! defined $meteor_fh ) {
22                    warn "# open connection to $meteor_server";
23                    $meteor_fh = IO::Socket::INET->new(
24                                    PeerAddr => $meteor_server,
25                                    Timeout => 1,
26                    ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
27                    $meteor_fh = 0; # don't try again
28            }
29    
30            warn ">> meteor ",dump( @a );
31            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
32    }
33    
34  my $debug = 0;  my $debug = 0;
35    
36    my $device    = "/dev/ttyUSB0";
37    my $baudrate  = "19200";
38    my $databits  = "8";
39    my $parity        = "none";
40    my $stopbits  = "1";
41    my $handshake = "none";
42    
43    my $program_path = './program/';
44    
45  my $response = {  my $response = {
46          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
47          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 54  my $response = {
54          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
55  };  };
56    
57    GetOptions(
58            'd|debug+'    => \$debug,
59            'device=s'    => \$device,
60            'baudrate=i'  => \$baudrate,
61            'databits=i'  => \$databits,
62            'parity=s'    => \$parity,
63            'stopbits=i'  => \$stopbits,
64            'handshake=s' => \$handshake,
65            'meteor=s'    => \$meteor_server,
66    ) or die $!;
67    
68    my $verbose = $debug > 0 ? $debug-- : 0;
69    
70  =head1 NAME  =head1 NAME
71    
72  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
73    
74  =head1 SYNOPSIS  =head1 SYNOPSIS
75    
76  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
77    
78  =head1 DESCRIPTION  =head1 DESCRIPTION
79    
# Line 52  it under the same terms ans Perl itself. Line 98  it under the same terms ans Perl itself.
98    
99  =cut  =cut
100    
101  # your serial port.  my $tags_data;
102  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
103    
104  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
105    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
106  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
107  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
108  $databits=$port->databits($databits);  $databits=$port->databits($databits);
109  $parity=$port->parity($parity);  $parity=$port->parity($parity);
110  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
111    
112  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
113    
114  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
115  $port->lookclear();  $port->lookclear();
# Line 81  $port->read_char_time(5); Line 122  $port->read_char_time(5);
122    
123  # initial hand-shake with device  # initial hand-shake with device
124    
125  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
126       '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 {
127          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
128            print "hardware version $hw_ver\n";
129            meteor( 'info', "Found reader hardware $hw_ver" );
130  });  });
131    
132  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?',
133       '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() }  );
134    
135  # start scanning for tags  # start scanning for tags
136    
137  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
138       '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
139  dispatch(                  my $rest = shift || die "no rest?";
140           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
141                  sub {  
142                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
143                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
144                            update_visible_tags();
145                            meteor( 'info-none-in-range' );
146                            $tags_data = {};
147                    } else {
148    
149                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
150    
151                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 106  dispatch( Line 154  dispatch(
154                          my @tags;                          my @tags;
155                          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 );
156                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
157                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
158    
159                          # XXX read first tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( @tags );  
160    
161                            update_visible_tags( @tags );
162                  }                  }
163  ) }          }
164    ) while(1);
165    #) foreach ( 1 .. 100 );
166    
167    
168    
169  ) foreach ( 1 .. 100 );  sub update_visible_tags {
170            my @tags = @_;
171    
172  my $read_cached;          my $last_visible_tags = $visible_tags;
173            $visible_tags = {};
174    
175            foreach my $tag ( @tags ) {
176                    if ( ! defined $last_visible_tags->{$tag} ) {
177                            if ( defined $tags_data->{$tag} ) {
178    #                               meteor( 'in-range', $tag );
179                            } else {
180                                    meteor( 'read', $tag );
181                                    read_tag( $tag );
182                            }
183                            $visible_tags->{$tag}++;
184                    } else {
185                            warn "## using cached data for $tag" if $debug;
186                    }
187                    delete $last_visible_tags->{$tag}; # leave just missing tags
188    
189                    if ( -e "$program_path/$tag" ) {
190                                    meteor( 'write', $tag );
191                                    write_tag( $tag );
192                    }
193            }
194    
195            foreach my $tag ( keys %$last_visible_tags ) {
196                    my $data = delete $tags_data->{$tag};
197                    print "removed tag $tag with data ",dump( $data ),"\n";
198                    meteor( 'removed', $tag );
199            }
200    
201            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
202    }
203    
204    my $tag_data_block;
205    
206    sub read_tag_data {
207            my ($start_block,$rest) = @_;
208            die "no rest?" unless $rest;
209            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
210            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
211            my $blocks = ord(substr($rest,8,1));
212            $rest = substr($rest,9); # leave just data blocks
213            foreach my $nr ( 0 .. $blocks - 1 ) {
214                    my $block = substr( $rest, $nr * 6, 6 );
215                    warn "## block ",as_hex( $block ) if $debug;
216                    my $ord   = unpack('v',substr( $block, 0, 2 ));
217                    my $expected_ord = $nr + $start_block;
218                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
219                    my $data  = substr( $block, 2 );
220                    die "data payload should be 4 bytes" if length($data) != 4;
221                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
222                    $tag_data_block->{$tag}->[ $ord ] = $data;
223            }
224            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
225            print "DATA $tag ",dump( $tags_data ), "\n";
226    }
227    
228  sub read_tag {  sub read_tag {
229          my ( $tag ) = @_;          my ( $tag ) = @_;
230    
231            confess "no tag?" unless $tag;
232    
233          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
234    
235          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          cmd(
236                          "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",
237  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 {
238                          my $rest = shift || die "no rest?";                          print "FIXME: tag $tag ready?\n";
239                          warn "## DATA ", dump( $rest ) if $debug;                  },
240                          my $blocks = ord(substr($rest,0,1));                  "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";
241                          my @data;                          read_tag_data( 0, @_ );
242                          foreach my $nr ( 0 .. $blocks - 1 ) {                  },
243                                  my $block = substr( $rest, 1 + $nr * 6, 6 );          );
244                                  warn "## block ",as_hex( $block ) if $debug;  
245                                  my $ord   = unpack('v',substr( $block, 0, 2 ));          cmd(
246                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
247                                  my $data  = substr( $block, 2 );                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
248                                  die "data payload should be 4 bytes" if length($data) != 4;                          read_tag_data( 3, @_ );
249                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  }
250                                  $data[ $ord ] = $data;          );
251                          }  
                         $read_cached->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";  
                 })  
         });  
   
         #        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  
 if (0) {  
         cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
   
         #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
         #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
         warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";  
252  }  }
253          warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
254    sub write_tag {
255            my ($tag) = @_;
256    
257            my $path = "$program_path/$tag";
258    
259            my $data = read_file( $path );
260    
261            print "write_tag $tag = $data\n";
262    
263            cmd(
264                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",
265                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
266            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
267    
268            my $to = $path;
269            $to .= '.' . time();
270    
271            rename $path, $to;
272            print ">> $to\n";
273    
274  }  }
275    
276    exit;
277    
278  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
279    
280  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 188  sub writechunk Line 305  sub writechunk
305  {  {
306          my $str=shift;          my $str=shift;
307          my $count = $port->write($str);          my $count = $port->write($str);
308          print "#> ", as_hex( $str ), "\t[$count]" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
309  }  }
310    
311  sub as_hex {  sub as_hex {
# Line 207  sub read_bytes { Line 324  sub read_bytes {
324          my $data = '';          my $data = '';
325          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
326                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
327                    die "no bytes on port: $!" unless defined $b;
328                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
329                  $data .= $b;                  $data .= $b;
330          }          }
# Line 236  sub assert { Line 354  sub assert {
354          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
355  }  }
356    
 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;  
         }  
 }  
   
357  use Digest::CRC;  use Digest::CRC;
358    
359  sub crcccitt {  sub crcccitt {
# Line 289  sub checksum { Line 389  sub checksum {
389          return $bytes . $checksum;          return $bytes . $checksum;
390  }  }
391    
392  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
393    
394    sub readchunk {
395          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
396    
397          # read header of packet          # read header of packet
# Line 305  sub readchunk { Line 405  sub readchunk {
405          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
406    
407          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
408          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
409    
410          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;
411    
412          $assert->{len}      = $len;          $assert->{len}      = $len;
413          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
414    
415          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
416            # find longest match for incomming data
417            my ($to) = grep {
418                    my $match = substr($payload,0,length($_));
419                    m/^\Q$match\E/
420            } sort { length($a) <=> length($b) } keys %$dispatch;
421            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
422    
423            if ( defined $to ) {
424                    my $rest = substr( $payload, length($to) );
425                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
426                    $dispatch->{ $to }->( $rest );
427            } else {
428                    print "NO DISPATCH for ",dump( $full ),"\n";
429            }
430    
431          return $data;          return $data;
432  }  }
# Line 330  sub str2bytes { Line 444  sub str2bytes {
444  }  }
445    
446  sub cmd {  sub cmd {
447          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
448            my $cmd_desc = shift || confess "no description?";
449            my @expect = @_;
450    
451          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
452    
453          # fix checksum if needed          # fix checksum if needed
454          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
455    
456          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
457          $assert->{send} = $cmd;          $assert->{send} = $cmd;
458          writechunk( $bytes );          writechunk( $bytes );
459    
460          if ( $expect ) {          while ( @expect ) {
461                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
462                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
463                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
464    
465                    next if defined $dispatch->{ $pattern };
466    
467                    $dispatch->{ substr($pattern,3) } = $coderef;
468                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
469          }          }
470    
471            readchunk;
472  }  }
473    
Legend:
Removed from v.18  
changed lines
  Added in v.29
  ViewVC Help
Powered by ViewVC 1.1.26