/[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 20 by dpavlin, Fri Oct 3 21:25:02 2008 UTC revision 33 by dpavlin, Wed Apr 8 14:48:22 2009 UTC
# Line 7  use warnings; Line 7  use warnings;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  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    
# Line 17  my $parity       = "none"; Line 40  my $parity       = "none";
40  my $stopbits  = "1";  my $stopbits  = "1";
41  my $handshake = "none";  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 30  my $response = { Line 55  my $response = {
55  };  };
56    
57  GetOptions(  GetOptions(
58          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
59          'device=s'    => \$device,          'device=s'    => \$device,
60          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
61          'databits=i'  => \$databits,          'databits=i'  => \$databits,
62          'parity=s'    => \$parity,          'parity=s'    => \$parity,
63          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
64          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
65            'meteor=s'    => \$meteor_server,
66  ) or die $!;  ) 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
# Line 70  it under the same terms ans Perl itself. Line 98  it under the same terms ans Perl itself.
98    
99  =cut  =cut
100    
101    my $tags_data;
102    my $visible_tags;
103    
104    my $item_type = {
105            1 => 'Book',
106            6 => 'CD/CD ROM',
107            2 => 'Magazine',
108            13 => 'Book with Audio Tape',
109            9 => 'Book with CD/CD ROM',
110            0 => 'Other',
111    
112            5 => 'Video',
113            4 => 'Audio Tape',
114            3 => 'Bound Journal',
115            8 => 'Book with Diskette',
116            7 => 'Diskette',
117    };
118    
119    warn "## known item type: ",dump( $item_type ) if $debug;
120    
121  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";
122  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
123  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 126  $databits=$port->databits($databits);
126  $parity=$port->parity($parity);  $parity=$port->parity($parity);
127  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
128    
129  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
130    
131  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
132  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 141  $port->read_char_time(5);
141    
142  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
143       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
144          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
145            print "hardware version $hw_ver\n";
146            meteor( 'info', "Found reader hardware $hw_ver" );
147  });  });
148    
149  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
# Line 102  cmd( 'D6 00  0C   13  04  01 00  02 00 Line 152  cmd( 'D6 00  0C   13  04  01 00  02 00
152  # start scanning for tags  # start scanning for tags
153    
154  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
      'D6 00  07   FE  00 00  05     00  C97B', sub {  
                 assert();  
                 print "no tag in range\n";  
   
         },  
