/[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 28 by dpavlin, Mon Apr 6 12:36:22 2009 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10    
11    use IO::Socket::INET;
12    
13    my $meteor_server = '192.168.1.13:4671';
14    my $meteor_fh;
15    
16    sub meteor {
17            my @a = @_;
18            push @a, scalar localtime() if $a[0] =~ m{^info};
19    
20            if ( ! defined $meteor_fh ) {
21                    warn "# open connection to $meteor_server";
22                    $meteor_fh = IO::Socket::INET->new(
23                                    PeerAddr => $meteor_server,
24                                    Timeout => 1,
25                    ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
26                    $meteor_fh = 0; # don't try again
27            }
28    
29            warn ">> meteor ",dump( @a );
30            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
31    }
32    
33  my $debug = 0;  my $debug = 0;
34    
35  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 30  my $response = { Line 52  my $response = {
52  };  };
53    
54  GetOptions(  GetOptions(
55          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
56          'device=s'    => \$device,          'device=s'    => \$device,
57          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
58          'databits=i'  => \$databits,          'databits=i'  => \$databits,
59          'parity=s'    => \$parity,          'parity=s'    => \$parity,
60          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
61          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
62            'meteor=s'    => \$meteor_server,
63  ) or die $!;  ) or die $!;
64    
65    my $verbose = $debug > 0 ? $debug-- : 0;
66    
67  =head1 NAME  =head1 NAME
68    
69  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 95  it under the same terms ans Perl itself.
95    
96  =cut  =cut
97    
98    my $tags_data;
99    my $visible_tags;
100    
101  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";
102  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
103  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 106  $databits=$port->databits($databits);
106  $parity=$port->parity($parity);  $parity=$port->parity($parity);
107  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
108    
109  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
110    
111  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
112  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 121  $port->read_char_time(5);
121    
122  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
123       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
124          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
125            print "hardware version $hw_ver\n";
126            meteor( 'info', "Found reader hardware $hw_ver" );
127  });  });
128    
129  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 132  cmd( 'D6 00  0C   13  04  01 00  02 00
132  # start scanning for tags  # start scanning for tags
133    
134  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";  
   
         },  
135           '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
136                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
137                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
138    
139                  if ( ! $nr ) {                  if ( ! $nr ) {
140                          print "no tags in range\n";                          print "no tags in range\n";
141                            update_visible_tags();
142                            meteor( 'info-none-in-range' );
143                            $tags_data = {};
144                  } else {                  } else {
145    
146                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 151  cmd( 'D6 00  05   FE     00  05
151                          my @tags;                          my @tags;
152                          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 );
153                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
154                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
155    
156                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
157    
158                            update_visible_tags( @tags );
159                  }                  }
160          }          }
161  ) foreach ( 1 .. 100 );  ) while(1);
162    #) foreach ( 1 .. 100 );
163    
164  my $read_cached;  
165    
166    sub update_visible_tags {
167            my @tags = @_;
168    
169            my $last_visible_tags = $visible_tags;
170            $visible_tags = {};
171    
172            foreach my $tag ( @tags ) {
173                    if ( ! defined $last_visible_tags->{$tag} ) {
174                            if ( defined $tags_data->{$tag} ) {
175    #                               meteor( 'in-range', $tag );
176                            } else {
177                                    meteor( 'read', $tag );
178                                    read_tag( $tag );
179                            }
180                            $visible_tags->{$tag}++;
181                    } else {
182                            warn "## using cached data for $tag" if $debug;
183                    }
184                    delete $last_visible_tags->{$tag}; # leave just missing tags
185            }
186    
187            foreach my $tag ( keys %$last_visible_tags ) {
188                    my $data = delete $tags_data->{$tag};
189                    print "removed tag $tag with data ",dump( $data ),"\n";
190                    meteor( 'removed', $tag );
191            }
192    
193            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
194    }
195    
196    my $tag_data_block;
197    
198    sub read_tag_data {
199            my ($start_block,$rest) = @_;
200            die "no rest?" unless $rest;
201            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
202            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
203            my $blocks = ord(substr($rest,8,1));
204            $rest = substr($rest,9); # leave just data blocks
205            foreach my $nr ( 0 .. $blocks - 1 ) {
206                    my $block = substr( $rest, $nr * 6, 6 );
207                    warn "## block ",as_hex( $block ) if $debug;
208                    my $ord   = unpack('v',substr( $block, 0, 2 ));
209                    my $expected_ord = $nr + $start_block;
210                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
211                    my $data  = substr( $block, 2 );
212                    die "data payload should be 4 bytes" if length($data) != 4;
213                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
214                    $tag_data_block->{$tag}->[ $ord ] = $data;
215            }
216            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
217            print "DATA $tag ",dump( $tags_data ), "\n";
218    }
219    
220  sub read_tag {  sub read_tag {
221          my ( $tag ) = @_;          my ( $tag ) = @_;
222    
223          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
224            
225          print "read_tag $tag\n";          print "read_tag $tag\n";
226    
227          cmd(          cmd(
228                  "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",
229                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
230                          print "FIXME: tag $tag ready?\n";                          print "FIXME: tag $tag ready?\n";
231                  },                  },
232                  "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";
233                          my $rest = shift || die "no rest?";                          read_tag_data( 0, @_ );
234                          warn "## DATA ", dump( $rest ) if $debug;                  },
                         my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));  
                         my $blocks = ord(substr($rest,8,1));  
                         $rest = substr($rest,9); # leave just data blocks  
                         my @data;  
                         foreach my $nr ( 0 .. $blocks - 1 ) {  
                                 my $block = substr( $rest, $nr * 6, 6 );  
                                 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";  
                 }  
235          );          );
236    
237          #        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          cmd(
238  if (0) {                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
239          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
240                            read_tag_data( 3, @_ );
241          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    }
242          #                           $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";  
 }  
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
243    
244  }  }
245    
# Line 231  sub read_bytes { Line 294  sub read_bytes {
294          my $data = '';          my $data = '';
295          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
296                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
297                    die "no bytes on port: $!" unless defined $b;
298                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
299                  $data .= $b;                  $data .= $b;
300          }          }
# Line 313  sub readchunk { Line 377  sub readchunk {
377          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
378          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
379    
380          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;
381    
382          $assert->{len}      = $len;          $assert->{len}      = $len;
383          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 423  sub cmd {
423          # fix checksum if needed          # fix checksum if needed
424          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
425    
426          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
427          $assert->{send} = $cmd;          $assert->{send} = $cmd;
428          writechunk( $bytes );          writechunk( $bytes );
429    
Legend:
Removed from v.20  
changed lines
  Added in v.28
  ViewVC Help
Powered by ViewVC 1.1.26