/[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 40 by dpavlin, Mon Jun 1 21:17:12 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  my $response = {  my $response = {
54          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
55          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 47  GetOptions( Line 70  GetOptions(
70          'parity=s'    => \$parity,          'parity=s'    => \$parity,
71          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
72          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
73            'meteor=s'    => \$meteor_server,
74  ) or die $!;  ) or die $!;
75    
76  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 85  it under the same terms ans Perl itself. Line 109  it under the same terms ans Perl itself.
109  my $tags_data;  my $tags_data;
110  my $visible_tags;  my $visible_tags;
111    
112    my $item_type = {
113            1 => 'Book',
114            6 => 'CD/CD ROM',
115            2 => 'Magazine',
116            13 => 'Book with Audio Tape',
117            9 => 'Book with CD/CD ROM',
118            0 => 'Other',
119    
120            5 => 'Video',
121            4 => 'Audio Tape',
122            3 => 'Bound Journal',
123            8 => 'Book with Diskette',
124            7 => 'Diskette',
125    };
126    
127    warn "## known item type: ",dump( $item_type ) if $debug;
128    
129  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";
130  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
131  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 110  cmd( 'D5 00  05   04 00 11 Line 151  cmd( 'D5 00  05   04 00 11
151       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
152          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
153          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
154          meteor( -1, "Found reader $hw_ver" );          meteor( 'info', "Found reader hardware $hw_ver" );
155  });  });
156    
157  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 167  cmd( 'D6 00  05   FE     00  05
167                  if ( ! $nr ) {                  if ( ! $nr ) {
168                          print "no tags in range\n";                          print "no tags in range\n";
169                          update_visible_tags();                          update_visible_tags();
170                          meteor( -1, "No tags in range" );                          meteor( 'info-none-in-range' );
171                            $tags_data = {};
172                  } else {                  } else {
173    
174                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 139  cmd( 'D6 00  05   FE     00  05 Line 181  cmd( 'D6 00  05   FE     00  05
181                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
182                          print "$nr tags in range: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
183    
184                          update_visible_tags( @tags );                          meteor( 'info-in-range', join(' ',@tags));
185    
186                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);                          update_visible_tags( @tags );
                         meteor( 0, "Tags:<ul>$html</ul>" );  
187                  }                  }
188          }          }
189  ) foreach ( 1 .. 1000 );  ) while(1);
190    #) foreach ( 1 .. 100 );
191    
192    
193    
# Line 157  sub update_visible_tags { Line 199  sub update_visible_tags {
199    
200          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
201                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
202                          read_tag( $tag );                          if ( defined $tags_data->{$tag} ) {
203    #                               meteor( 'in-range', $tag );
204                            } else {
205                                    meteor( 'read', $tag );
206                                    read_tag( $tag );
207                            }
208                          $visible_tags->{$tag}++;                          $visible_tags->{$tag}++;
209                  } else {                  } else {
210                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
211                  }                  }
212                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
213    
214                    if ( -e "$program_path/$tag" ) {
215                                    meteor( 'write', $tag );
216                                    write_tag( $tag );
217                    }
218                    if ( -e "$secure_path/$tag" ) {
219                                    meteor( 'secure', $tag );
220                                    secure_tag( $tag );
221                    }
222          }          }
223    
224          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
225                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
226                  print "removed tag $tag with data ",dump( $data ),"\n";                  print "removed tag $tag with data ",dump( $data ),"\n";
227                    meteor( 'removed', $tag );
228          }          }
229    
230          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;
231  }  }
232    
233    my $tag_data_block;
234    
235    sub read_tag_data {
236            my ($start_block,$rest) = @_;
237            die "no rest?" unless $rest;
238            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
239            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
240            my $blocks = ord(substr($rest,8,1));
241            $rest = substr($rest,9); # leave just data blocks
242            foreach my $nr ( 0 .. $blocks - 1 ) {
243                    my $block = substr( $rest, $nr * 6, 6 );
244                    warn "## block ",as_hex( $block ) if $debug;
245                    my $ord   = unpack('v',substr( $block, 0, 2 ));
246                    my $expected_ord = $nr + $start_block;
247                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
248                    my $data  = substr( $block, 2 );
249                    die "data payload should be 4 bytes" if length($data) != 4;
250                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
251                    $tag_data_block->{$tag}->[ $ord ] = $data;
252            }
253            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
254    
255            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
256            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
257    }
258    
259  sub read_tag {  sub read_tag {
260          my ( $tag ) = @_;          my ( $tag ) = @_;
261    
262          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
263    
         return if defined $tags_data->{$tag};  
   
264          print "read_tag $tag\n";          print "read_tag $tag\n";
265    
266          cmd(          cmd(
267                  "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",
268                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
269                          print "FIXME: tag $tag ready?\n";                          print "FIXME: tag $tag ready?\n";
270                  },                  },
271                  "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";
272                          my $rest = shift || die "no rest?";                          read_tag_data( 0, @_ );
273                          warn "## DATA ", dump( $rest ) if $debug;                  },
274                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          );
275                          my $blocks = ord(substr($rest,8,1));  
276                          $rest = substr($rest,9); # leave just data blocks          cmd(
277                          my @data;                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
278                          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  
279                                  my $block = substr( $rest, $nr * 6, 6 );                          read_tag_data( 3, @_ );
280                                  warn "## block ",as_hex( $block ) if $debug;                  }
281                                  my $ord   = unpack('v',substr( $block, 0, 2 ));          );
282                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;  
283                                  my $data  = substr( $block, 2 );          my $security;
284                                  die "data payload should be 4 bytes" if length($data) != 4;  
285                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;          cmd(
286                                  $data[ $ord ] = $data;                  "D6 00 0B 0A $tag 1234", "check security $tag",
287                          }                  "D6 00 0D 0A 00", sub {
288                          $tags_data->{ $tag } = join('', @data);                          my $rest = shift;
289                          print "DATA $tag ",dump( $tags_data ), "\n";                          my $from_tag;
290                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
291                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
292                            $security = as_hex( $security );
293                            warn "# SECURITY $tag = $security\n";
294                  }                  }
295          );          );
296    
297          #        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";
298  if (0) {          my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
299          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          my $set   = ( $set_item & 0xf0 ) >> 4;
300            my $total = ( $set_item & 0x0f );
301          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00            my $branch  = $br_lib >> 20;
302          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA          my $library = $br_lib & 0x000fffff;
303          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";
304    
305  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
306    
307          my $item = unpack('H*', substr($tag,-8) ) % 100000;  sub write_tag {
308          meteor( $item, "Loading $item" );          my ($tag) = @_;
309    
310            my $path = "$program_path/$tag";
311    
312            my $data = read_file( $path );
313            my $hex_data;
314    
315            if ( $data =~ s{^hex\s+}{} ) {
316                    $hex_data = $data;
317                    $hex_data =~ s{\s+}{}g;
318            } else {
319    
320                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
321    
322                    my $max_len = 7 * 4;
323    
324                    if ( length($data) > $max_len ) {
325                            $data = substr($data,0,$max_len);
326                            warn "strip content to $max_len bytes\n";
327                    }
328    
329                    $hex_data = unpack('H*', $data);
330            }
331    
332            my $len = length($hex_data) / 2;
333            # pad to block size
334            $hex_data .= '00' x ( 4 - $len % 4 );
335            my $blocks = sprintf('%02x', length($hex_data) / 4);
336    
337            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
338    
339            cmd(
340                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
341                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
342            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
343    
344            my $to = $path;
345            $to .= '.' . time();
346    
347            rename $path, $to;
348            print ">> $to\n";
349    
350            delete $tags_data->{$tag};      # force re-read of tag
351    }
352    
353    sub secure_tag {
354            my ($tag) = @_;
355    
356            my $path = "$secure_path/$tag";
357            my $data = substr(read_file( $path ),0,2);
358    
359            cmd(
360                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
361                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
362            );
363    
364            my $to = $path;
365            $to .= '.' . time();
366    
367            rename $path, $to;
368            print ">> $to\n";
369  }  }
370    
371  exit;  exit;
# Line 257  sub writechunk Line 400  sub writechunk
400  {  {
401          my $str=shift;          my $str=shift;
402          my $count = $port->write($str);          my $count = $port->write($str);
403            my $len = length($str);
404            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
405          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
406  }  }
407    
# Line 276  sub read_bytes { Line 421  sub read_bytes {
421          my $data = '';          my $data = '';
422          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
423                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
424                    die "no bytes on port: $!" unless defined $b;
425                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
426                  $data .= $b;                  $data .= $b;
427          }          }
# Line 294  sub skip_assert { Line 440  sub skip_assert {
440  sub assert {  sub assert {
441          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
442    
443            return unless $assert->{expect};
444    
445          $from ||= 0;          $from ||= 0;
446          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
447    
# Line 322  sub crcccitt { Line 470  sub crcccitt {
470  sub checksum {  sub checksum {
471          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
472    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
473          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
474          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
475    
476          if ( $len_real != $len ) {          if ( $len_real != $len ) {
477                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
478                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
479          }          }
480    
481            my $xor = crcccitt( substr($bytes,1) ); # skip D6
482            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
483    
484          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
485                  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";
486                  return $bytes . $xor;                  return $bytes . $xor;
# Line 371  sub readchunk { Line 519  sub readchunk {
519          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
520          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
521    
522          if ( defined $to ) {          if ( defined $to && $payload ) {
523                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) );
524                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
525                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
Legend:
Removed from v.23  
changed lines
  Added in v.40
  ViewVC Help
Powered by ViewVC 1.1.26