/[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 32 by dpavlin, Mon Apr 6 21:28:02 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    
45  my $response = {  my $response = {
46          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
47          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 47  GetOptions( Line 62  GetOptions(
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;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 85  it under the same terms ans Perl itself. Line 101  it under the same terms ans Perl itself.
101  my $tags_data;  my $tags_data;
102  my $visible_tags;  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 110  cmd( 'D5 00  05   04 00 11 Line 143  cmd( 'D5 00  05   04 00 11
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          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
145          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
146          meteor( -1, "Found reader $hw_ver" );          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 126  cmd( 'D6 00  05   FE     00  05 Line 159  cmd( 'D6 00  05   FE     00  05
159                  if ( ! $nr ) {                  if ( ! $nr ) {
160                          print "no tags in range\n";                          print "no tags in range\n";
161                          update_visible_tags();                          update_visible_tags();
162                          meteor( -1, "No tags in range" );                          meteor( 'info-none-in-range' );
163                            $tags_data = {};
164                  } else {                  } else {
165    
166                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 139  cmd( 'D6 00  05   FE     00  05 Line 173  cmd( 'D6 00  05   FE     00  05
173                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
174                          print "$nr tags in range: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
175    
176                          update_visible_tags( @tags );                          meteor( 'info-in-range', join(' ',@tags));
177    
178                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);                          update_visible_tags( @tags );
                         meteor( 0, "Tags:<ul>$html</ul>" );  
179                  }                  }
180          }          }
181  ) foreach ( 1 .. 1000 );  ) while(1);
182    #) foreach ( 1 .. 100 );
183    
184    
185    
# Line 157  sub update_visible_tags { Line 191  sub update_visible_tags {
191    
192          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
193                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
194                          read_tag( $tag );                          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}++;                          $visible_tags->{$tag}++;
201                  } else {                  } else {
202                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
203                  }                  }
204                  delete $last_visible_tags->{$tag}; # leave just missing tags                  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 ) {          foreach my $tag ( keys %$last_visible_tags ) {
213                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
214                  print "removed tag $tag with data ",dump( $data ),"\n";                  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;          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 $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          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
251    
         return if defined $tags_data->{$tag};  
   
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;  
                         }  
                         $tags_data->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $tags_data ), "\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 $data = $tags_data->{$tag} || die "no data for $tag";
272  if (0) {          my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
273          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          my $set   = ( $set_item & 0xf0 ) >> 4;
274            my $total = ( $set_item & 0x0f );
275          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00            my $branch  = $br_lib >> 20;
276          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA          my $library = $br_lib & 0x000fffff;
277          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' branch: $branch library: $library custom: $custom\n";
278    
279  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
280    
281          my $item = unpack('H*', substr($tag,-8) ) % 100000;  sub write_tag {
282          meteor( $item, "Loading $item" );          my ($tag) = @_;
283    
284            my $path = "$program_path/$tag";
285    
286            my $data = read_file( $path );
287    
288            $data = substr($data,0,16);
289    
290            my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
291    
292            print "write_tag $tag = $data ",dump( $hex_data );
293    
294            cmd(
295                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
296                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
297            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
298    
299            my $to = $path;
300            $to .= '.' . time();
301    
302            rename $path, $to;
303            print ">> $to\n";
304    
305            delete $tags_data->{$tag};      # force re-read of tag
306  }  }
307    
308  exit;  exit;
# Line 276  sub read_bytes { Line 356  sub read_bytes {
356          my $data = '';          my $data = '';
357          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
358                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
359                    die "no bytes on port: $!" unless defined $b;
360                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
361                  $data .= $b;                  $data .= $b;
362          }          }
Legend:
Removed from v.23  
changed lines
  Added in v.32
  ViewVC Help
Powered by ViewVC 1.1.26