/[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 10 by dpavlin, Sun Sep 28 22:15:29 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;  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?',
22          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  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 39  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 50  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 102  dispatch( Line 114  dispatch(
114                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
115    
116                          my @tags;                          my @tags;
117                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
118                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
119                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          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 );  ) foreach ( 1 .. 100 );
128    
129  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  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  #     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  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
138  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  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 153  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 204  sub assert { Line 251  sub assert {
251  our $dispatch;  our $dispatch;
252  sub dispatch {  sub dispatch {
253          my ( $pattern, $coderef ) = @_;          my ( $pattern, $coderef ) = @_;
254    
255            $dispatch->{ $pattern } = $coderef;
256    
257          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $patt = substr( str2bytes($pattern), 3 ); # just payload
258          my $l = length($patt);          my $l = length($patt);
259          my $p = substr( $assert->{payload}, 0, $l );          my $p = substr( $assert->{payload}, 0, $l );
# Line 219  sub dispatch { Line 269  sub dispatch {
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 );  # my $checksum = checksum( $bytes );
285  # my $checksum = checksum( $bytes, $original_checksum );  # my $checksum = checksum( $bytes, $original_checksum );
286  sub checksum {  sub checksum {
287          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
288    
289          my $xor = $checksum; # FIXME          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 ) {          if ( defined $checksum && $xor ne $checksum ) {
301                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  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 262  sub readchunk { Line 335  sub readchunk {
335  sub str2bytes {  sub str2bytes {
336          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
337          my $b = $str;          my $b = $str;
338          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
339          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
340          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
341          my $bytes = eval $b;          my $bytes = eval $b;
342          die $@ if $@;          die $@ if $@;
343          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 276  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.10  
changed lines
  Added in v.19
  ViewVC Help
Powered by ViewVC 1.1.26