/[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 23 by dpavlin, Sat Mar 28 03:47:10 2009 UTC revision 41 by dpavlin, Thu Jun 4 13:36:20 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;  use IO::Socket::INET;
13    
14  my $meteor = IO::Socket::INET->new( '192.168.1.13:4671' ) || die "can't connect to meteor: $!";  my $meteor_server = '192.168.1.13:4671';
15    my $meteor_fh;
16    
17  sub meteor {  sub meteor {
18          my ( $item, $html ) = @_;          my @a = @_;
19          warn ">> meteor $item $html\n";          push @a, scalar localtime() if $a[0] =~ m{^info};
20          print $meteor "ADDMESSAGE test $item|" . localtime() . "<br>$html\n";  
21            if ( ! defined $meteor_fh ) {
22                    if ( $meteor_fh =
23                                    IO::Socket::INET->new(
24                                            PeerAddr => $meteor_server,
25                                            Timeout => 1,
26                                    )
27                    ) {
28                            warn "# meteor connected to $meteor_server";
29                    } else {
30                            warn "can't connect to meteor $meteor_server: $!";
31                            $meteor_fh = 0;
32                    }
33            }
34    
35            if ( $meteor_fh ) {
36                    warn ">> meteor ",dump( @a );
37                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
38            }
39  }  }
40    
41  my $debug = 0;  my $debug = 0;
# Line 27  my $parity       = "none"; Line 47  my $parity       = "none";
47  my $stopbits  = "1";  my $stopbits  = "1";
48  my $handshake = "none";  my $handshake = "none";
49    
50    my $program_path = './program/';
51    my $secure_path = './secure/';
52    
53    # 3M defaults: 8,4
54    my $max_rfid_block = 16;
55    my $read_blocks = 8;
56    
57  my $response = {  my $response = {
58          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
59          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 47  GetOptions( Line 74  GetOptions(
74          'parity=s'    => \$parity,          'parity=s'    => \$parity,
75          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
76          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
77            'meteor=s'    => \$meteor_server,
78  ) or die $!;  ) or die $!;
79    
80  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 85  it under the same terms ans Perl itself. Line 113  it under the same terms ans Perl itself.
113  my $tags_data;  my $tags_data;
114  my $visible_tags;  my $visible_tags;
115    
116    my $item_type = {
117            1 => 'Book',
118            6 => 'CD/CD ROM',
119            2 => 'Magazine',
120            13 => 'Book with Audio Tape',
121            9 => 'Book with CD/CD ROM',
122            0 => 'Other',
123    
124            5 => 'Video',
125            4 => 'Audio Tape',
126            3 => 'Bound Journal',
127            8 => 'Book with Diskette',
128            7 => 'Diskette',
129    };
130    
131    warn "## known item type: ",dump( $item_type ) if $debug;
132    
133  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";
134  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
135  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 110  cmd( 'D5 00  05   04 00 11 Line 155  cmd( 'D5 00  05   04 00 11
155       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
156          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
157          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
158          meteor( -1, "Found reader $hw_ver" );          meteor( 'info', "Found reader hardware $hw_ver" );
159  });  });
160    
161  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 126  cmd( 'D6 00  05   FE     00  05 Line 171  cmd( 'D6 00  05   FE     00  05
171                  if ( ! $nr ) {                  if ( ! $nr ) {
172                          print "no tags in range\n";                          print "no tags in range\n";
173                          update_visible_tags();                          update_visible_tags();
174                          meteor( -1, "No tags in range" );                          meteor( 'info-none-in-range' );
175                            $tags_data = {};
176                  } else {                  } else {
177    
178                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 139  cmd( 'D6 00  05   FE     00  05 Line 185  cmd( 'D6 00  05   FE     00  05
185                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
186                          print "$nr tags in range: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
187    
188                          update_visible_tags( @tags );                          meteor( 'info-in-range', join(' ',@tags));
189    
190                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);                          update_visible_tags( @tags );
                         meteor( 0, "Tags:<ul>$html</ul>" );  
191                  }                  }
192          }          }
193  ) foreach ( 1 .. 1000 );  ) while(1);
194    #) foreach ( 1 .. 100 );
195    
196    
197    
# Line 157  sub update_visible_tags { Line 203  sub update_visible_tags {
203    
204          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
205                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
206                          read_tag( $tag );                          if ( defined $tags_data->{$tag} ) {
207    #                               meteor( 'in-range', $tag );
208                            } else {
209                                    meteor( 'read', $tag );
210                                    read_tag( $tag );
211                            }
212                          $visible_tags->{$tag}++;                          $visible_tags->{$tag}++;
213                  } else {                  } else {
214                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
215                  }                  }
216                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
217    
218                    if ( -e "$program_path/$tag" ) {
219                                    meteor( 'write', $tag );
220                                    write_tag( $tag );
221                    }
222                    if ( -e "$secure_path/$tag" ) {
223                                    meteor( 'secure', $tag );
224                                    secure_tag( $tag );
225                    }
226          }          }
227    
228          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
229                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
230                  print "removed tag $tag with data ",dump( $data ),"\n";                  print "removed tag $tag with data ",dump( $data ),"\n";
231                    meteor( 'removed', $tag );
232          }          }
233    
234          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
235  }  }
236    
237    my $tag_data_block;
238    
239    sub read_tag_data {
240            my ($start_block,$rest) = @_;
241            die "no rest?" unless $rest;
242    
243            my $last_block = 0;
244    
245            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
246            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
247            my $blocks = ord(substr($rest,8,1));
248            $rest = substr($rest,9); # leave just data blocks
249            foreach my $nr ( 0 .. $blocks - 1 ) {
250                    my $block = substr( $rest, $nr * 6, 6 );
251                    warn "## block ",as_hex( $block ) if $debug;
252                    my $ord   = unpack('v',substr( $block, 0, 2 ));
253                    my $expected_ord = $nr + $start_block;
254                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
255                    my $data  = substr( $block, 2 );
256                    die "data payload should be 4 bytes" if length($data) != 4;
257                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
258                    $tag_data_block->{$tag}->[ $ord ] = $data;
259                    $last_block = $ord;
260            }
261            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
262    
263            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
264            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
265    
266            return $last_block;
267    }
268    
269  sub read_tag {  sub read_tag {
270          my ( $tag ) = @_;          my ( $tag ) = @_;
271    
272          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
273    
         return if defined $tags_data->{$tag};  
   
274          print "read_tag $tag\n";          print "read_tag $tag\n";
275    
276            my $start_block = 0;
277    
278            while ( $start_block < $max_rfid_block ) {
279    
280                    cmd(
281                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
282                                    "read $tag offset: $start_block blocks: $read_blocks",
283                            "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";
284                                    $start_block = read_tag_data( $start_block, @_ );
285                                    warn "# read tag upto $start_block\n";
286                            },
287                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
288                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
289                            },
290                    );
291    
292            }
293    
294            my $security;
295    
296          cmd(          cmd(
297                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag 1234", "check security $tag",
298                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
299                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
300                  },                          my $from_tag;
301                  "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";                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
302                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
303                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
304                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          warn "# SECURITY $tag = $security\n";
                         my $blocks = ord(substr($rest,8,1));  
                         $rest = substr($rest,9); # leave just data blocks  
                         my @data;  
                         foreach my $nr ( 0 .. $blocks - 1 ) {  
                                 my $block = substr( $rest, $nr * 6, 6 );  
                                 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;  
                         }  
                         $tags_data->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $tags_data ), "\n";  
