/[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 27 by dpavlin, Mon Apr 6 11:21:15 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    
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                    warn "# open connection to $meteor_server";
22                    $meteor_fh = IO::Socket::INET->new(
23                                    PeerAddr => $meteor_server,
24                                    Timeout => 1,
25                    ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
26                    $meteor_fh = 0; # don't try again
27            }
28    
29            warn ">> meteor ",dump( @a );
30            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
31    }
32    
33    my $debug = 0;
34    
35    my $device    = "/dev/ttyUSB0";
36    my $baudrate  = "19200";
37    my $databits  = "8";
38    my $parity        = "none";
39    my $stopbits  = "1";
40    my $handshake = "none";
41    
42  my $response = {  my $response = {
43          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 18  my $response = { Line 51  my $response = {
51          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
52  };  };
53    
54    GetOptions(
55            'd|debug+'    => \$debug,
56            'device=s'    => \$device,
57            'baudrate=i'  => \$baudrate,
58            'databits=i'  => \$databits,
59            'parity=s'    => \$parity,
60            'stopbits=i'  => \$stopbits,
61            'handshake=s' => \$handshake,
62            'meteor=s'    => \$meteor_server,
63    ) or die $!;
64    
65    my $verbose = $debug > 0 ? $debug-- : 0;
66    
67  =head1 NAME  =head1 NAME
68    
69  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
70    
71  =head1 SYNOPSIS  =head1 SYNOPSIS
72    
73  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 36  L<Device::SerialPort(3)> Line 82  L<Device::SerialPort(3)>
82    
83  L<perl(1)>  L<perl(1)>
84    
85    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
86    
87  =head1 AUTHOR  =head1 AUTHOR
88    
89  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 95  it under the same terms ans Perl itself.
95    
96  =cut  =cut
97    
98  # your serial port.  my $tags_data;
99  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
100    
101  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
102    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
103  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
104  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
105  $databits=$port->databits($databits);  $databits=$port->databits($databits);
106  $parity=$port->parity($parity);  $parity=$port->parity($parity);
107  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
108    
109  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
110    
111  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
112  $port->lookclear();  $port->lookclear();
# Line 74  $port->read_char_time(5); Line 117  $port->read_char_time(5);
117  #$port->stty_inpck(1);  #$port->stty_inpck(1);
118  #$port->stty_istrip(1);  #$port->stty_istrip(1);
119    
120  sub cmd {  # initial hand-shake with device
121          my ( $cmd, $desc, $expect ) = @_;  
122          $cmd =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
123          $cmd =~ s/\s+/\\x/g;       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
124          $cmd = '"\x' . $cmd . '"';          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
125          my $bytes = eval $cmd;          print "hardware version $hw_ver\n";
126          die $@ if $@;          meteor( 'info', "Found reader hardware $hw_ver" );
127          warn ">> ", as_hex( $bytes ), "\t$desc\n";  });
128          writechunk( $bytes );  
129          warn "?? $expect\n" if $expect;  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
130          readchunk();       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
131  }  
132    # start scanning for tags
133    
134    cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
135             'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
136                    my $rest = shift || die "no rest?";
137                    my $nr = ord( substr( $rest, 0, 1 ) );
138    
139                    if ( ! $nr ) {
140                            print "no tags in range\n";
141                            update_visible_tags();
142                            meteor( 'info-none-in-range' );
143                            $tags_data = {};
144                    } else {
145    
146                            my $tags = substr( $rest, 1 );
147    
148                            my $tl = length( $tags );
149                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
150    
151                            my @tags;
152                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
153                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
154                            print "$nr tags in range: ", join(',', @tags ) , "\n";
155    
156  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',                          meteor( 'info-in-range', join(' ',@tags));
      'D5 00  09  04   00   11   0A 05 00 02   7250 -- hw 10.5.0.2' );  
157    
158  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );                          update_visible_tags( @tags );
159  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778                  }
160            }
161    ) while(1);
162    #) foreach ( 1 .. 100 );
163    
164    
165    
166    sub update_visible_tags {
167            my @tags = @_;
168    
169            my $last_visible_tags = $visible_tags;
170            $visible_tags = {};
171    
172            foreach my $tag ( @tags ) {
173                    if ( ! defined $last_visible_tags->{$tag} ) {
174                            if ( defined $tags_data->{$tag} ) {
175    #                               meteor( 'in-range', $tag );
176                            } else {
177                                    meteor( 'read', $tag );
178                                    read_tag( $tag );
179                            }
180                            $visible_tags->{$tag}++;
181                    } else {
182                            warn "## using cached data for $tag" if $debug;
183                    }
184                    delete $last_visible_tags->{$tag}; # leave just missing tags
185            }
186    
187            foreach my $tag ( keys %$last_visible_tags ) {
188                    my $data = delete $tags_data->{$tag};
189                    print "removed tag $tag with data ",dump( $data ),"\n";
190                    meteor( 'removed', $tag );
191            }
192    
193            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
194    }
195    
 cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  
      'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );  
