/[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 17 by dpavlin, Fri Oct 3 08:53:57 2008 UTC revision 24 by dpavlin, Sat Mar 28 14:20:27 2009 UTC
# Line 6  use warnings; Line 6  use warnings;
6    
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9    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";
24    my $baudrate  = "19200";
25    my $databits  = "8";
26    my $parity        = "none";
27    my $stopbits  = "1";
28    my $handshake = "none";
29    
30  my $response = {  my $response = {
31          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
32          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 39  my $response = {
39          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
40  };  };
41    
42    GetOptions(
43            'd|debug+'    => \$debug,
44            'device=s'    => \$device,
45            'baudrate=i'  => \$baudrate,
46            'databits=i'  => \$databits,
47            'parity=s'    => \$parity,
48            'stopbits=i'  => \$stopbits,
49            'handshake=s' => \$handshake,
50    ) 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
57    
58  =head1 SYNOPSIS  =head1 SYNOPSIS
59    
60  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
61    
62  =head1 DESCRIPTION  =head1 DESCRIPTION
63    
# Line 52  it under the same terms ans Perl itself. Line 82  it under the same terms ans Perl itself.
82    
83  =cut  =cut
84    
85  # your serial port.  my $tags_data;
86  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
87    
88  my $port=new Device::SerialPort($device) || die "new($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;
90  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
91  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
92  $databits=$port->databits($databits);  $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 81  $port->read_char_time(5); Line 106  $port->read_char_time(5);
106    
107  # initial hand-shake with device  # initial hand-shake with device
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', 'hw 10.5.0.2', 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','stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
117       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
118    
119  # start scanning for tags  # start scanning for tags
120    
121  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
122       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
123  dispatch(                  my $rest = shift || die "no rest?";
124           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
125                  sub {  
126                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
127                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
128                            update_visible_tags();
129                            meteor( -1, "No tags in range" );
130                            $tags_data = {};
131                    } else {
132    
133                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
134    
135                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 106  dispatch( Line 138  dispatch(
138                          my @tags;                          my @tags;
139                          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 );
140                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
141                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
142    
143                            update_visible_tags( @tags );
144    
145                          # XXX read first tag                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);
146                          read_tag( @tags );                          meteor( 0, "Tags:<ul>$html</ul>" );
147                    }
148            }
149    ) while(1);
150    #) foreach ( 1 .. 100 );
151    
152    
153    
154    sub update_visible_tags {
155            my @tags = @_;
156    
157            my $last_visible_tags = $visible_tags;
158            $visible_tags = {};
159    
160            foreach my $tag ( @tags ) {
161                    if ( ! defined $last_visible_tags->{$tag} ) {
162                            read_tag( $tag );
163                            $visible_tags->{$tag}++;
164                    } else {
165                            warn "## using cached data for $tag" if $debug;
166                  }                  }
167  ) }                  delete $last_visible_tags->{$tag}; # leave just missing tags
168            }
169    
170  ) foreach ( 1 .. 100 );          foreach my $tag ( keys %$last_visible_tags ) {
171                    my $data = delete $tags_data->{$tag};
172                    print "removed tag $tag with data ",dump( $data ),"\n";
173            }
174    
175            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
176    }
177    
 my $read_cached;  
178    
179  sub read_tag {  sub read_tag {
180          my ( $tag ) = @_;          my ( $tag ) = @_;
181    
182            confess "no tag?" unless $tag;
183    
184            return if defined $tags_data->{$tag};
185    
186          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
187    
188          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          cmd(
189                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
190                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
191                            print "FIXME: tag $tag ready?\n";
192                    },
193                    "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";
194                            my $rest = shift || die "no rest?";
195                            warn "## DATA ", dump( $rest ) if $debug;
196                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
197                            my $blocks = ord(substr($rest,8,1));
198                            $rest = substr($rest,9); # leave just data blocks
199                            my @data;
200                            foreach my $nr ( 0 .. $blocks - 1 ) {
201                                    my $block = substr( $rest, $nr * 6, 6 );
202                                    warn "## block ",as_hex( $block ) if $debug;
203                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
204                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
205                                    my $data  = substr( $block, 2 );
206                                    die "data payload should be 4 bytes" if length($data) != 4;
207                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
208                                    $data[ $ord ] = $data;
209                            }
210                            $tags_data->{ $tag } = join('', @data);
211                            print "DATA $tag ",dump( $tags_data ), "\n";
212                    }
213            );
214    
215          #        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          #        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
         warn "?? D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";  
