/[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 16 by dpavlin, Thu Oct 2 22:53:57 2008 UTC revision 23 by dpavlin, Sat Mar 28 03:47:10 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                    } else {
131    
132                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
133    
134                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 106  dispatch( Line 137  dispatch(
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                          # XXX read first tag                          update_visible_tags( @tags );
                         read_tag( @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    
150    
 ) foreach ( 1 .. 100 );  
151    
152  my $read_cached;  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            }
167    
168            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            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";
         return if $read_cached->{ $tag }++;  
185    
186          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          cmd(
187                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
188                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
189                            print "FIXME: tag $tag ready?\n";
190                    },
191                    "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";
192                            my $rest = shift || die "no rest?";
193                            warn "## DATA ", dump( $rest ) if $debug;
194                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
195                            my $blocks = ord(substr($rest,8,1));
196                            $rest = substr($rest,9); # leave just data blocks
197                            my @data;
198                            foreach my $nr ( 0 .. $blocks - 1 ) {
199                                    my $block = substr( $rest, $nr * 6, 6 );
200                                    warn "## block ",as_hex( $block ) if $debug;
201                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
202                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
203                                    my $data  = substr( $block, 2 );
204                                    die "data payload should be 4 bytes" if length($data) != 4;
205                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
206                                    $data[ $ord ] = $data;
207                            }
208                            $tags_data->{ $tag } = join('', @data);
209                            print "DATA $tag ",dump( $tags_data ), "\n";
210                    }
211            );
212    
213          #        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";  
214  if (0) {  if (0) {
215          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' );
216    
# Line 137  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;
229    
230  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
231    
232  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  sub writechunk Line 257  sub writechunk
257  {  {
258          my $str=shift;          my $str=shift;
259          my $count = $port->write($str);          my $count = $port->write($str);
260          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
261  }  }
262    
263  sub as_hex {  sub as_hex {
# Line 217  sub assert { Line 305  sub assert {
305          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
306  }  }
307    
 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;  
         }  
 }  
   
308  use Digest::CRC;  use Digest::CRC;
309    
310  sub crcccitt {  sub crcccitt {
# Line 256  sub checksum { Line 326  sub checksum {
326          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
327    
328          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
329          my $len_real = length($bytes);          my $len_real = length($bytes) - 1;
330          print "length wrong: $len_real != $len\n" if $len_real != $len;  
331            if ( $len_real != $len ) {
332                    print "length wrong: $len_real != $len\n";
333                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
334            }
335    
336          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
337                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
# Line 266  sub checksum { Line 340  sub checksum {
340          return $bytes . $checksum;          return $bytes . $checksum;
341  }  }
342    
343  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
344    
345    sub readchunk {
346          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
347    
348          # read header of packet          # read header of packet
# Line 282  sub readchunk { Line 356  sub readchunk {
356          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
357    
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;
365    
366          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
367            # find longest match for incomming data
368            my ($to) = grep {
369                    my $match = substr($payload,0,length($_));
370                    m/^\Q$match\E/
371            } sort { length($a) <=> length($b) } keys %$dispatch;
372            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
373    
374            if ( defined $to ) {
375                    my $rest = substr( $payload, length($to) );
376                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
377                    $dispatch->{ $to }->( $rest );
378            } else {
379                    print "NO DISPATCH for ",dump( $full ),"\n";
380            }
381    
382          return $data;          return $data;
383  }  }
# Line 297  sub readchunk { Line 385  sub readchunk {
385  sub str2bytes {  sub str2bytes {
386          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
387          my $b = $str;          my $b = $str;
388          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
389          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
390          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
391          my $bytes = eval $b;          my $bytes = eval $b;
392          die $@ if $@;          die $@ if $@;
393          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 308  sub str2bytes { Line 395  sub str2bytes {
395  }  }
396    
397  sub cmd {  sub cmd {
398          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
399            my $cmd_desc = shift || confess "no description?";
400            my @expect = @_;
401    
402          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
403    
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    
411          if ( $expect ) {          while ( @expect ) {
412                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
413                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
414                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
415    
416                    next if defined $dispatch->{ $pattern };
417    
418                    $dispatch->{ substr($pattern,3) } = $coderef;
419                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
420          }          }
421    
422            readchunk;
423  }  }
424    
Legend:
Removed from v.16  
changed lines
  Added in v.23
  ViewVC Help
Powered by ViewVC 1.1.26