/[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 17 by dpavlin, Fri Oct 3 08: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;  });
         die $@ if $@;  
         warn ">> ", as_hex( $bytes ), "\t$desc\n";  
         writechunk( $bytes );  
         warn "?? $expect\n" if $expect;  
         readchunk();  
 }  
88    
89  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','stats?',
90       'D5 00  09  04   00   11   0A 05 00 02   7250 -- hw 10.5.0.2' );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );
91    
92  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  # start scanning for tags
 #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778  
93    
94  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
95       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );       '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  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen                          my $tl = length( $tags );
104                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
105    
106  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );                          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  #     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                          # XXX read first tag
112  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";                          read_tag( @tags );
113    
114  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );                  }
115    ) }
116    
117  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00    ) foreach ( 1 .. 100 );
118  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
119  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  my $read_cached;
120                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";  
121  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";  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 offset: 0 blocks: 3' );
128    
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 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) - 1;
260    
261            if ( $len_real != $len ) {
262                    print "length wrong: $len_real != $len\n";
263                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
264            }
265    
266            if ( defined $checksum && $xor ne $checksum ) {
267                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
268                    return $bytes . $xor;
269            }
270            return $bytes . $checksum;
271    }
272    
273  sub readchunk {  sub readchunk {
274            my ( $parser ) = @_;
275    
276            sleep 1;        # FIXME remove
277    
278          # read header of packet          # read header of packet
279          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
280          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
281            my $len = ord($length);
282          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
283    
284          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
285            my $payload_len = length($data);
286            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
287    
288            my $checksum = substr( $data, -2, 2 );
289            checksum( $header . $length . $payload, $checksum );
290    
291            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
292    
293            $assert->{len}      = $len;
294            $assert->{payload}  = $payload;
295    
296          sleep 1;          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
297    
298            return $data;
299    }
300    
301    sub str2bytes {
302            my $str = shift || confess "no str?";
303            my $b = $str;
304            $b =~ s/\s+//g;
305            $b =~ s/(..)/\\x$1/g;
306            $b = "\"$b\"";
307            my $bytes = eval $b;
308            die $@ if $@;
309            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
310            return $bytes;
311    }
312    
313    sub cmd {
314            my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
315            my $bytes = str2bytes( $cmd );
316    
317            # fix checksum if needed
318            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
319    
320            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
321            $assert->{send} = $cmd;
322            writechunk( $bytes );
323    
324            if ( $expect ) {
325                    warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
326                    $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
327                    readchunk( $coderef );
328            }
329  }  }
330    
Legend:
Removed from v.1  
changed lines
  Added in v.17
  ViewVC Help
Powered by ViewVC 1.1.26