/[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 16 by dpavlin, Thu Oct 2 22:53:57 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    
10    my $debug = 0;
11    
12  my $response = {  my $response = {
13          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 36  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 74  $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  sub cmd {  # initial hand-shake with device
83          my ( $cmd, $desc, $expect ) = @_;  
84          $cmd =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
85          $cmd =~ s/\s+/\\x/g;       'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {
86          $cmd = '"\x' . $cmd . '"';          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
87          my $bytes = eval $cmd;  });
88          die $@ if $@;  
89          warn ">> ", as_hex( $bytes ), "\t$desc\n";  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','stats?',
90          writechunk( $bytes );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );
91          warn "?? $expect\n" if $expect;  
92          readchunk();  # 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                            # XXX read first tag
112                            read_tag( @tags );
113    
114  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',                  }
115       'D5 00  09  04   00   11   0A 05 00 02   7250 -- hw 10.5.0.2' );  ) }
116    
117  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  ) foreach ( 1 .. 100 );
 #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778  
118    
119  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  my $read_cached;
      'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );  
120    
121  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen  sub read_tag {
122            my ( $tag ) = @_;
123    
124  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          print "read_tag $tag\n";
125            return if $read_cached->{ $tag }++;
126    
127  #     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 offset: 0 blocks: 3' );
 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";  
128    
129  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          #        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   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
135  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
136  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
137                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";  }
138  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";          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 140  print "Port closed\n"; Line 168  print "Port closed\n";
168  sub writechunk  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 {
176          my @out;          my @out;
177          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
178                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
179                  $hex =~ s/(..)/$1 /g;                  $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 164  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    our $assert;
200    
201    # my $rest = skip_assert( 3 );
202    sub skip_assert {
203            assert( 0, shift );
204    }
205    
206    sub assert {
207            my ( $from, $to ) = @_;
208    
209            $from ||= 0;
210            $to = length( $assert->{expect} ) if ! defined $to;
211    
212            my $p = substr( $assert->{payload}, $from, $to );
213            my $e = substr( $assert->{expect},  $from, $to );
214            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 {
270            my ( $parser ) = @_;
271    
272            sleep 1;        # FIXME remove
273    
274          # read header of packet          # read header of packet
275          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
276          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
277            my $len = ord($length);
278          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
279    
280          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
281            my $payload_len = length($data);
282            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
283    
284            my $checksum = substr( $data, -2, 2 );
285            checksum( $header . $length . $payload, $checksum );
286    
287            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
288    
289            $assert->{len}      = $len;
290            $assert->{payload}  = $payload;
291    
292            $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
293    
294          sleep 1;          return $data;
295    }
296    
297    sub str2bytes {
298            my $str = shift || confess "no str?";
299            my $b = $str;
300            $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum
301            $b =~ s/\s+$//;
302            $b =~ s/\s+/\\x/g;
303            $b = '"\x' . $b . '"';
304            my $bytes = eval $b;
305            die $@ if $@;
306            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
307            return $bytes;
308    }
309    
310    sub cmd {
311            my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
312            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";
318            $assert->{send} = $cmd;
319            writechunk( $bytes );
320    
321            if ( $expect ) {
322                    warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
323                    $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
324                    readchunk( $coderef );
325            }
326  }  }
327    
Legend:
Removed from v.1  
changed lines
  Added in v.16
  ViewVC Help
Powered by ViewVC 1.1.26