/[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 26 by dpavlin, Wed Apr 1 16:59:09 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                    $meteor_fh = IO::Socket::INET->new( $meteor_server )
22                            || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
23                    $meteor_fh = 0; # don't try again
24            }
25    
26            warn ">> meteor ",dump( @a );
27            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
28    }
29    
30  my $debug = 0;  my $debug = 0;
31    
32  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 30  my $response = { Line 49  my $response = {
49  };  };
50    
51  GetOptions(  GetOptions(
52          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
53          'device=s'    => \$device,          'device=s'    => \$device,
54          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
55          'databits=i'  => \$databits,          'databits=i'  => \$databits,
56          'parity=s'    => \$parity,          'parity=s'    => \$parity,
57          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
58          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
59            'meteor=s'    => \$meteor_server,
60  ) or die $!;  ) or die $!;
61    
62    my $verbose = $debug > 0 ? $debug-- : 0;
63    
64  =head1 NAME  =head1 NAME
65    
66  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 92  it under the same terms ans Perl itself.
92    
93  =cut  =cut
94    
95    my $tags_data;
96    my $visible_tags;
97    
98  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";
99  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
100  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 103  $databits=$port->databits($databits);
103  $parity=$port->parity($parity);  $parity=$port->parity($parity);
104  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
105    
106  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
107    
108  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
109  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 118  $port->read_char_time(5);
118    
119  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
120       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
121          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
122            print "hardware version $hw_ver\n";
123            meteor( 'info', "Found reader hardware $hw_ver" );
124  });  });
125    
126  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 129  cmd( 'D6 00  0C   13  04  01 00  02 00
129  # start scanning for tags  # start scanning for tags
130    
131  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";  
   
         },  
132           '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
133                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
134                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
135    
136                  if ( ! $nr ) {                  if ( ! $nr ) {
137                          print "no tags in range\n";                          print "no tags in range\n";
138                            update_visible_tags();
139                            meteor( 'info-none-in-range' );
140                            $tags_data = {};
141                  } else {                  } else {
142    
143                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 148  cmd( 'D6 00  05   FE     00  05
148                          my @tags;                          my @tags;
149                          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 );
150                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
151                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
152    
153                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
154    
155                            update_visible_tags( @tags );
156                  }                  }
157          }          }
158  ) foreach ( 1 .. 100 );  ) while(1);
159    #) foreach ( 1 .. 100 );
160    
161    
162    
163    sub update_visible_tags {
164            my @tags = @_;
165    
166            my $last_visible_tags = $visible_tags;
167            $visible_tags = {};
168    
169            foreach my $tag ( @tags ) {
170                    if ( ! defined $last_visible_tags->{$tag} ) {
171                            if ( defined $tags_data->{$tag} ) {
172    #                               meteor( 'in-range', $tag );
173                            } else {
174                                    meteor( 'read', $tag );
175                                    read_tag( $tag );
176                            }
177                            $visible_tags->{$tag}++;
178                    } else {
179                            warn "## using cached data for $tag" if $debug;
180                    }
181                    delete $last_visible_tags->{$tag}; # leave just missing tags
182            }
183    
184            foreach my $tag ( keys %$last_visible_tags ) {
185                    my $data = delete $tags_data->{$tag};
186                    print "removed tag $tag with data ",dump( $data ),"\n";
187                    meteor( 'removed', $tag );
188            }
189    
190            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
191    }
192    
 my $read_cached;  
193    
194  sub read_tag {  sub read_tag {
195          my ( $tag ) = @_;          my ( $tag ) = @_;
196    
197          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
198            
199          print "read_tag $tag\n";          print "read_tag $tag\n";
200    
201          cmd(          cmd(
# Line 163  sub read_tag { Line 220  sub read_tag {
220                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
221                                  $data[ $ord ] = $data;                                  $data[ $ord ] = $data;
222                          }                          }
223                          $read_cached->{ $tag } = join('', @data);                          $tags_data->{ $tag } = join('', @data);
224                          print "DATA $tag ",dump( $read_cached ), "\n";                          print "DATA $tag ",dump( $tags_data ), "\n";
225                  }                  }
226          );          );
227    
# Line 313  sub readchunk { Line 370  sub readchunk {
370          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
371          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
372    
373          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;
374    
375          $assert->{len}      = $len;          $assert->{len}      = $len;
376          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 416  sub cmd {
416          # fix checksum if needed          # fix checksum if needed
417          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
418    
419          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
420          $assert->{send} = $cmd;          $assert->{send} = $cmd;
421          writechunk( $bytes );          writechunk( $bytes );
422    
Legend:
Removed from v.20  
changed lines
  Added in v.26
  ViewVC Help
Powered by ViewVC 1.1.26