305                  }                  }
306          );          );
307    
308          #        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 $data = $tags_data->{$tag} || die "no data for $tag";
309  if (0) {          my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
310          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          my $set   = ( $set_item & 0xf0 ) >> 4;
311            my $total = ( $set_item & 0x0f );
312          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00            my $branch  = $br_lib >> 20;
313          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA          my $library = $br_lib & 0x000fffff;
314          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";          print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' library: $library branch: $branch custom: $custom security: $security\n";
315    
316  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
317    
318          my $item = unpack('H*', substr($tag,-8) ) % 100000;  sub write_tag {
319          meteor( $item, "Loading $item" );          my ($tag) = @_;
320    
321            my $path = "$program_path/$tag";
322    
323            my $data = read_file( $path );
324            my $hex_data;
325    
326            if ( $data =~ s{^hex\s+}{} ) {
327                    $hex_data = $data;
328                    $hex_data =~ s{\s+}{}g;
329            } else {
330    
331                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
332    
333                    my $max_len = $max_rfid_block * 4;
334    
335                    if ( length($data) > $max_len ) {
336                            $data = substr($data,0,$max_len);
337                            warn "strip content to $max_len bytes\n";
338                    }
339    
340                    $hex_data = unpack('H*', $data);
341            }
342    
343            my $len = length($hex_data) / 2;
344            # pad to block size
345            $hex_data .= '00' x ( 4 - $len % 4 );
346            my $blocks = sprintf('%02x', length($hex_data) / 4);
347    
348            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
349    
350            cmd(
351                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
352                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
353            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
354    
355            my $to = $path;
356            $to .= '.' . time();
357    
358            rename $path, $to;
359            print ">> $to\n";
360    
361            delete $tags_data->{$tag};      # force re-read of tag
362    }
363    
364    sub secure_tag {
365            my ($tag) = @_;
366    
367            my $path = "$secure_path/$tag";
368            my $data = substr(read_file( $path ),0,2);
369    
370            cmd(
371                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
372                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
373            );
374    
375            my $to = $path;
376            $to .= '.' . time();
377    
378            rename $path, $to;
379            print ">> $to\n";
380  }  }
381    
382  exit;  exit;
# Line 257  sub writechunk Line 411  sub writechunk
411  {  {
412          my $str=shift;          my $str=shift;
413          my $count = $port->write($str);          my $count = $port->write($str);
414            my $len = length($str);
415            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
416          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
417  }  }
418    
# Line 276  sub read_bytes { Line 432  sub read_bytes {
432          my $data = '';          my $data = '';
433          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
434                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
435                    die "no bytes on port: $!" unless defined $b;
436                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
437                  $data .= $b;                  $data .= $b;
438          }          }
# Line 294  sub skip_assert { Line 451  sub skip_assert {
451  sub assert {  sub assert {
452          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
453    
454            return unless $assert->{expect};
455    
456          $from ||= 0;          $from ||= 0;
457          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
458    
# Line 322  sub crcccitt { Line 481  sub crcccitt {
481  sub checksum {  sub checksum {
482          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
483    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
484          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
485          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
486    
487          if ( $len_real != $len ) {          if ( $len_real != $len ) {
488                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
489                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
490          }          }
491    
492            my $xor = crcccitt( substr($bytes,1) ); # skip D6
493            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
494    
495          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
496                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
497                  return $bytes . $xor;                  return $bytes . $xor;
# Line 371  sub readchunk { Line 530  sub readchunk {
530          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
531          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
532    
533          if ( defined $to ) {          if ( defined $to && $payload ) {
534                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) );
535                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
536                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
Legend:
Removed from v.23  
changed lines
  Added in v.41
  ViewVC Help
Powered by ViewVC 1.1.26