/[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 26 by dpavlin, Wed Apr 1 16:59:09 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_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";
33    my $baudrate  = "19200";
34    my $databits  = "8";
35    my $parity        = "none";
36    my $stopbits  = "1";
37    my $handshake = "none";
38    
39  my $response = {  my $response = {
40          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
41          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 48  my $response = {
48          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
49  };  };
50    
51    GetOptions(
52            'd|debug+'    => \$debug,
53            'device=s'    => \$device,
54            'baudrate=i'  => \$baudrate,
55            'databits=i'  => \$databits,
56            'parity=s'    => \$parity,
57            'stopbits=i'  => \$stopbits,
58            'handshake=s' => \$handshake,
59            'meteor=s'    => \$meteor_server,
60    ) 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
67    
68  =head1 SYNOPSIS  =head1 SYNOPSIS
69    
70  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
71    
72  =head1 DESCRIPTION  =head1 DESCRIPTION
73    
# Line 52  it under the same terms ans Perl itself. Line 92  it under the same terms ans Perl itself.
92    
93  =cut  =cut
94    
95  # your serial port.  my $tags_data;
96  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
97    
98  my $port=new Device::SerialPort($device) || die "new($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;
100  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
101  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
102  $databits=$port->databits($databits);  $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 81  $port->read_char_time(5); Line 116  $port->read_char_time(5);
116    
117  # initial hand-shake with device  # initial hand-shake with device
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', 'hw 10.5.0.2', 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','stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
127       '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() }  );
128    
129  # start scanning for tags  # start scanning for tags
130    
131  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
132       '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
133  dispatch(                  my $rest = shift || die "no rest?";
134           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
135                  sub {  
136                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
137                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
138                            update_visible_tags();
139                            meteor( 'info-none-in-range' );
140                            $tags_data = {};
141                    } else {
142    
143                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
144    
145                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 106  dispatch( Line 148  dispatch(
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                            meteor( 'info-in-range', join(' ',@tags));
154    
155                            update_visible_tags( @tags );
156                    }
157            }
158    ) while(1);
159    #) foreach ( 1 .. 100 );
160    
                         # XXX read first tag  
                         read_tag( @tags );  
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  ) foreach ( 1 .. 100 );          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            confess "no tag?" unless $tag;
198    
199          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
200    
201          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          cmd(
202                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
203                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
204                            print "FIXME: tag $tag ready?\n";
205                    },
206                    "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";
207                            my $rest = shift || die "no rest?";
208                            warn "## DATA ", dump( $rest ) if $debug;
209                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
210                            my $blocks = ord(substr($rest,8,1));
211                            $rest = substr($rest,9); # leave just data blocks
212                            my @data;
213                            foreach my $nr ( 0 .. $blocks - 1 ) {
214                                    my $block = substr( $rest, $nr * 6, 6 );
215                                    warn "## block ",as_hex( $block ) if $debug;
216                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
217                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
218                                    my $data  = substr( $block, 2 );
219                                    die "data payload should be 4 bytes" if length($data) != 4;
220                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
221                                    $data[ $ord ] = $data;
222                            }
223                            $tags_data->{ $tag } = join('', @data);
224                            print "DATA $tag ",dump( $tags_data ), "\n";
225                    }
226            );
227    
228          #        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";  
229  if (0) {  if (0) {
230          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' );
231    
# Line 139  if (0) { Line 237  if (0) {
237    
238  }  }
239    
240    exit;
241    
242  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
243    
244  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  sub writechunk Line 269  sub writechunk
269  {  {
270          my $str=shift;          my $str=shift;
271          my $count = $port->write($str);          my $count = $port->write($str);
272          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
273  }  }
274    
275  sub as_hex {  sub as_hex {
# Line 217  sub assert { Line 317  sub assert {
317          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
318  }  }
319    
 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;  
         }  
 }  
   
320  use Digest::CRC;  use Digest::CRC;
321    
322  sub crcccitt {  sub crcccitt {
# Line 256  sub checksum { Line 338  sub checksum {
338          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
339    
340          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
341          my $len_real = length($bytes);          my $len_real = length($bytes) - 1;
342          print "length wrong: $len_real != $len\n" if $len_real != $len;  
343            if ( $len_real != $len ) {
344                    print "length wrong: $len_real != $len\n";
345                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
346            }
347    
348          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
349                  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 352  sub checksum {
352          return $bytes . $checksum;          return $bytes . $checksum;
353  }  }
354    
355  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
356    
357    sub readchunk {
358          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
359    
360          # read header of packet          # read header of packet
# Line 282  sub readchunk { Line 368  sub readchunk {
368          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
369    
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;
377    
378          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
379            # find longest match for incomming data
380            my ($to) = grep {
381                    my $match = substr($payload,0,length($_));
382                    m/^\Q$match\E/
383            } sort { length($a) <=> length($b) } keys %$dispatch;
384            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
385    
386            if ( defined $to ) {
387                    my $rest = substr( $payload, length($to) );
388                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
389                    $dispatch->{ $to }->( $rest );
390            } else {
391                    print "NO DISPATCH for ",dump( $full ),"\n";
392            }
393    
394          return $data;          return $data;
395  }  }
# Line 297  sub readchunk { Line 397  sub readchunk {
397  sub str2bytes {  sub str2bytes {
398          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
399          my $b = $str;          my $b = $str;
400          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
401          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
402          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
403          my $bytes = eval $b;          my $bytes = eval $b;
404          die $@ if $@;          die $@ if $@;
405          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 308  sub str2bytes { Line 407  sub str2bytes {
407  }  }
408    
409  sub cmd {  sub cmd {
410          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
411            my $cmd_desc = shift || confess "no description?";
412            my @expect = @_;
413    
414          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
415    
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    
423          if ( $expect ) {          while ( @expect ) {
424                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
425                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
426                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
427    
428                    next if defined $dispatch->{ $pattern };
429    
430                    $dispatch->{ substr($pattern,3) } = $coderef;
431                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
432          }          }
433    
434            readchunk;
435  }  }
436    
Legend:
Removed from v.16  
changed lines
  Added in v.26
  ViewVC Help
Powered by ViewVC 1.1.26