/[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 15 by dpavlin, Thu Oct 2 21:20:10 2008 UTC revision 29 by dpavlin, Mon Apr 6 13:10:40 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    use File::Slurp;
11    
12    use IO::Socket::INET;
13    
14    my $meteor_server = '192.168.1.13:4671';
15    my $meteor_fh;
16    
17    sub meteor {
18            my @a = @_;
19            push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21            if ( ! defined $meteor_fh ) {
22                    warn "# open connection to $meteor_server";
23                    $meteor_fh = IO::Socket::INET->new(
24                                    PeerAddr => $meteor_server,
25                                    Timeout => 1,
26                    ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
27                    $meteor_fh = 0; # don't try again
28            }
29    
30            warn ">> meteor ",dump( @a );
31            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
32    }
33    
34  my $debug = 0;  my $debug = 0;
35    
36    my $device    = "/dev/ttyUSB0";
37    my $baudrate  = "19200";
38    my $databits  = "8";
39    my $parity        = "none";
40    my $stopbits  = "1";
41    my $handshake = "none";
42    
43    my $program_path = './program/';
44    
45  my $response = {  my $response = {
46          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
47          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 54  my $response = {
54          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
55  };  };
56    
57    GetOptions(
58            'd|debug+'    => \$debug,
59            'device=s'    => \$device,
60            'baudrate=i'  => \$baudrate,
61            'databits=i'  => \$databits,
62            'parity=s'    => \$parity,
63            'stopbits=i'  => \$stopbits,
64            'handshake=s' => \$handshake,
65            'meteor=s'    => \$meteor_server,
66    ) or die $!;
67    
68    my $verbose = $debug > 0 ? $debug-- : 0;
69    
70  =head1 NAME  =head1 NAME
71    
72  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
73    
74  =head1 SYNOPSIS  =head1 SYNOPSIS
75    
76  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
77    
78  =head1 DESCRIPTION  =head1 DESCRIPTION
79    
# Line 52  it under the same terms ans Perl itself. Line 98  it under the same terms ans Perl itself.
98    
99  =cut  =cut
100    
101  # your serial port.  my $tags_data;
102  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
103    
104  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
105    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
106  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
107  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
108  $databits=$port->databits($databits);  $databits=$port->databits($databits);
109  $parity=$port->parity($parity);  $parity=$port->parity($parity);
110  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
111    
112  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
113    
114  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
115  $port->lookclear();  $port->lookclear();
# Line 81  $port->read_char_time(5); Line 122  $port->read_char_time(5);
122    
123  # initial hand-shake with device  # initial hand-shake with device
124    
125  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
126       '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 {
127          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
128            print "hardware version $hw_ver\n";
129            meteor( 'info', "Found reader hardware $hw_ver" );
130  });  });
131    
132  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?',
133       '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() }  );
134    
135  # start scanning for tags  # start scanning for tags
136    
137  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
138       '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
139  dispatch(                  my $rest = shift || die "no rest?";
140           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
141                  sub {  
142                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
143                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
144                            update_visible_tags();
145                            meteor( 'info-none-in-range' );
146                            $tags_data = {};
147                    } else {
148    
149                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
150    
151                          my $tl = length( $tags );                          my $tl = length( $tags );
152                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
153    
154                          my @tags;                          my @tags;
155                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
156                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
157                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
158    
159                            meteor( 'info-in-range', join(' ',@tags));
160    
161                            update_visible_tags( @tags );
162                    }
163            }
164    ) while(1);
165    #) foreach ( 1 .. 100 );
166    
167    
168    
169    sub update_visible_tags {
170            my @tags = @_;
171    
172            my $last_visible_tags = $visible_tags;
173            $visible_tags = {};
174    
175            foreach my $tag ( @tags ) {
176                    if ( ! defined $last_visible_tags->{$tag} ) {
177                            if ( defined $tags_data->{$tag} ) {
178    #                               meteor( 'in-range', $tag );
179                            } else {
180                                    meteor( 'read', $tag );
181                                    read_tag( $tag );
182                            }
183                            $visible_tags->{$tag}++;
184                    } else {
185                            warn "## using cached data for $tag" if $debug;
186                  }                  }
187  ) }                  delete $last_visible_tags->{$tag}; # leave just missing tags
188    
189  ) foreach ( 1 .. 100 );                  if ( -e "$program_path/$tag" ) {
190                                    meteor( 'write', $tag );
191                                    write_tag( $tag );
192                    }
193            }
194    
195  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          foreach my $tag ( keys %$last_visible_tags ) {
196                    my $data = delete $tags_data->{$tag};
197                    print "removed tag $tag with data ",dump( $data ),"\n";
198                    meteor( 'removed', $tag );
199            }
200    
201  #     D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
202  warn "D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";  }
203    
204  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  my $tag_data_block;
205    
206  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00    sub read_tag_data {
207  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          my ($start_block,$rest) = @_;
208  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36          die "no rest?" unless $rest;
209                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
210  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
211            my $blocks = ord(substr($rest,8,1));
212            $rest = substr($rest,9); # leave just data blocks
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                    my $expected_ord = $nr + $start_block;
218                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
219                    my $data  = substr( $block, 2 );
220                    die "data payload should be 4 bytes" if length($data) != 4;
221                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
222                    $tag_data_block->{$tag}->[ $ord ] = $data;
223            }
224            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
225            print "DATA $tag ",dump( $tags_data ), "\n";
226    }
227    
228    sub read_tag {
229            my ( $tag ) = @_;
230    
231            confess "no tag?" unless $tag;
232    
233            print "read_tag $tag\n";
234    
235            cmd(
236                    "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
237                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
238                            print "FIXME: tag $tag ready?\n";
239                    },
240                    "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";
241                            read_tag_data( 0, @_ );
242                    },
243            );
244    
245            cmd(
246                    "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
247                    "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
248                            read_tag_data( 3, @_ );
249                    }
250            );
251    
252    }
253    
254    sub write_tag {
255            my ($tag) = @_;
256    
257            my $path = "$program_path/$tag";
258    
259            my $data = read_file( $path );
260    
261            print "write_tag $tag = $data\n";
262    
263            cmd(
264                    "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",
265                    "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
266            ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
267    
268            my $to = $path;
269            $to .= '.' . time();
270    
271            rename $path, $to;
272            print ">> $to\n";
273    
274    }
275    
276    exit;
277    
278  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
279    
# Line 155  sub writechunk Line 305  sub writechunk
305  {  {
306          my $str=shift;          my $str=shift;
307          my $count = $port->write($str);          my $count = $port->write($str);
308          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
309  }  }
310    
311  sub as_hex {  sub as_hex {
# Line 174  sub read_bytes { Line 324  sub read_bytes {
324          my $data = '';          my $data = '';
325          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
326                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
327                    die "no bytes on port: $!" unless defined $b;
328                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
329                  $data .= $b;                  $data .= $b;
330          }          }
# Line 203  sub assert { Line 354  sub assert {
354          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
355  }  }
356    
 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;  
         }  
 }  
   
