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