216  if (0) {  if (0) {
217          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
218    
# Line 137  if (0) { Line 222  if (0) {
222  }  }
223          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";
224    
225            my $item = unpack('H*', substr($tag,-8) ) % 100000;
226            meteor( $item, "Loading $item" );
227    
228  }  }
229    
230    exit;
231    
232  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
233    
234  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  sub writechunk Line 259  sub writechunk
259  {  {
260          my $str=shift;          my $str=shift;
261          my $count = $port->write($str);          my $count = $port->write($str);
262          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
263  }  }
264    
265  sub as_hex {  sub as_hex {
# Line 217  sub assert { Line 307  sub assert {
307          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
308  }  }
309    
 our $dispatch;  
 sub dispatch {  
         my ( $pattern, $coderef ) = @_;  
         my $patt = substr( str2bytes($pattern), 3 ); # just payload  
         my $l = length($patt);  
         my $p = substr( $assert->{payload}, 0, $l );  
         warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;  
   
         if ( $assert->{payload} eq $assert->{expect} ) {  
                 warn "## no dispatch, payload expected" if $debug;  
         } elsif ( $p eq $patt ) {  
                 # if matched call with rest of payload  
                 $coderef->( substr( $assert->{payload}, $l ) );  
         } else {  
                 warn "## dispatch ignored" if $debug;  
         }  
 }  
   
310  use Digest::CRC;  use Digest::CRC;
311    
312  sub crcccitt {  sub crcccitt {
# Line 270  sub checksum { Line 342  sub checksum {
342          return $bytes . $checksum;          return $bytes . $checksum;
343  }  }
344    
345  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
346    
347    sub readchunk {
348          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
349    
350          # read header of packet          # read header of packet
# Line 286  sub readchunk { Line 358  sub readchunk {
358          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
359    
360          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
361          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
362    
363          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;
364    
365          $assert->{len}      = $len;          $assert->{len}      = $len;
366          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
367    
368          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
369            # find longest match for incomming data
370            my ($to) = grep {
371                    my $match = substr($payload,0,length($_));
372                    m/^\Q$match\E/
373            } sort { length($a) <=> length($b) } keys %$dispatch;
374            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
375    
376            if ( defined $to ) {
377                    my $rest = substr( $payload, length($to) );
378                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
379                    $dispatch->{ $to }->( $rest );
380            } else {
381                    print "NO DISPATCH for ",dump( $full ),"\n";
382            }
383    
384          return $data;          return $data;
385  }  }
# Line 311  sub str2bytes { Line 397  sub str2bytes {
397  }  }
398    
399  sub cmd {  sub cmd {
400          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
401            my $cmd_desc = shift || confess "no description?";
402            my @expect = @_;
403    
404          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
405    
406          # fix checksum if needed          # fix checksum if needed
407          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
408    
409          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
410          $assert->{send} = $cmd;          $assert->{send} = $cmd;
411          writechunk( $bytes );          writechunk( $bytes );
412    
413          if ( $expect ) {          while ( @expect ) {
414                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
415                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
416                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
417    
418                    next if defined $dispatch->{ $pattern };
419    
420                    $dispatch->{ substr($pattern,3) } = $coderef;
421                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
422          }          }
423    
424            readchunk;
425  }  }
426    
Legend:
Removed from v.17  
changed lines
  Added in v.24
  ViewVC Help
Powered by ViewVC 1.1.26