/[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 2 by dpavlin, Sun Sep 28 14:05:43 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;
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?',
# Line 19  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 37  L<Device::SerialPort(3)> Line 79  L<Device::SerialPort(3)>
79    
80  L<perl(1)>  L<perl(1)>
81    
82    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
83    
84  =head1 AUTHOR  =head1 AUTHOR
85    
86  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
# Line 48  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 75  $port->read_char_time(5); Line 114  $port->read_char_time(5);
114  #$port->stty_inpck(1);  #$port->stty_inpck(1);
115  #$port->stty_istrip(1);  #$port->stty_istrip(1);
116    
117  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
118       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
119          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
120          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
121          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\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       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
128    
129    # start scanning for tags
130    
131    cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
132             'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
133                    my $rest = shift || die "no rest?";
134                    my $nr = ord( substr( $rest, 0, 1 ) );
135    
136                    if ( ! $nr ) {
137                            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 );
144    
145                            my $tl = length( $tags );
146                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
147    
148                            my @tags;
149                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
150                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
151                            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    
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            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
191    }
192    
 cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  
      'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );  
193    
194  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  sub read_tag {
195            my ( $tag ) = @_;
196    
197  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          confess "no tag?" unless $tag;
198    
199  #     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 "read_tag $tag\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";  
200    
201  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          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
229    if (0) {
230            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
231    
232            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
233            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
234            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
235    }
236            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
237    
238    }
239    
240  #     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";  
241    
242  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
243    
# Line 133  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 141  sub as_hex { Line 277  sub as_hex {
277          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
278                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
279                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
280                    $hex =~ s/\s+$//;
281                  push @out, $hex;                  push @out, $hex;
282          }          }
283          return join('  ', @out);          return join(' | ', @out);
284  }  }
285    
286  sub read_bytes {  sub read_bytes {
# Line 155  sub read_bytes { Line 292  sub read_bytes {
292                  $data .= $b;                  $data .= $b;
293          }          }
294          $desc ||= '?';          $desc ||= '?';
295          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
296          return $data;          return $data;
297  }  }
298    
299  my $assert;  our $assert;
300    
301    # my $rest = skip_assert( 3 );
302    sub skip_assert {
303            assert( 0, shift );
304    }
305    
306  sub assert {  sub assert {
307          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
308    
309          warn "# assert ", dump( $assert );          $from ||= 0;
310            $to = length( $assert->{expect} ) if ! defined $to;
311    
312          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
313          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
314          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), "\t[$from-$to]\n" if $e ne $p;          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
315    
316            # return the rest
317            return substr( $assert->{payload}, $to );
318  }  }
319    
320  sub readchunk {  use Digest::CRC;
         my ( $parser ) = @_;  
321    
322    sub crcccitt {
323            my $bytes = shift;
324            my $crc = Digest::CRC->new(
325                    # midified CCITT to xor with 0xffff instead of 0x0000
326                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
327            ) or die $!;
328            $crc->add( $bytes );
329            pack('n', $crc->digest);
330    }
331    
332    # my $checksum = checksum( $bytes );
333    # my $checksum = checksum( $bytes, $original_checksum );
334    sub checksum {
335            my ( $bytes, $checksum ) = @_;
336    
337            my $xor = crcccitt( substr($bytes,1) ); # skip D6
338            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
339    
340            my $len = ord(substr($bytes,2,1));
341            my $len_real = length($bytes) - 1;
342    
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 ) {
349                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
350                    return $bytes . $xor;
351            }
352            return $bytes . $checksum;
353    }
354    
355    our $dispatch;
356    
357    sub readchunk {
358          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
359    
360          # read header of packet          # read header of packet
# Line 181  sub readchunk { Line 362  sub readchunk {
362          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
363          my $len = ord($length);          my $len = ord($length);
364          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
365    
366          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
367          my $payload_len = length($data);          my $payload_len = length($data);
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          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
372    
373          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", 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;
         $assert->{checksum} = $checksum;  
377    
378          $parser->( $len, $payload, $checksum ) 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  }  }
396    
397  sub str2bytes {  sub str2bytes {
398          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
399          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
400          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
401          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
402          my $bytes = eval $str;          $b = "\"$b\"";
403            my $bytes = eval $b;
404          die $@ if $@;          die $@ if $@;
405            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
406          return $bytes;          return $bytes;
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          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
417            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
418    
419            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.2  
changed lines
  Added in v.26
  ViewVC Help
Powered by ViewVC 1.1.26