/[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 37 by dpavlin, Mon Jun 1 13:09:41 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                    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;
42    
# Line 17  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 30  my $response = { Line 63  my $response = {
63  };  };
64    
65  GetOptions(  GetOptions(
66          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
67          'device=s'    => \$device,          'device=s'    => \$device,
68          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
69          'databits=i'  => \$databits,          'databits=i'  => \$databits,
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;
77    
78  =head1 NAME  =head1 NAME
79    
80  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 106  it under the same terms ans Perl itself.
106    
107  =cut  =cut
108    
109    my $tags_data;
110    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 78  $databits=$port->databits($databits); Line 134  $databits=$port->databits($databits);
134  $parity=$port->parity($parity);  $parity=$port->parity($parity);
135  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
136    
137  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
138    
139  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
140  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 149  $port->read_char_time(5);
149    
150  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
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          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
153            print "hardware version $hw_ver\n";
154            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 102  cmd( 'D6 00  0C   13  04  01 00  02 00 Line 160  cmd( 'D6 00  0C   13  04  01 00  02 00
160  # start scanning for tags  # start scanning for tags
161    
162  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";  
   
         },  
163           '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
164                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
165                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
166    
167                  if ( ! $nr ) {                  if ( ! $nr ) {
168                          print "no tags in range\n";                          print "no tags in range\n";
169                            update_visible_tags();
170                            meteor( 'info-none-in-range' );
171                            $tags_data = {};
172                  } else {                  } else {
173    
174                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 179  cmd( 'D6 00  05   FE     00  05
179                          my @tags;                          my @tags;
180                          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 );
181                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
182                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
183    
184                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
185    
186                            update_visible_tags( @tags );
187                  }                  }
188          }          }
189  ) foreach ( 1 .. 100 );  ) while(1);
190    #) foreach ( 1 .. 100 );
191    
192    
193    
194    sub update_visible_tags {
195            my @tags = @_;
196    
197            my $last_visible_tags = $visible_tags;
198            $visible_tags = {};
199    
200            foreach my $tag ( @tags ) {
201                    if ( ! defined $last_visible_tags->{$tag} ) {
202                            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}++;
209                    } else {
210                            warn "## using cached data for $tag" if $debug;
211                    }
212                    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 ) {
225                    my $data = delete $tags_data->{$tag};
226                    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;
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 $read_cached;          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          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
263            
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, @_ );
                                 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";  
280                  }                  }
281          );          );
282    
283          #        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;
284  if (0) {  
285          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          cmd(
286                    "D6 00 0B 0A $tag 1234", "check security $tag",
287          #        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 {
288          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          my $rest = shift;
289          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\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            my $data = $tags_data->{$tag} || die "no data for $tag";
298            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
299            my $set   = ( $set_item & 0xf0 ) >> 4;
300            my $total = ( $set_item & 0x0f );
301            my $branch  = $br_lib >> 20;
302            my $library = $br_lib & 0x000fffff;
303            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    sub write_tag {
308            my ($tag) = @_;
309    
310            my $path = "$program_path/$tag";
311    
312            my $data = read_file( $path );
313    
314            $data = substr($data,0,16);
315    
316            my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
317    
318            print "write_tag $tag = ",dump( $data ), " == $hex_data\n";
319    
320            cmd(
321                    "d6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  fd3b", "write $tag",
322                    "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },
323            ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!
324    
325            my $to = $path;
326            $to .= '.' . time();
327    
328            rename $path, $to;
329            print ">> $to\n";
330    
331            delete $tags_data->{$tag};      # force re-read of tag
332    }
333    
334    sub secure_tag {
335            my ($tag) = @_;
336    
337            my $path = "$secure_path/$tag";
338            my $data = substr(read_file( $path ),0,2);
339    
340            cmd(
341                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
342                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
343            );
344    
345            my $to = $path;
346            $to .= '.' . time();
347    
348            rename $path, $to;
349            print ">> $to\n";
350  }  }
351    
352  exit;  exit;
# Line 231  sub read_bytes { Line 400  sub read_bytes {
400          my $data = '';          my $data = '';
401          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
402                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
403                    die "no bytes on port: $!" unless defined $b;
404                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
405                  $data .= $b;                  $data .= $b;
406          }          }
# Line 313  sub readchunk { Line 483  sub readchunk {
483          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
484          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
485    
486          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;
487    
488          $assert->{len}      = $len;          $assert->{len}      = $len;
489          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 529  sub cmd {
529          # fix checksum if needed          # fix checksum if needed
530          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
531    
532          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
533          $assert->{send} = $cmd;          $assert->{send} = $cmd;
534          writechunk( $bytes );          writechunk( $bytes );
535    
Legend:
Removed from v.20  
changed lines
  Added in v.37
  ViewVC Help
Powered by ViewVC 1.1.26