357  use Digest::CRC;  use Digest::CRC;
358    
359  sub crcccitt {  sub crcccitt {
# Line 241  sub checksum { Line 374  sub checksum {
374          my $xor = crcccitt( substr($bytes,1) ); # skip D6          my $xor = crcccitt( substr($bytes,1) ); # skip D6
375          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
376    
377            my $len = ord(substr($bytes,2,1));
378            my $len_real = length($bytes) - 1;
379    
380            if ( $len_real != $len ) {
381                    print "length wrong: $len_real != $len\n";
382                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
383            }
384    
385          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
386                  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";
387                    return $bytes . $xor;
388          }          }
389            return $bytes . $checksum;
390  }  }
391    
392  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
393    
394    sub readchunk {
395          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
396    
397          # read header of packet          # read header of packet
# Line 262  sub readchunk { Line 405  sub readchunk {
405          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
406    
407          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
408          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
409    
410          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;
411    
412          $assert->{len}      = $len;          $assert->{len}      = $len;
413          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
414    
415          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
416            # find longest match for incomming data
417            my ($to) = grep {
418                    my $match = substr($payload,0,length($_));
419                    m/^\Q$match\E/
420            } sort { length($a) <=> length($b) } keys %$dispatch;
421            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
422    
423            if ( defined $to ) {
424                    my $rest = substr( $payload, length($to) );
425                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
426                    $dispatch->{ $to }->( $rest );
427            } else {
428                    print "NO DISPATCH for ",dump( $full ),"\n";
429            }
430    
431          return $data;          return $data;
432  }  }
# Line 277  sub readchunk { Line 434  sub readchunk {
434  sub str2bytes {  sub str2bytes {
435          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
436          my $b = $str;          my $b = $str;
437          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
438          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
439          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
440          my $bytes = eval $b;          my $bytes = eval $b;
441          die $@ if $@;          die $@ if $@;
442          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 288  sub str2bytes { Line 444  sub str2bytes {
444  }  }
445    
446  sub cmd {  sub cmd {
447          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
448            my $cmd_desc = shift || confess "no description?";
449            my @expect = @_;
450    
451          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
452    
453          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
454            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
455    
456            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
457          $assert->{send} = $cmd;          $assert->{send} = $cmd;
458          writechunk( $bytes );          writechunk( $bytes );
459    
460          if ( $expect ) {          while ( @expect ) {
461                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
462                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
463                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
464    
465                    next if defined $dispatch->{ $pattern };
466    
467                    $dispatch->{ substr($pattern,3) } = $coderef;
468                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
469          }          }
470    
471            readchunk;
472  }  }
473    
Legend:
Removed from v.15  
changed lines
  Added in v.29
  ViewVC Help
Powered by ViewVC 1.1.26