/[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 16 by dpavlin, Thu Oct 2 22:53:57 2008 UTC
# Line 7  use warnings; Line 7  use warnings;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9    
10    my $debug = 0;
11    
12  my $response = {  my $response = {
13          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
14          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 37  L<Device::SerialPort(3)> Line 39  L<Device::SerialPort(3)>
39    
40  L<perl(1)>  L<perl(1)>
41    
42    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
43    
44  =head1 AUTHOR  =head1 AUTHOR
45    
46  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
# Line 75  $port->read_char_time(5); Line 79  $port->read_char_time(5);
79  #$port->stty_inpck(1);  #$port->stty_inpck(1);
80  #$port->stty_istrip(1);  #$port->stty_istrip(1);
81    
82  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
83       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
84          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
85          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {
86          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
87  });  });
88    
89  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','stats?',
90  #     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','FIXME: unimplemented', sub { assert() }  );
91    
92    # start scanning for tags
93    
94    cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
95         'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {
96    dispatch(
97             'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8
98                    sub {
99                            my $rest = shift || die "no rest?";
100                            my $nr = ord( substr( $rest, 0, 1 ) );
101                            my $tags = substr( $rest, 1 );
102    
103                            my $tl = length( $tags );
104                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
105    
106                            my @tags;
107                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
108                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
109                            print "seen $nr tags: ", join(',', @tags ) , "\n";
110    
111  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",                          # XXX read first tag
112       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );                          read_tag( @tags );
113    
114  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen                  }
115    ) }
116    
117  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  ) foreach ( 1 .. 100 );
118    
119  #     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  my $read_cached;
 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";  
120    
121  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  sub read_tag {
122            my ( $tag ) = @_;
123    
124  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            print "read_tag $tag\n";
125  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          return if $read_cached->{ $tag }++;
126  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
127                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );
128  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";  
129            #        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
130            warn "?? D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
131    if (0) {
132            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
133    
134            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
135            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
136            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
137    }
138            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
139    
140    }
141    
142  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
143    
# Line 133  sub writechunk Line 169  sub writechunk
169  {  {
170          my $str=shift;          my $str=shift;
171          my $count = $port->write($str);          my $count = $port->write($str);
172          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n";
173  }  }
174    
175  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 177  sub as_hex {
177          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
178                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
179                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
180                    $hex =~ s/\s+$//;
181                  push @out, $hex;                  push @out, $hex;
182          }          }
183          return join('  ', @out);          return join(' | ', @out);
184  }  }
185    
186  sub read_bytes {  sub read_bytes {
# Line 155  sub read_bytes { Line 192  sub read_bytes {
192                  $data .= $b;                  $data .= $b;
193          }          }
194          $desc ||= '?';          $desc ||= '?';
195          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
196          return $data;          return $data;
197  }  }
198    
199  my $assert;  our $assert;
200    
201    # my $rest = skip_assert( 3 );
202    sub skip_assert {
203            assert( 0, shift );
204    }
205    
206  sub assert {  sub assert {
207          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
208    
209          warn "# assert ", dump( $assert );          $from ||= 0;
210            $to = length( $assert->{expect} ) if ! defined $to;
211    
212          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
213          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
214          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;
215    
216            # return the rest
217            return substr( $assert->{payload}, $to );
218    }
219    
220    our $dispatch;
221    sub dispatch {
222            my ( $pattern, $coderef ) = @_;
223            my $patt = substr( str2bytes($pattern), 3 ); # just payload
224            my $l = length($patt);
225            my $p = substr( $assert->{payload}, 0, $l );
226            warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
227    
228            if ( $assert->{payload} eq $assert->{expect} ) {
229                    warn "## no dispatch, payload expected" if $debug;
230            } elsif ( $p eq $patt ) {
231                    # if matched call with rest of payload
232                    $coderef->( substr( $assert->{payload}, $l ) );
233            } else {
234                    warn "## dispatch ignored" if $debug;
235            }
236    }
237    
238    use Digest::CRC;
239    
240    sub crcccitt {
241            my $bytes = shift;
242            my $crc = Digest::CRC->new(
243                    # midified CCITT to xor with 0xffff instead of 0x0000
244                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
245            ) or die $!;
246            $crc->add( $bytes );
247            pack('n', $crc->digest);
248    }
249    
250    # my $checksum = checksum( $bytes );
251    # my $checksum = checksum( $bytes, $original_checksum );
252    sub checksum {
253            my ( $bytes, $checksum ) = @_;
254    
255            my $xor = crcccitt( substr($bytes,1) ); # skip D6
256            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
257    
258            my $len = ord(substr($bytes,2,1));
259            my $len_real = length($bytes);
260            print "length wrong: $len_real != $len\n" if $len_real != $len;
261    
262            if ( defined $checksum && $xor ne $checksum ) {
263                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
264                    return $bytes . $xor;
265            }
266            return $bytes . $checksum;
267  }  }
268    
269  sub readchunk {  sub readchunk {
# Line 181  sub readchunk { Line 276  sub readchunk {
276          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
277          my $len = ord($length);          my $len = ord($length);
278          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
279    
280          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
281          my $payload_len = length($data);          my $payload_len = length($data);
282          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
283    
284          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
285          # FIXME check checksum          checksum( $header . $length . $payload, $checksum );
286    
287          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";
288    
289          $assert->{len}      = $len;          $assert->{len}      = $len;
290          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
291    
292          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
293    
294          return $data;          return $data;
295  }  }
296    
297  sub str2bytes {  sub str2bytes {
298          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
299          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
300          $str =~ s/\s+/\\x/g;          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum
301          $str = '"\x' . $str . '"';          $b =~ s/\s+$//;
302          my $bytes = eval $str;          $b =~ s/\s+/\\x/g;
303            $b = '"\x' . $b . '"';
304            my $bytes = eval $b;
305          die $@ if $@;          die $@ if $@;
306            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
307          return $bytes;          return $bytes;
308  }  }
309    
# Line 214  sub cmd { Line 311  sub cmd {
311          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
312          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
313    
314            # fix checksum if needed
315            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
316    
317          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
318          $assert->{send} = $cmd;          $assert->{send} = $cmd;
319          writechunk( $bytes );          writechunk( $bytes );
Legend:
Removed from v.2  
changed lines
  Added in v.16
  ViewVC Help
Powered by ViewVC 1.1.26