/[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 23 by dpavlin, Sat Mar 28 03:47:10 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 = IO::Socket::INET->new( '192.168.1.13:4671' ) || die "can't connect to meteor: $!";
14    
15    sub meteor {
16            my ( $item, $html ) = @_;
17            warn ">> meteor $item $html\n";
18            print $meteor "ADDMESSAGE test $item|" . localtime() . "<br>$html\n";
19    }
20    
21  my $debug = 0;  my $debug = 0;
22    
23  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 30  my $response = { Line 40  my $response = {
40  };  };
41    
42  GetOptions(  GetOptions(
43          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
44          'device=s'    => \$device,          'device=s'    => \$device,
45          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
46          'databits=i'  => \$databits,          'databits=i'  => \$databits,
# Line 39  GetOptions( Line 49  GetOptions(
49          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
50  ) or die $!;  ) or die $!;
51    
52    my $verbose = $debug > 0 ? $debug-- : 0;
53    
54  =head1 NAME  =head1 NAME
55    
56  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 82  it under the same terms ans Perl itself.
82    
83  =cut  =cut
84    
85    my $tags_data;
86    my $visible_tags;
87    
88  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";
89  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
90  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 93  $databits=$port->databits($databits);
93  $parity=$port->parity($parity);  $parity=$port->parity($parity);
94  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
95    
96  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
97    
98  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
99  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 108  $port->read_char_time(5);
108    
109  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
110       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
111          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
112            print "hardware version $hw_ver\n";
113            meteor( -1, "Found reader $hw_ver" );
114  });  });
115    
116  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 119  cmd( 'D6 00  0C   13  04  01 00  02 00
119  # start scanning for tags  # start scanning for tags
120    
121  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";  
   
         },  
122           '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
123                  my $rest = shift || die "no rest?";                  my $rest = shift || die "no rest?";
124                  my $nr = ord( substr( $rest, 0, 1 ) );                  my $nr = ord( substr( $rest, 0, 1 ) );
125    
126                  if ( ! $nr ) {                  if ( ! $nr ) {
127                          print "no tags in range\n";                          print "no tags in range\n";
128                            update_visible_tags();
129                            meteor( -1, "No tags in range" );
130                  } else {                  } else {
131    
132                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
# Line 123  cmd( 'D6 00  05   FE     00  05 Line 137  cmd( 'D6 00  05   FE     00  05
137                          my @tags;                          my @tags;
138                          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 );
139                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
140                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
141    
142                            update_visible_tags( @tags );
143    
144                            my $html = join('', map { "<li><tt>$_</tt>" } @tags);
145                            meteor( 0, "Tags:<ul>$html</ul>" );
146                    }
147            }
148    ) foreach ( 1 .. 1000 );
149    
                         # read data from tag  
                         read_tag( $_ ) foreach @tags;  
150    
151    
152    sub update_visible_tags {
153            my @tags = @_;
154    
155            my $last_visible_tags = $visible_tags;
156            $visible_tags = {};
157    
158            foreach my $tag ( @tags ) {
159                    if ( ! defined $last_visible_tags->{$tag} ) {
160                            read_tag( $tag );
161                            $visible_tags->{$tag}++;
162                    } else {
163                            warn "## using cached data for $tag" if $debug;
164                  }                  }
165                    delete $last_visible_tags->{$tag}; # leave just missing tags
166          }          }
 ) foreach ( 1 .. 100 );  
167    
168  my $read_cached;          foreach my $tag ( keys %$last_visible_tags ) {
169                    my $data = delete $tags_data->{$tag};
170                    print "removed tag $tag with data ",dump( $data ),"\n";
171            }
172    
173            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
174    }
175    
176    
177  sub read_tag {  sub read_tag {
178          my ( $tag ) = @_;          my ( $tag ) = @_;
179    
180          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
181            
182            return if defined $tags_data->{$tag};
183    
184          print "read_tag $tag\n";          print "read_tag $tag\n";
185    
186          cmd(          cmd(
# Line 163  sub read_tag { Line 205  sub read_tag {
205                                  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;
206                                  $data[ $ord ] = $data;                                  $data[ $ord ] = $data;
207                          }                          }
208                          $read_cached->{ $tag } = join('', @data);                          $tags_data->{ $tag } = join('', @data);
209                          print "DATA $tag ",dump( $read_cached ), "\n";                          print "DATA $tag ",dump( $tags_data ), "\n";
210                  }                  }
211          );          );
212    
# Line 178  if (0) { Line 220  if (0) {
220  }  }
221          warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";          warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
222    
223            my $item = unpack('H*', substr($tag,-8) ) % 100000;
224            meteor( $item, "Loading $item" );
225    
226  }  }
227    
228  exit;  exit;
# Line 313  sub readchunk { Line 358  sub readchunk {
358          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
359          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
360    
361          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;
362    
363          $assert->{len}      = $len;          $assert->{len}      = $len;
364          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 359  sub cmd { Line 404  sub cmd {
404          # fix checksum if needed          # fix checksum if needed
405          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
406    
407          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
408          $assert->{send} = $cmd;          $assert->{send} = $cmd;
409          writechunk( $bytes );          writechunk( $bytes );
410    
Legend:
Removed from v.20  
changed lines
  Added in v.23
  ViewVC Help
Powered by ViewVC 1.1.26