196    
197  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  sub read_tag {
198            my ( $tag ) = @_;
199    
200  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          confess "no tag?" unless $tag;
201    
202  #     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";
203  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";  
204            cmd(
205                    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
206                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
207                            print "FIXME: tag $tag ready?\n";
208                    },
209                    "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";
210                            my $rest = shift || die "no rest?";
211                            warn "## DATA ", dump( $rest ) if $debug;
212                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
213                            my $blocks = ord(substr($rest,8,1));
214                            $rest = substr($rest,9); # leave just data blocks
215                            my @data;
216                            foreach my $nr ( 0 .. $blocks - 1 ) {
217                                    my $block = substr( $rest, $nr * 6, 6 );
218                                    warn "## block ",as_hex( $block ) if $debug;
219                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
220                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
221                                    my $data  = substr( $block, 2 );
222                                    die "data payload should be 4 bytes" if length($data) != 4;
223                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
224                                    $data[ $ord ] = $data;
225                            }
226                            $tags_data->{ $tag } = join('', @data);
227                            print "DATA $tag ",dump( $tags_data ), "\n";
228                    }
229            );
230    
231            #        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
232    if (0) {
233            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
234    
235            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
236            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
237            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
238    }
239            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
240    
241  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  }
242    
243  #     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";  
244    
245  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
246    
# Line 140  print "Port closed\n"; Line 271  print "Port closed\n";
271  sub writechunk  sub writechunk
272  {  {
273          my $str=shift;          my $str=shift;
   
274          my $count = $port->write($str);          my $count = $port->write($str);
275          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
276  }  }
277    
278  sub as_hex {  sub as_hex {
279          my @out;          my @out;
280          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
281                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
282                  $hex =~ s/(..)/$1 /g;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
283                    $hex =~ s/\s+$//;
284                  push @out, $hex;                  push @out, $hex;
285          }          }
286          return join('  ', @out);          return join(' | ', @out);
287  }  }
288    
289  sub read_bytes {  sub read_bytes {
# Line 164  sub read_bytes { Line 295  sub read_bytes {
295                  $data .= $b;                  $data .= $b;
296          }          }
297          $desc ||= '?';          $desc ||= '?';
298          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
299          return $data;          return $data;
300  }  }
301    
302    our $assert;
303    
304    # my $rest = skip_assert( 3 );
305    sub skip_assert {
306            assert( 0, shift );
307    }
308    
309    sub assert {
310            my ( $from, $to ) = @_;
311    
312            $from ||= 0;
313            $to = length( $assert->{expect} ) if ! defined $to;
314    
315            my $p = substr( $assert->{payload}, $from, $to );
316            my $e = substr( $assert->{expect},  $from, $to );
317            warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
318    
319            # return the rest
320            return substr( $assert->{payload}, $to );
321    }
322    
323    use Digest::CRC;
324    
325    sub crcccitt {
326            my $bytes = shift;
327            my $crc = Digest::CRC->new(
328                    # midified CCITT to xor with 0xffff instead of 0x0000
329                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
330            ) or die $!;
331            $crc->add( $bytes );
332            pack('n', $crc->digest);
333    }
334    
335    # my $checksum = checksum( $bytes );
336    # my $checksum = checksum( $bytes, $original_checksum );
337    sub checksum {
338            my ( $bytes, $checksum ) = @_;
339    
340            my $xor = crcccitt( substr($bytes,1) ); # skip D6
341            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
342    
343            my $len = ord(substr($bytes,2,1));
344            my $len_real = length($bytes) - 1;
345    
346            if ( $len_real != $len ) {
347                    print "length wrong: $len_real != $len\n";
348                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
349            }
350    
351            if ( defined $checksum && $xor ne $checksum ) {
352                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
353                    return $bytes . $xor;
354            }
355            return $bytes . $checksum;
356    }
357    
358    our $dispatch;
359    
360  sub readchunk {  sub readchunk {
361            sleep 1;        # FIXME remove
362    
363          # read header of packet          # read header of packet
364          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
365          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
366            my $len = ord($length);
367          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
368    
369          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
370            my $payload_len = length($data);
371            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
372    
373            my $checksum = substr( $data, -2, 2 );
374            checksum( $header . $length . $payload , $checksum );
375    
376            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
377    
378            $assert->{len}      = $len;
379            $assert->{payload}  = $payload;
380    
381            my $full = $header . $length . $data; # full
382            # find longest match for incomming data
383            my ($to) = grep {
384                    my $match = substr($payload,0,length($_));
385                    m/^\Q$match\E/
386            } sort { length($a) <=> length($b) } keys %$dispatch;
387            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
388    
389            if ( defined $to ) {
390                    my $rest = substr( $payload, length($to) );
391                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
392                    $dispatch->{ $to }->( $rest );
393            } else {
394                    print "NO DISPATCH for ",dump( $full ),"\n";
395            }
396    
397            return $data;
398    }
399    
400    sub str2bytes {
401            my $str = shift || confess "no str?";
402            my $b = $str;
403            $b =~ s/\s+//g;
404            $b =~ s/(..)/\\x$1/g;
405            $b = "\"$b\"";
406            my $bytes = eval $b;
407            die $@ if $@;
408            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
409            return $bytes;
410    }
411    
412    sub cmd {
413            my $cmd = shift || confess "no cmd?";
414            my $cmd_desc = shift || confess "no description?";
415            my @expect = @_;
416    
417            my $bytes = str2bytes( $cmd );
418    
419            # fix checksum if needed
420            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
421    
422            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
423            $assert->{send} = $cmd;
424            writechunk( $bytes );
425    
426            while ( @expect ) {
427                    my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
428                    my $coderef = shift @expect || confess "no coderef?";
429                    confess "not coderef" unless ref $coderef eq 'CODE';
430    
431                    next if defined $dispatch->{ $pattern };
432    
433                    $dispatch->{ substr($pattern,3) } = $coderef;
434                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
435            }
436    
437          sleep 1;          readchunk;
438  }  }
439    
Legend:
Removed from v.1  
changed lines
  Added in v.27
  ViewVC Help
Powered by ViewVC 1.1.26