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