/[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 29 by dpavlin, Mon Apr 6 13:10:40 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                    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;
35    
# Line 17  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 30  my $response = { Line 55  my $response = {
55  };  };
56    
57  GetOptions(  GetOptions(
58          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
59          'device=s'    => \$device,          'device=s'    => \$device,
60          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
61          'databits=i'  => \$databits,          'databits=i'  => \$databits,
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;
69    
70  =head1 NAME  =head1 NAME
71    
72  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 98  it under the same terms ans Perl itself.
98    
99  =cut  =cut
100    
101    my $tags_data;
102    my $visible_tags;
103    
104  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";
105  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
106  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 109  $databits=$port->databits($databits);
109  $parity=$port->parity($parity);  $parity=$port->parity($parity);
110  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
111    
112  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
113    
114  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
115  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 124  $port->read_char_time(5);
124    
125  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
126       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
127          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
128            print "hardware version $hw_ver\n";
129            meteor( 'info', "Found reader hardware $hw_ver" );
130  });  });
131    
132  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 135  cmd( 'D6 00  0C   13  04  01 00  02 00
135  # start scanning for tags  # start scanning for tags
136    
137  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";  
   
         },  
138           '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
139                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
140                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
141    
142                  if ( ! $nr ) {                  if ( ! $nr ) {
143                          print "no tags in range\n";                          print "no tags in range\n";
144                            update_visible_tags();
145                            meteor( 'info-none-in-range' );
146                            $tags_data = {};
147                  } else {                  } else {
148    
149                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 154  cmd( 'D6 00  05   FE     00  05
154                          my @tags;                          my @tags;
155                          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 );
156                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
157                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
158    
159                            meteor( 'info-in-range', join(' ',@tags));
160    
161                          # read data from tag                          update_visible_tags( @tags );
162                          read_tag( $_ ) foreach @tags;                  }
163            }
164    ) while(1);
165    #) foreach ( 1 .. 100 );
166    
167    
168    
169    sub update_visible_tags {
170            my @tags = @_;
171    
172            my $last_visible_tags = $visible_tags;
173            $visible_tags = {};
174    
175            foreach my $tag ( @tags ) {
176                    if ( ! defined $last_visible_tags->{$tag} ) {
177                            if ( defined $tags_data->{$tag} ) {
178    #                               meteor( 'in-range', $tag );
179                            } else {
180                                    meteor( 'read', $tag );
181                                    read_tag( $tag );
182                            }
183                            $visible_tags->{$tag}++;
184                    } else {
185                            warn "## using cached data for $tag" if $debug;
186                    }
187                    delete $last_visible_tags->{$tag}; # leave just missing tags
188    
189                    if ( -e "$program_path/$tag" ) {
190                                    meteor( 'write', $tag );
191                                    write_tag( $tag );
192                  }                  }
193          }          }
 ) foreach ( 1 .. 100 );  
194    
195  my $read_cached;          foreach my $tag ( keys %$last_visible_tags ) {
196                    my $data = delete $tags_data->{$tag};
197                    print "removed tag $tag with data ",dump( $data ),"\n";
198                    meteor( 'removed', $tag );
199            }
200    
201            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
202    }
203    
204    my $tag_data_block;
205    
206    sub read_tag_data {
207            my ($start_block,$rest) = @_;
208            die "no rest?" unless $rest;
209            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
210            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
211            my $blocks = ord(substr($rest,8,1));
212            $rest = substr($rest,9); # leave just data blocks
213            foreach my $nr ( 0 .. $blocks - 1 ) {
214                    my $block = substr( $rest, $nr * 6, 6 );
215                    warn "## block ",as_hex( $block ) if $debug;
216                    my $ord   = unpack('v',substr( $block, 0, 2 ));
217                    my $expected_ord = $nr + $start_block;
218                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
219                    my $data  = substr( $block, 2 );
220                    die "data payload should be 4 bytes" if length($data) != 4;
221                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
222                    $tag_data_block->{$tag}->[ $ord ] = $data;
223            }
224            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
225            print "DATA $tag ",dump( $tags_data ), "\n";
226    }
227    
228  sub read_tag {  sub read_tag {
229          my ( $tag ) = @_;          my ( $tag ) = @_;
230    
231          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
232            
233          print "read_tag $tag\n";          print "read_tag $tag\n";
234    
235          cmd(          cmd(
236                  "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",
237                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
238                          print "FIXME: tag $tag ready?\n";                          print "FIXME: tag $tag ready?\n";
239                  },                  },
240                  "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";
241                          my $rest = shift || die "no rest?";                          read_tag_data( 0, @_ );
242                          warn "## DATA ", dump( $rest ) if $debug;                  },
243                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          );
244                          my $blocks = ord(substr($rest,8,1));  
245                          $rest = substr($rest,9); # leave just data blocks          cmd(
246                          my @data;                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
247                          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  
248                                  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";  
249                  }                  }
250          );          );
251    
         #        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  
 if (0) {  
         cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
   
         #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
         #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
         warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";  
252  }  }
253          warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
254    sub write_tag {
255            my ($tag) = @_;
256    
257            my $path = "$program_path/$tag";
258    
259            my $data = read_file( $path );
260    
261            print "write_tag $tag = $data\n";
262    
263            cmd(
264                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",
265                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
266            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
267    
268            my $to = $path;
269            $to .= '.' . time();
270    
271            rename $path, $to;
272            print ">> $to\n";
273    
274  }  }
275    
# Line 231  sub read_bytes { Line 324  sub read_bytes {
324          my $data = '';          my $data = '';
325          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
326                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
327                    die "no bytes on port: $!" unless defined $b;
328                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
329                  $data .= $b;                  $data .= $b;
330          }          }
# Line 313  sub readchunk { Line 407  sub readchunk {
407          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
408          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
409    
410          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;
411    
412          $assert->{len}      = $len;          $assert->{len}      = $len;
413          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 453  sub cmd {
453          # fix checksum if needed          # fix checksum if needed
454          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
455    
456          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
457          $assert->{send} = $cmd;          $assert->{send} = $cmd;
458          writechunk( $bytes );          writechunk( $bytes );
459    
Legend:
Removed from v.20  
changed lines
  Added in v.29
  ViewVC Help
Powered by ViewVC 1.1.26