/[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 3 by dpavlin, Sun Sep 28 14:06:59 2008 UTC revision 21 by dpavlin, Fri Oct 3 21:47:24 2008 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    my $debug = 0;
12    
13    my $device    = "/dev/ttyUSB0";
14    my $baudrate  = "19200";
15    my $databits  = "8";
16    my $parity        = "none";
17    my $stopbits  = "1";
18    my $handshake = "none";
19    
20  my $response = {  my $response = {
21          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 19  my $response = { Line 29  my $response = {
29          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
30  };  };
31    
32    GetOptions(
33            'd|debug+'      => \$debug,
34            'device=s'    => \$device,
35            'baudrate=i'  => \$baudrate,
36            'databits=i'  => \$databits,
37            'parity=s'    => \$parity,
38            'stopbits=i'  => \$stopbits,
39            'handshake=s' => \$handshake,
40    ) or die $!;
41    
42  =head1 NAME  =head1 NAME
43    
44  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
45    
46  =head1 SYNOPSIS  =head1 SYNOPSIS
47    
48  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
49    
50  =head1 DESCRIPTION  =head1 DESCRIPTION
51    
# Line 37  L<Device::SerialPort(3)> Line 57  L<Device::SerialPort(3)>
57    
58  L<perl(1)>  L<perl(1)>
59    
60    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
61    
62  =head1 AUTHOR  =head1 AUTHOR
63    
64  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 70  it under the same terms ans Perl itself.
70    
71  =cut  =cut
72    
73  # your serial port.  my $tags_data;
74  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
75    
76  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
77    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
78  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
79  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
80  $databits=$port->databits($databits);  $databits=$port->databits($databits);
# Line 75  $port->read_char_time(5); Line 92  $port->read_char_time(5);
92  #$port->stty_inpck(1);  #$port->stty_inpck(1);
93  #$port->stty_istrip(1);  #$port->stty_istrip(1);
94    
95  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
96       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
97          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
98          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
99          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
100  });  });
101    
102  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?',
103  #     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() }  );
104    
105    # start scanning for tags
106    
107  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
108       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );       'D6 00  07   FE  00 00  05     00  C97B', sub {
109                    assert();
110                    print "no tag in range\n";
111    
112            },
113             'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
114                    my $rest = shift || die "no rest?";
115                    my $nr = ord( substr( $rest, 0, 1 ) );
116    
117                    if ( ! $nr ) {
118                            print "no tags in range\n";
119                    } else {
120    
121                            my $tags = substr( $rest, 1 );
122    
123                            my $tl = length( $tags );
124                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
125    
126                            my @tags;
127                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
128                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
129                            print "seen $nr tags: ", join(',', @tags ) , "\n";
130    
131                            my $removed_tags = $visible_tags;
132                            $visible_tags = {};
133    
134                            foreach my $tag ( @tags ) {
135                                    next if $visible_tags->{$tag}++;
136                                    read_tag( $tag );
137                                    if ( delete $removed_tags->{$tag} ) {
138                                            print "removed tag $tag\n";
139                                    }
140                            }
141    
142                    }
143            }
144    ) foreach ( 1 .. 100 );
145    
146  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  sub read_tag {
147            my ( $tag ) = @_;
148    
149  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          print "read_tag $tag\n";
150    
151  #     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          cmd(
152  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";                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
153                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
154                            print "FIXME: tag $tag ready?\n";
155                    },
156                    "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";
157                            my $rest = shift || die "no rest?";
158                            warn "## DATA ", dump( $rest ) if $debug;
159                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
160                            my $blocks = ord(substr($rest,8,1));
161                            $rest = substr($rest,9); # leave just data blocks
162                            my @data;
163                            foreach my $nr ( 0 .. $blocks - 1 ) {
164                                    my $block = substr( $rest, $nr * 6, 6 );
165                                    warn "## block ",as_hex( $block ) if $debug;
166                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
167                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
168                                    my $data  = substr( $block, 2 );
169                                    die "data payload should be 4 bytes" if length($data) != 4;
170                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
171                                    $data[ $ord ] = $data;
172                            }
173                            $tags_data->{ $tag } = join('', @data);
174                            print "DATA $tag ",dump( $tags_data ), "\n";
175                    }
176            );
177    
178            #        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
179    if (0) {
180            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
181    
182            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
183            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
184            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
185    }
186            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
187    
188  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  }
189    
190  #     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";  
191    
192  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
193    
# Line 133  sub writechunk Line 219  sub writechunk
219  {  {
220          my $str=shift;          my $str=shift;
221          my $count = $port->write($str);          my $count = $port->write($str);
222          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
223  }  }
224    
225  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 227  sub as_hex {
227          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
228                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
229                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
230                    $hex =~ s/\s+$//;
231                  push @out, $hex;                  push @out, $hex;
232          }          }
233          return join('  ', @out);          return join(' | ', @out);
234  }  }
235    
236  sub read_bytes {  sub read_bytes {
# Line 155  sub read_bytes { Line 242  sub read_bytes {
242                  $data .= $b;                  $data .= $b;
243          }          }
244          $desc ||= '?';          $desc ||= '?';
245          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
246          return $data;          return $data;
247  }  }
248    
249  my $assert;  our $assert;
250    
251    # my $rest = skip_assert( 3 );
252    sub skip_assert {
253            assert( 0, shift );
254    }
255    
256  sub assert {  sub assert {
257          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
258    
259            $from ||= 0;
260            $to = length( $assert->{expect} ) if ! defined $to;
261    
262          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
263          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
264          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
265    
266            # return the rest
267            return substr( $assert->{payload}, $to );
268  }  }
269    
270  sub readchunk {  use Digest::CRC;
         my ( $parser ) = @_;  
271    
272    sub crcccitt {
273            my $bytes = shift;
274            my $crc = Digest::CRC->new(
275                    # midified CCITT to xor with 0xffff instead of 0x0000
276                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
277            ) or die $!;
278            $crc->add( $bytes );
279            pack('n', $crc->digest);
280    }
281    
282    # my $checksum = checksum( $bytes );
283    # my $checksum = checksum( $bytes, $original_checksum );
284    sub checksum {
285            my ( $bytes, $checksum ) = @_;
286    
287            my $xor = crcccitt( substr($bytes,1) ); # skip D6
288            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
289    
290            my $len = ord(substr($bytes,2,1));
291            my $len_real = length($bytes) - 1;
292    
293            if ( $len_real != $len ) {
294                    print "length wrong: $len_real != $len\n";
295                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
296            }
297    
298            if ( defined $checksum && $xor ne $checksum ) {
299                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
300                    return $bytes . $xor;
301            }
302            return $bytes . $checksum;
303    }
304    
305    our $dispatch;
306    
307    sub readchunk {
308          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
309    
310          # read header of packet          # read header of packet
# Line 179  sub readchunk { Line 312  sub readchunk {
312          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
313          my $len = ord($length);          my $len = ord($length);
314          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
315    
316          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
317          my $payload_len = length($data);          my $payload_len = length($data);
318          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
319    
320          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
321          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
322    
323          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";
324    
325          $assert->{len}      = $len;          $assert->{len}      = $len;
326          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
327    
328          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
329            # find longest match for incomming data
330            my ($to) = grep {
331                    my $match = substr($payload,0,length($_));
332                    m/^\Q$match\E/
333            } sort { length($a) <=> length($b) } keys %$dispatch;
334            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
335    
336            if ( defined $to ) {
337                    my $rest = substr( $payload, length($to) );
338                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
339                    $dispatch->{ $to }->( $rest );
340            } else {
341                    print "NO DISPATCH for ",dump( $full ),"\n";
342            }
343    
344          return $data;          return $data;
345  }  }
346    
347  sub str2bytes {  sub str2bytes {
348          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
349          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
350          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
351          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
352          my $bytes = eval $str;          $b = "\"$b\"";
353            my $bytes = eval $b;
354          die $@ if $@;          die $@ if $@;
355            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
356          return $bytes;          return $bytes;
357  }  }
358    
359  sub cmd {  sub cmd {
360          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
361            my $cmd_desc = shift || confess "no description?";
362            my @expect = @_;
363    
364          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
365    
366            # fix checksum if needed
367            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
368    
369          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
370          $assert->{send} = $cmd;          $assert->{send} = $cmd;
371          writechunk( $bytes );          writechunk( $bytes );
372    
373          if ( $expect ) {          while ( @expect ) {
374                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
375                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
376                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
377    
378                    next if defined $dispatch->{ $pattern };
379    
380                    $dispatch->{ substr($pattern,3) } = $coderef;
381                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
382          }          }
383    
384            readchunk;
385  }  }
386    

Legend:
Removed from v.3  
changed lines
  Added in v.21

  ViewVC Help
Powered by ViewVC 1.1.26