/[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 19 by dpavlin, Fri Oct 3 15:38:08 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 $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
74  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";  
75  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
76  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
77  $databits=$port->databits($databits);  $databits=$port->databits($databits);
# Line 75  $port->read_char_time(5); Line 89  $port->read_char_time(5);
89  #$port->stty_inpck(1);  #$port->stty_inpck(1);
90  #$port->stty_istrip(1);  #$port->stty_istrip(1);
91    
92  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
      'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
         my ( $len, $payload, $checksum ) = @_;  
         assert( 0, 3 );  
         print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";  
 });  
   
 cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  
 #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778  
93    
94  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
95       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );       'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {
96            print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
97    });
98    
99  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','stats?',
100         'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );
101    
102  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  # start scanning for tags
103    
104  #     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( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
105  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  07   FE  00 00  05     00  C97B', 'no tag', sub {
106    dispatch(
107             'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8
108                    sub {
109                            my $rest = shift || die "no rest?";
110                            my $nr = ord( substr( $rest, 0, 1 ) );
111                            my $tags = substr( $rest, 1 );
112    
113                            my $tl = length( $tags );
114                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
115    
116                            my @tags;
117                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
118                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
119                            print "seen $nr tags: ", join(',', @tags ) , "\n";
120    
121                            # read data from tag
122                            read_tag( $_ ) foreach @tags;
123    
124                    }
125    ) }
126    
127    ) foreach ( 1 .. 100 );
128    
129    my $read_cached;
130    
131    sub read_tag {
132            my ( $tag ) = @_;
133    
134            print "read_tag $tag\n";
135            return if $read_cached->{ $tag }++;
136    
137            cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
138                            "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {
139    dispatch(       "D6 00  1F  02 00   $tag   ", sub { # 03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
140                            my $rest = shift || die "no rest?";
141                            warn "## DATA ", dump( $rest ) if $debug;
142                            my $blocks = ord(substr($rest,0,1));
143                            my @data;
144                            foreach my $nr ( 0 .. $blocks - 1 ) {
145                                    my $block = substr( $rest, 1 + $nr * 6, 6 );
146                                    warn "## block ",as_hex( $block ) if $debug;
147                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
148                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
149                                    my $data  = substr( $block, 2 );
150                                    die "data payload should be 4 bytes" if length($data) != 4;
151                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
152                                    $data[ $ord ] = $data;
153                            }
154                            $read_cached->{ $tag } = join('', @data);
155                            print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";
156                    })
157            });
158    
159            #        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
160    if (0) {
161            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
162    
163            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
164            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
165            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
166    }
167            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
168    
169  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  }
170    
171  #     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";  
172    
173  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
174    
# Line 133  sub writechunk Line 200  sub writechunk
200  {  {
201          my $str=shift;          my $str=shift;
202          my $count = $port->write($str);          my $count = $port->write($str);
203          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
204  }  }
205    
206  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 208  sub as_hex {
208          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
209                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
210                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
211                    $hex =~ s/\s+$//;
212                  push @out, $hex;                  push @out, $hex;
213          }          }
214          return join('  ', @out);          return join(' | ', @out);
215  }  }
216    
217  sub read_bytes {  sub read_bytes {
# Line 155  sub read_bytes { Line 223  sub read_bytes {
223                  $data .= $b;                  $data .= $b;
224          }          }
225          $desc ||= '?';          $desc ||= '?';
226          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
227          return $data;          return $data;
228  }  }
229    
230  my $assert;  our $assert;
231    
232    # my $rest = skip_assert( 3 );
233    sub skip_assert {
234            assert( 0, shift );
235    }
236    
237  sub assert {  sub assert {
238          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
239    
240          warn "# assert ", dump( $assert );          $from ||= 0;
241            $to = length( $assert->{expect} ) if ! defined $to;
242    
243          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
244          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
245          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;
246    
247            # return the rest
248            return substr( $assert->{payload}, $to );
249    }
250    
251    our $dispatch;
252    sub dispatch {
253            my ( $pattern, $coderef ) = @_;
254    
255            $dispatch->{ $pattern } = $coderef;
256    
257            my $patt = substr( str2bytes($pattern), 3 ); # just payload
258            my $l = length($patt);
259            my $p = substr( $assert->{payload}, 0, $l );
260            warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
261    
262            if ( $assert->{payload} eq $assert->{expect} ) {
263                    warn "## no dispatch, payload expected" if $debug;
264            } elsif ( $p eq $patt ) {
265                    # if matched call with rest of payload
266                    $coderef->( substr( $assert->{payload}, $l ) );
267            } else {
268                    warn "## dispatch ignored" if $debug;
269            }
270    }
271    
272    use Digest::CRC;
273    
274    sub crcccitt {
275            my $bytes = shift;
276            my $crc = Digest::CRC->new(
277                    # midified CCITT to xor with 0xffff instead of 0x0000
278                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
279            ) or die $!;
280            $crc->add( $bytes );
281            pack('n', $crc->digest);
282    }
283    
284    # my $checksum = checksum( $bytes );
285    # my $checksum = checksum( $bytes, $original_checksum );
286    sub checksum {
287            my ( $bytes, $checksum ) = @_;
288    
289            my $xor = crcccitt( substr($bytes,1) ); # skip D6
290            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
291    
292            my $len = ord(substr($bytes,2,1));
293            my $len_real = length($bytes) - 1;
294    
295            if ( $len_real != $len ) {
296                    print "length wrong: $len_real != $len\n";
297                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
298            }
299    
300            if ( defined $checksum && $xor ne $checksum ) {
301                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
302                    return $bytes . $xor;
303            }
304            return $bytes . $checksum;
305  }  }
306    
307  sub readchunk {  sub readchunk {
# Line 181  sub readchunk { Line 314  sub readchunk {
314          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
315          my $len = ord($length);          my $len = ord($length);
316          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
317    
318          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
319          my $payload_len = length($data);          my $payload_len = length($data);
320          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
321    
322          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
323          # FIXME check checksum          checksum( $header . $length . $payload, $checksum );
324    
325          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";
326    
327          $assert->{len}      = $len;          $assert->{len}      = $len;
328          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
329    
330          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
331    
332          return $data;          return $data;
333  }  }
334    
335  sub str2bytes {  sub str2bytes {
336          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
337          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
338          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
339          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
340          my $bytes = eval $str;          $b = "\"$b\"";
341            my $bytes = eval $b;
342          die $@ if $@;          die $@ if $@;
343            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
344          return $bytes;          return $bytes;
345  }  }
346    
# Line 214  sub cmd { Line 348  sub cmd {
348          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
349          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
350    
351            # fix checksum if needed
352            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
353    
354          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
355          $assert->{send} = $cmd;          $assert->{send} = $cmd;
356          writechunk( $bytes );          writechunk( $bytes );
Legend:
Removed from v.2  
changed lines
  Added in v.19
  ViewVC Help
Powered by ViewVC 1.1.26