/[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 25 by dpavlin, Sun Mar 29 01:05:49 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    
15    my $meteor = IO::Socket::INET->new( $meteor_server )
16             || die "can't connect to meteor $meteor_server: $!";
17    
18    sub meteor {
19            my @a = @_;
20            push @a, scalar localtime() if $a[0] =~ m{^info};
21    
22            warn ">> meteor ",dump( @a );
23            print $meteor "ADDMESSAGE test ",join('|',@a),"\n";
24    }
25    
26  my $debug = 0;  my $debug = 0;
27    
28  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 30  my $response = { Line 45  my $response = {
45  };  };
46    
47  GetOptions(  GetOptions(
48          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
49          'device=s'    => \$device,          'device=s'    => \$device,
50          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
51          'databits=i'  => \$databits,          'databits=i'  => \$databits,
# Line 39  GetOptions( Line 54  GetOptions(
54          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
55  ) or die $!;  ) or die $!;
56    
57    my $verbose = $debug > 0 ? $debug-- : 0;
58    
59  =head1 NAME  =head1 NAME
60    
61  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 87  it under the same terms ans Perl itself.
87    
88  =cut  =cut
89    
90    my $tags_data;
91    my $visible_tags;
92    
93  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";
94  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
95  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 98  $databits=$port->databits($databits);
98  $parity=$port->parity($parity);  $parity=$port->parity($parity);
99  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
100    
101  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
102    
103  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
104  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 113  $port->read_char_time(5);
113    
114  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
115       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
116          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
117            print "hardware version $hw_ver\n";
118            meteor( 'info', "Found reader hardware $hw_ver" );
119  });  });
120    
121  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 124  cmd( 'D6 00  0C   13  04  01 00  02 00
124  # start scanning for tags  # start scanning for tags
125    
126  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";  
   
         },  
127           '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
128                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
129                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
130    
131                  if ( ! $nr ) {                  if ( ! $nr ) {
132                          print "no tags in range\n";                          print "no tags in range\n";
133                            update_visible_tags();
134                            meteor( 'info-none-in-range' );
135                            $tags_data = {};
136                  } else {                  } else {
137    
138                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 143  cmd( 'D6 00  05   FE     00  05
143                          my @tags;                          my @tags;
144                          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 );
145                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
146                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
147    
148                          # read data from tag                          meteor( 'info-in-range', join(' ',@tags));
                         read_tag( $_ ) foreach @tags;  
149    
150                            update_visible_tags( @tags );
151                  }                  }
152          }          }
153  ) foreach ( 1 .. 100 );  ) while(1);
154    #) foreach ( 1 .. 100 );
155    
156    
157    
158    sub update_visible_tags {
159            my @tags = @_;
160    
161            my $last_visible_tags = $visible_tags;
162            $visible_tags = {};
163    
164            foreach my $tag ( @tags ) {
165                    if ( ! defined $last_visible_tags->{$tag} ) {
166                            if ( defined $tags_data->{$tag} ) {
167    #                               meteor( 'in-range', $tag );
168                            } else {
169                                    meteor( 'read', $tag );
170                                    read_tag( $tag );
171                            }
172                            $visible_tags->{$tag}++;
173                    } else {
174                            warn "## using cached data for $tag" if $debug;
175                    }
176                    delete $last_visible_tags->{$tag}; # leave just missing tags
177            }
178    
179            foreach my $tag ( keys %$last_visible_tags ) {
180                    my $data = delete $tags_data->{$tag};
181                    print "removed tag $tag with data ",dump( $data ),"\n";
182                    meteor( 'removed', $tag );
183            }
184    
185            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
186    }
187    
 my $read_cached;  
188    
189  sub read_tag {  sub read_tag {
190          my ( $tag ) = @_;          my ( $tag ) = @_;
191    
192          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
193            
194          print "read_tag $tag\n";          print "read_tag $tag\n";
195    
196          cmd(          cmd(
# Line 163  sub read_tag { Line 215  sub read_tag {
215                                  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;
216                                  $data[ $ord ] = $data;                                  $data[ $ord ] = $data;
217                          }                          }
218                          $read_cached->{ $tag } = join('', @data);                          $tags_data->{ $tag } = join('', @data);
219                          print "DATA $tag ",dump( $read_cached ), "\n";                          print "DATA $tag ",dump( $tags_data ), "\n";
220                  }                  }
221          );          );
222    
# Line 313  sub readchunk { Line 365  sub readchunk {
365          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
366          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
367    
368          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;
369    
370          $assert->{len}      = $len;          $assert->{len}      = $len;
371          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 411  sub cmd {
411          # fix checksum if needed          # fix checksum if needed
412          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
413    
414          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
415          $assert->{send} = $cmd;          $assert->{send} = $cmd;
416          writechunk( $bytes );          writechunk( $bytes );
417    
Legend:
Removed from v.20  
changed lines
  Added in v.25
  ViewVC Help
Powered by ViewVC 1.1.26