155           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
156                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
157                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
158    
159                  if ( ! $nr ) {                  if ( ! $nr ) {
160                          print "no tags in range\n";                          print "no tags in range\n";
161                            update_visible_tags();
162                            meteor( 'info-none-in-range' );
163                            $tags_data = {};
164                  } else {                  } else {
165    
166                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 171  cmd( 'D6 00  05   FE     00  05
171                          my @tags;                          my @tags;
172                          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 );
173                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
174                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
175    
176                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
177    
178                            update_visible_tags( @tags );
179                  }                  }
180          }          }
181  ) foreach ( 1 .. 100 );  ) while(1);
182    #) foreach ( 1 .. 100 );
183    
184    
185    
186    sub update_visible_tags {
187            my @tags = @_;
188    
189            my $last_visible_tags = $visible_tags;
190            $visible_tags = {};
191    
192            foreach my $tag ( @tags ) {
193                    if ( ! defined $last_visible_tags->{$tag} ) {
194                            if ( defined $tags_data->{$tag} ) {
195    #                               meteor( 'in-range', $tag );
196                            } else {
197                                    meteor( 'read', $tag );
198                                    read_tag( $tag );
199                            }
200                            $visible_tags->{$tag}++;
201                    } else {
202                            warn "## using cached data for $tag" if $debug;
203                    }
204                    delete $last_visible_tags->{$tag}; # leave just missing tags
205    
206                    if ( -e "$program_path/$tag" ) {
207                                    meteor( 'write', $tag );
208                                    write_tag( $tag );
209                    }
210            }
211    
212            foreach my $tag ( keys %$last_visible_tags ) {
213                    my $data = delete $tags_data->{$tag};
214                    print "removed tag $tag with data ",dump( $data ),"\n";
215                    meteor( 'removed', $tag );
216            }
217    
218            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
219    }
220    
221    my $tag_data_block;
222    
223    sub read_tag_data {
224            my ($start_block,$rest) = @_;
225            die "no rest?" unless $rest;
226            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
227            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
228            my $blocks = ord(substr($rest,8,1));
229            $rest = substr($rest,9); # leave just data blocks
230            foreach my $nr ( 0 .. $blocks - 1 ) {
231                    my $block = substr( $rest, $nr * 6, 6 );
232                    warn "## block ",as_hex( $block ) if $debug;
233                    my $ord   = unpack('v',substr( $block, 0, 2 ));
234                    my $expected_ord = $nr + $start_block;
235                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
236                    my $data  = substr( $block, 2 );
237                    die "data payload should be 4 bytes" if length($data) != 4;
238                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
239                    $tag_data_block->{$tag}->[ $ord ] = $data;
240            }
241            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
242    
243  my $read_cached;          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
244            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
245    }
246    
247  sub read_tag {  sub read_tag {
248          my ( $tag ) = @_;          my ( $tag ) = @_;
249    
250          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
251            
252          print "read_tag $tag\n";          print "read_tag $tag\n";
253    
254          cmd(          cmd(
255                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
256                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
257                          print "FIXME: tag $tag ready?\n";                          print "FIXME: tag $tag ready?\n";
258                  },                  },
259                  "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";                  "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";
260                          my $rest = shift || die "no rest?";                          read_tag_data( 0, @_ );
261                          warn "## DATA ", dump( $rest ) if $debug;                  },
262                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          );
263                          my $blocks = ord(substr($rest,8,1));  
264                          $rest = substr($rest,9); # leave just data blocks          cmd(
265                          my @data;                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
266                          foreach my $nr ( 0 .. $blocks - 1 ) {                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
267                                  my $block = substr( $rest, $nr * 6, 6 );                          read_tag_data( 3, @_ );
                                 warn "## block ",as_hex( $block ) if $debug;  
                                 my $ord   = unpack('v',substr( $block, 0, 2 ));  
                                 die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;  
                                 my $data  = substr( $block, 2 );  
                                 die "data payload should be 4 bytes" if length($data) != 4;  
                                 warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;  
                                 $data[ $ord ] = $data;  
                         }  
                         $read_cached->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $read_cached ), "\n";  
268                  }                  }
269          );          );
270    
271          #        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          my $security;
272  if (0) {  
273          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          cmd(
274                    "D6 00 0B 0A $tag 1234", "check security $tag",
275          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    "D6 00 0D 0A 00", sub {
276          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          my $rest = shift;
277          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";                          my $from_tag;
278                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
279                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
280                            $security = as_hex( $security );
281                            warn "# SECURITY $tag = $security\n";
282                    }
283            );
284    
285            my $data = $tags_data->{$tag} || die "no data for $tag";
286            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
287            my $set   = ( $set_item & 0xf0 ) >> 4;
288            my $total = ( $set_item & 0x0f );
289            my $branch  = $br_lib >> 20;
290            my $library = $br_lib & 0x000fffff;
291            print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n";
292    
293  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
294    
295    sub write_tag {
296            my ($tag) = @_;
297    
298            my $path = "$program_path/$tag";
299    
300            my $data = read_file( $path );
301    
302            $data = substr($data,0,16);
303    
304            my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
305    
306            print "write_tag $tag = $data ",dump( $hex_data );
307    
308            cmd(
309                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
310                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
311            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
312    
313            my $to = $path;
314            $to .= '.' . time();
315    
316            rename $path, $to;
317            print ">> $to\n";
318    
319            delete $tags_data->{$tag};      # force re-read of tag
320  }  }
321    
322  exit;  exit;
# Line 231  sub read_bytes { Line 370  sub read_bytes {
370          my $data = '';          my $data = '';
371          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
372                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
373                    die "no bytes on port: $!" unless defined $b;
374                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
375                  $data .= $b;                  $data .= $b;
376          }          }
# Line 313  sub readchunk { Line 453  sub readchunk {
453          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
454          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
455    
456          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;
457    
458          $assert->{len}      = $len;          $assert->{len}      = $len;
459          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 499  sub cmd {
499          # fix checksum if needed          # fix checksum if needed
500          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
501    
502          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
503          $assert->{send} = $cmd;          $assert->{send} = $cmd;
504          writechunk( $bytes );          writechunk( $bytes );
505    
Legend:
Removed from v.20  
changed lines
  Added in v.33
  ViewVC Help
Powered by ViewVC 1.1.26