/[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 3 by dpavlin, Sun Sep 28 14:06:59 2008 UTC revision 18 by dpavlin, Fri Oct 3 12:31:58 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
      '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  
83    
84  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
85       '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 {
86            print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
87  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  });
88    
89  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  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','FIXME: unimplemented', sub { assert() }  );
91    
92  #     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  # start scanning for tags
 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";  
93    
94  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  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                            # XXX read first tag
112                            read_tag( @tags );
113    
114                    }
115    ) }
116    
117    ) foreach ( 1 .. 100 );
118    
119    my $read_cached;
120    
121    sub read_tag {
122            my ( $tag ) = @_;
123    
124            print "read_tag $tag\n";
125            return if $read_cached->{ $tag }++;
126    
127            cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
128                            "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {
129    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";
130                            my $rest = shift || die "no rest?";
131                            warn "## DATA ", dump( $rest ) if $debug;
132                            my $blocks = ord(substr($rest,0,1));
133                            my @data;
134                            foreach my $nr ( 0 .. $blocks - 1 ) {
135                                    my $block = substr( $rest, 1 + $nr * 6, 6 );
136                                    warn "## block ",as_hex( $block ) if $debug;
137                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
138                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
139                                    my $data  = substr( $block, 2 );
140                                    die "data payload should be 4 bytes" if length($data) != 4;
141                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
142                                    $data[ $ord ] = $data;
143                            }
144                            $read_cached->{ $tag } = join('', @data);
145                            print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";
146                    })
147            });
148    
149            #        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
150    if (0) {
151            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
152    
153            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
154            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
155            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
156    }
157            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
158    
159  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00    }
 #                                                                      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";  
160    
161  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
162    
# Line 133  sub writechunk Line 188  sub writechunk
188  {  {
189          my $str=shift;          my $str=shift;
190          my $count = $port->write($str);          my $count = $port->write($str);
191          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]" if $debug;
192  }  }
193    
194  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 196  sub as_hex {
196          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
197                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
198                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
199                    $hex =~ s/\s+$//;
200                  push @out, $hex;                  push @out, $hex;
201          }          }
202          return join('  ', @out);          return join(' | ', @out);
203  }  }
204    
205  sub read_bytes {  sub read_bytes {
# Line 155  sub read_bytes { Line 211  sub read_bytes {
211                  $data .= $b;                  $data .= $b;
212          }          }
213          $desc ||= '?';          $desc ||= '?';
214          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
215          return $data;          return $data;
216  }  }
217    
218  my $assert;  our $assert;
219    
220    # my $rest = skip_assert( 3 );
221    sub skip_assert {
222            assert( 0, shift );
223    }
224    
225  sub assert {  sub assert {
226          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
227    
228            $from ||= 0;
229            $to = length( $assert->{expect} ) if ! defined $to;
230    
231          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
232          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
233          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
234    
235            # return the rest
236            return substr( $assert->{payload}, $to );
237    }
238    
239    our $dispatch;
240    sub dispatch {
241            my ( $pattern, $coderef ) = @_;
242            my $patt = substr( str2bytes($pattern), 3 ); # just payload
243            my $l = length($patt);
244            my $p = substr( $assert->{payload}, 0, $l );
245            warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
246    
247            if ( $assert->{payload} eq $assert->{expect} ) {
248                    warn "## no dispatch, payload expected" if $debug;
249            } elsif ( $p eq $patt ) {
250                    # if matched call with rest of payload
251                    $coderef->( substr( $assert->{payload}, $l ) );
252            } else {
253                    warn "## dispatch ignored" if $debug;
254            }
255    }
256    
257    use Digest::CRC;
258    
259    sub crcccitt {
260            my $bytes = shift;
261            my $crc = Digest::CRC->new(
262                    # midified CCITT to xor with 0xffff instead of 0x0000
263                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
264            ) or die $!;
265            $crc->add( $bytes );
266            pack('n', $crc->digest);
267    }
268    
269    # my $checksum = checksum( $bytes );
270    # my $checksum = checksum( $bytes, $original_checksum );
271    sub checksum {
272            my ( $bytes, $checksum ) = @_;
273    
274            my $xor = crcccitt( substr($bytes,1) ); # skip D6
275            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
276    
277            my $len = ord(substr($bytes,2,1));
278            my $len_real = length($bytes) - 1;
279    
280            if ( $len_real != $len ) {
281                    print "length wrong: $len_real != $len\n";
282                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
283            }
284    
285            if ( defined $checksum && $xor ne $checksum ) {
286                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
287                    return $bytes . $xor;
288            }
289            return $bytes . $checksum;
290  }  }
291    
292  sub readchunk {  sub readchunk {
# Line 179  sub readchunk { Line 299  sub readchunk {
299          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
300          my $len = ord($length);          my $len = ord($length);
301          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
302    
303          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
304          my $payload_len = length($data);          my $payload_len = length($data);
305          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
306    
307          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
308          # FIXME check checksum          checksum( $header . $length . $payload, $checksum );
309    
310          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";
311    
312          $assert->{len}      = $len;          $assert->{len}      = $len;
313          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
314    
315          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
316    
317          return $data;          return $data;
318  }  }
319    
320  sub str2bytes {  sub str2bytes {
321          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
322          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
323          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
324          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
325          my $bytes = eval $str;          $b = "\"$b\"";
326            my $bytes = eval $b;
327          die $@ if $@;          die $@ if $@;
328            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
329          return $bytes;          return $bytes;
330  }  }
331    
# Line 212  sub cmd { Line 333  sub cmd {
333          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
334          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
335    
336            # fix checksum if needed
337            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
338    
339          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
340          $assert->{send} = $cmd;          $assert->{send} = $cmd;
341          writechunk( $bytes );          writechunk( $bytes );
Legend:
Removed from v.3  
changed lines
  Added in v.18
  ViewVC Help
Powered by ViewVC 1.1.26