/[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 1 by dpavlin, Sun Sep 28 12:57:32 2008 UTC revision 29 by dpavlin, Mon Apr 6 13:10:40 2009 UTC
# Line 5  use strict; Line 5  use strict;
5  use warnings;  use warnings;
6    
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8    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;
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?',
# Line 18  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 36  L<Device::SerialPort(3)> Line 85  L<Device::SerialPort(3)>
85    
86  L<perl(1)>  L<perl(1)>
87    
88    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
89    
90  =head1 AUTHOR  =head1 AUTHOR
91    
92  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
# Line 47  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 74  $port->read_char_time(5); Line 120  $port->read_char_time(5);
120  #$port->stty_inpck(1);  #$port->stty_inpck(1);
121  #$port->stty_istrip(1);  #$port->stty_istrip(1);
122    
123  sub cmd {  # initial hand-shake with device
124          my ( $cmd, $desc, $expect ) = @_;  
125          $cmd =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
126          $cmd =~ s/\s+/\\x/g;       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
127          $cmd = '"\x' . $cmd . '"';          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
128          my $bytes = eval $cmd;          print "hardware version $hw_ver\n";
129          die $@ if $@;          meteor( 'info', "Found reader hardware $hw_ver" );
130          warn ">> ", as_hex( $bytes ), "\t$desc\n";  });
131          writechunk( $bytes );  
132          warn "?? $expect\n" if $expect;  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
133          readchunk();       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
134    
135    # start scanning for tags
136    
137    cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
138             'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
139                    my $rest = shift || die "no rest?";
140                    my $nr = ord( substr( $rest, 0, 1 ) );
141    
142                    if ( ! $nr ) {
143                            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 );
150    
151                            my $tl = length( $tags );
152                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
153    
154                            my @tags;
155                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
156                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
157                            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                    if ( -e "$program_path/$tag" ) {
190                                    meteor( 'write', $tag );
191                                    write_tag( $tag );
192                    }
193            }
194    
195            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            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
202    }
203    
204    my $tag_data_block;
205    
206    sub read_tag_data {
207            my ($start_block,$rest) = @_;
208            die "no rest?" unless $rest;
209            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
210            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  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  sub read_tag {
229       'D5 00  09  04   00   11   0A 05 00 02   7250 -- hw 10.5.0.2' );          my ( $tag ) = @_;
230    
231            confess "no tag?" unless $tag;
232    
233            print "read_tag $tag\n";
234    
235  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );          cmd(
236  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778                  "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  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  sub write_tag {
255       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );          my ($tag) = @_;
256    
257  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen          my $path = "$program_path/$tag";
258    
259  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          my $data = read_file( $path );
260    
261  #     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          print "write_tag $tag = $data\n";
 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";  
262    
263  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          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  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00    exit;
 #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
 warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
                                                                        05 00   00 00 00 00   06 00   00 00 00 00    524B\n";  
 warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";  
277    
278  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
279    
# Line 140  print "Port closed\n"; Line 304  print "Port closed\n";
304  sub writechunk  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 {
312          my @out;          my @out;
313          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
314                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
315                  $hex =~ s/(..)/$1 /g;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
316                    $hex =~ s/\s+$//;
317                  push @out, $hex;                  push @out, $hex;
318          }          }
319          return join('  ', @out);          return join(' | ', @out);
320  }  }
321    
322  sub read_bytes {  sub read_bytes {
# Line 160  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          }          }
331          $desc ||= '?';          $desc ||= '?';
332          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
333          return $data;          return $data;
334  }  }
335    
336    our $assert;
337    
338    # my $rest = skip_assert( 3 );
339    sub skip_assert {
340            assert( 0, shift );
341    }
342    
343    sub assert {
344            my ( $from, $to ) = @_;
345    
346            $from ||= 0;
347            $to = length( $assert->{expect} ) if ! defined $to;
348    
349            my $p = substr( $assert->{payload}, $from, $to );
350            my $e = substr( $assert->{expect},  $from, $to );
351            warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
352    
353            # return the rest
354            return substr( $assert->{payload}, $to );
355    }
356    
357    use Digest::CRC;
358    
359    sub crcccitt {
360            my $bytes = shift;
361            my $crc = Digest::CRC->new(
362                    # midified CCITT to xor with 0xffff instead of 0x0000
363                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
364            ) or die $!;
365            $crc->add( $bytes );
366            pack('n', $crc->digest);
367    }
368    
369    # my $checksum = checksum( $bytes );
370    # my $checksum = checksum( $bytes, $original_checksum );
371    sub checksum {
372            my ( $bytes, $checksum ) = @_;
373    
374            my $xor = crcccitt( substr($bytes,1) ); # skip D6
375            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 ) {
386                    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    our $dispatch;
393    
394  sub readchunk {  sub readchunk {
395            sleep 1;        # FIXME remove
396    
397          # read header of packet          # read header of packet
398          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
399          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
400            my $len = ord($length);
401          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
402    
403          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
404            my $payload_len = length($data);
405            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
406    
407            my $checksum = substr( $data, -2, 2 );
408            checksum( $header . $length . $payload , $checksum );
409    
410            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
411    
412            $assert->{len}      = $len;
413            $assert->{payload}  = $payload;
414    
415            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;
432    }
433    
434    sub str2bytes {
435            my $str = shift || confess "no str?";
436            my $b = $str;
437            $b =~ s/\s+//g;
438            $b =~ s/(..)/\\x$1/g;
439            $b = "\"$b\"";
440            my $bytes = eval $b;
441            die $@ if $@;
442            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
443            return $bytes;
444    }
445    
446    sub cmd {
447            my $cmd = shift || confess "no cmd?";
448            my $cmd_desc = shift || confess "no description?";
449            my @expect = @_;
450    
451            my $bytes = str2bytes( $cmd );
452    
453            # 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;
458            writechunk( $bytes );
459    
460            while ( @expect ) {
461                    my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
462                    my $coderef = shift @expect || confess "no coderef?";
463                    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          sleep 1;          readchunk;
472  }  }
473    

Legend:
Removed from v.1  
changed lines
  Added in v.29

  ViewVC Help
Powered by ViewVC 1.1.26