/[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 34 by dpavlin, Wed Apr 8 15:03:49 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                    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;
# Line 27  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    my $secure_path = './secure/';
45    
46  my $response = {  my $response = {
47          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
48          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 47  GetOptions( Line 63  GetOptions(
63          'parity=s'    => \$parity,          'parity=s'    => \$parity,
64          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
65          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
66            'meteor=s'    => \$meteor_server,
67  ) or die $!;  ) or die $!;
68    
69  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 85  it under the same terms ans Perl itself. Line 102  it under the same terms ans Perl itself.
102  my $tags_data;  my $tags_data;
103  my $visible_tags;  my $visible_tags;
104    
105    my $item_type = {
106            1 => 'Book',
107            6 => 'CD/CD ROM',
108            2 => 'Magazine',
109            13 => 'Book with Audio Tape',
110            9 => 'Book with CD/CD ROM',
111            0 => 'Other',
112    
113            5 => 'Video',
114            4 => 'Audio Tape',
115            3 => 'Bound Journal',
116            8 => 'Book with Diskette',
117            7 => 'Diskette',
118    };
119    
120    warn "## known item type: ",dump( $item_type ) if $debug;
121    
122  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";
123  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
124  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 110  cmd( 'D5 00  05   04 00 11 Line 144  cmd( 'D5 00  05   04 00 11
144       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
145          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
146          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
147          meteor( -1, "Found reader $hw_ver" );          meteor( 'info', "Found reader hardware $hw_ver" );
148  });  });
149    
150  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 160  cmd( 'D6 00  05   FE     00  05
160                  if ( ! $nr ) {                  if ( ! $nr ) {
161                          print "no tags in range\n";                          print "no tags in range\n";
162                          update_visible_tags();                          update_visible_tags();
163                          meteor( -1, "No tags in range" );                          meteor( 'info-none-in-range' );
164                            $tags_data = {};
165                  } else {                  } else {
166    
167                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 139  cmd( 'D6 00  05   FE     00  05 Line 174  cmd( 'D6 00  05   FE     00  05
174                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
175                          print "$nr tags in range: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
176    
177                          update_visible_tags( @tags );                          meteor( 'info-in-range', join(' ',@tags));
178    
179                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);                          update_visible_tags( @tags );
                         meteor( 0, "Tags:<ul>$html</ul>" );  
180                  }                  }
181          }          }
182  ) foreach ( 1 .. 1000 );  ) while(1);
183    #) foreach ( 1 .. 100 );
184    
185    
186    
# Line 157  sub update_visible_tags { Line 192  sub update_visible_tags {
192    
193          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
194                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
195                          read_tag( $tag );                          if ( defined $tags_data->{$tag} ) {
196    #                               meteor( 'in-range', $tag );
197                            } else {
198                                    meteor( 'read', $tag );
199                                    read_tag( $tag );
200                            }
201                          $visible_tags->{$tag}++;                          $visible_tags->{$tag}++;
202                  } else {                  } else {
203                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
204                  }                  }
205                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
206    
207                    if ( -e "$program_path/$tag" ) {
208                                    meteor( 'write', $tag );
209                                    write_tag( $tag );
210                    }
211                    if ( -e "$secure_path/$tag" ) {
212                                    meteor( 'secure', $tag );
213                                    secure_tag( $tag );
214                    }
215          }          }
216    
217          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
218                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
219                  print "removed tag $tag with data ",dump( $data ),"\n";                  print "removed tag $tag with data ",dump( $data ),"\n";
220                    meteor( 'removed', $tag );
221          }          }
222    
223          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;
224  }  }
225    
226    my $tag_data_block;
227    
228    sub read_tag_data {
229            my ($start_block,$rest) = @_;
230            die "no rest?" unless $rest;
231            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
232            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
233            my $blocks = ord(substr($rest,8,1));
234            $rest = substr($rest,9); # leave just data blocks
235            foreach my $nr ( 0 .. $blocks - 1 ) {
236                    my $block = substr( $rest, $nr * 6, 6 );
237                    warn "## block ",as_hex( $block ) if $debug;
238                    my $ord   = unpack('v',substr( $block, 0, 2 ));
239                    my $expected_ord = $nr + $start_block;
240                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
241                    my $data  = substr( $block, 2 );
242                    die "data payload should be 4 bytes" if length($data) != 4;
243                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
244                    $tag_data_block->{$tag}->[ $ord ] = $data;
245            }
246            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
247    
248            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
249            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
250    }
251    
252  sub read_tag {  sub read_tag {
253          my ( $tag ) = @_;          my ( $tag ) = @_;
254    
255          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
256    
         return if defined $tags_data->{$tag};  
   
257          print "read_tag $tag\n";          print "read_tag $tag\n";
258    
259          cmd(          cmd(
260                  "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",
261                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
262                          print "FIXME: tag $tag ready?\n";                          print "FIXME: tag $tag ready?\n";
263                  },                  },
264                  "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";
265                          my $rest = shift || die "no rest?";                          read_tag_data( 0, @_ );
266                          warn "## DATA ", dump( $rest ) if $debug;                  },
267                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          );
268                          my $blocks = ord(substr($rest,8,1));  
269                          $rest = substr($rest,9); # leave just data blocks          cmd(
270                          my @data;                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
271                          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  
272                                  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;  
                         }  
                         $tags_data->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $tags_data ), "\n";  
273                  }                  }
274          );          );
275    
276          #        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;
277  if (0) {  
278          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          cmd(
279                    "D6 00 0B 0A $tag 1234", "check security $tag",
280          #        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 {
281          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          my $rest = shift;
282          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";                          my $from_tag;
283                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
284                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
285                            $security = as_hex( $security );
286                            warn "# SECURITY $tag = $security\n";
287                    }
288            );
289    
290            my $data = $tags_data->{$tag} || die "no data for $tag";
291            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
292            my $set   = ( $set_item & 0xf0 ) >> 4;
293            my $total = ( $set_item & 0x0f );
294            my $branch  = $br_lib >> 20;
295            my $library = $br_lib & 0x000fffff;
296            print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n";
297    
298  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
299    
300          my $item = unpack('H*', substr($tag,-8) ) % 100000;  sub write_tag {
301          meteor( $item, "Loading $item" );          my ($tag) = @_;
302    
303            my $path = "$program_path/$tag";
304    
305            my $data = read_file( $path );
306    
307            $data = substr($data,0,16);
308    
309            my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) );
310    
311            print "write_tag $tag = $data ",dump( $hex_data );
312    
313            cmd(
314                    "d6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  fd3b", "write $tag",
315                    "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },
316            ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!
317    
318            my $to = $path;
319            $to .= '.' . time();
320    
321            rename $path, $to;
322            print ">> $to\n";
323    
324            delete $tags_data->{$tag};      # force re-read of tag
325    }
326    
327    sub secure_tag {
328            my ($tag) = @_;
329    
330            my $path = "$secure_path/$tag";
331            my $data = substr(read_file( $path ),0,2);
332    
333            cmd(
334                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
335                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
336            );
337    
338            my $to = $path;
339            $to .= '.' . time();
340    
341            rename $path, $to;
342            print ">> $to\n";
343  }  }
344    
345  exit;  exit;
# Line 276  sub read_bytes { Line 393  sub read_bytes {
393          my $data = '';          my $data = '';
394          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
395                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
396                    die "no bytes on port: $!" unless defined $b;
397                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
398                  $data .= $b;                  $data .= $b;
399          }          }
Legend:
Removed from v.23  
changed lines
  Added in v.34
  ViewVC Help
Powered by ViewVC 1.1.26