/[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 19 by dpavlin, Fri Oct 3 15:38:08 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  =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 36  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 47  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 74  $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  sub cmd {  # initial hand-shake with device
         my ( $cmd, $desc, $expect ) = @_;  
         $cmd =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum  
         $cmd =~ s/\s+/\\x/g;  
         $cmd = '"\x' . $cmd . '"';  
         my $bytes = eval $cmd;  
         die $@ if $@;  
         warn ">> ", as_hex( $bytes ), "\t$desc\n";  
         writechunk( $bytes );  
         warn "?? $expect\n" if $expect;  
         readchunk();  
 }  
   
 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' );  
   
 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  
   
 cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  
      'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );  
   
 #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  
   
 cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  
93    
94  #     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( 'D5 00  05   04 00 11                 8C66', 'hw version?',
95  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";       '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    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    # start scanning for tags
103    
104    cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
105         '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 140  print "Port closed\n"; Line 199  print "Port closed\n";
199  sub writechunk  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 {
207          my @out;          my @out;
208          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
209                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
210                  $hex =~ s/(..)/$1 /g;                  $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 164  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    our $assert;
231    
232    # my $rest = skip_assert( 3 );
233    sub skip_assert {
234            assert( 0, shift );
235    }
236    
237    sub assert {
238            my ( $from, $to ) = @_;
239    
240            $from ||= 0;
241            $to = length( $assert->{expect} ) if ! defined $to;
242    
243            my $p = substr( $assert->{payload}, $from, $to );
244            my $e = substr( $assert->{expect},  $from, $to );
245            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 {
308            my ( $parser ) = @_;
309    
310            sleep 1;        # FIXME remove
311    
312          # read header of packet          # read header of packet
313          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
314          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
315            my $len = ord($length);
316          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
317    
318          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
319            my $payload_len = length($data);
320            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
321    
322            my $checksum = substr( $data, -2, 2 );
323            checksum( $header . $length . $payload, $checksum );
324    
325            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
326    
327            $assert->{len}      = $len;
328            $assert->{payload}  = $payload;
329    
330          sleep 1;          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
331    
332            return $data;
333    }
334    
335    sub str2bytes {
336            my $str = shift || confess "no str?";
337            my $b = $str;
338            $b =~ s/\s+//g;
339            $b =~ s/(..)/\\x$1/g;
340            $b = "\"$b\"";
341            my $bytes = eval $b;
342            die $@ if $@;
343            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
344            return $bytes;
345    }
346    
347    sub cmd {
348            my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
349            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";
355            $assert->{send} = $cmd;
356            writechunk( $bytes );
357    
358            if ( $expect ) {
359                    warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
360                    $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
361                    readchunk( $coderef );
362            }
363  }  }
364    
Legend:
Removed from v.1  
changed lines
  Added in v.19
  ViewVC Help
Powered by ViewVC 1.1.26