/[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 18 by dpavlin, Fri Oct 3 12:31:58 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
         my ( $cmd, $desc, $expect ) = @_;  
         $cmd =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum  
         $cmd =~ s/\s+/\\x/g;  
         $cmd = '"\x' . $cmd . '"';  
         my $bytes = eval $cmd;  
         die $@ if $@;  
         warn ">> ", as_hex( $bytes ), "\t$desc\n";  
         writechunk( $bytes );  
         warn "?? $expect\n" if $expect;  
         readchunk();  
 }  
   
 cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  
      'D5 00  09  04   00   11   0A 05 00 02   7250 -- hw 10.5.0.2' );  
83    
84  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
85  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778       '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  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  });
88       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );  
89    cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','stats?',
90  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );
91    
92  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  # start scanning for tags
93    
94  #     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  05   FE     00  05         FA40', "XXX scan $_",
95  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  07   FE  00 00  05     00  C97B', 'no tag', sub {
96    dispatch(
97  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );           '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 140  print "Port closed\n"; Line 187  print "Port closed\n";
187  sub writechunk  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 {
195          my @out;          my @out;
196          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
197                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
198                  $hex =~ s/(..)/$1 /g;                  $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 164  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    our $assert;
219    
220    # my $rest = skip_assert( 3 );
221    sub skip_assert {
222            assert( 0, shift );
223    }
224    
225    sub assert {
226            my ( $from, $to ) = @_;
227    
228            $from ||= 0;
229            $to = length( $assert->{expect} ) if ! defined $to;
230    
231            my $p = substr( $assert->{payload}, $from, $to );
232            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;
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 {
293            my ( $parser ) = @_;
294    
295            sleep 1;        # FIXME remove
296    
297          # read header of packet          # read header of packet
298          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
299          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
300            my $len = ord($length);
301          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
302    
303          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
304            my $payload_len = length($data);
305            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
306    
307            my $checksum = substr( $data, -2, 2 );
308            checksum( $header . $length . $payload, $checksum );
309    
310            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
311    
312            $assert->{len}      = $len;
313            $assert->{payload}  = $payload;
314    
315            $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
316    
317          sleep 1;          return $data;
318    }
319    
320    sub str2bytes {
321            my $str = shift || confess "no str?";
322            my $b = $str;
323            $b =~ s/\s+//g;
324            $b =~ s/(..)/\\x$1/g;
325            $b = "\"$b\"";
326            my $bytes = eval $b;
327            die $@ if $@;
328            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
329            return $bytes;
330    }
331    
332    sub cmd {
333            my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
334            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";
340            $assert->{send} = $cmd;
341            writechunk( $bytes );
342    
343            if ( $expect ) {
344                    warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
345                    $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
346                    readchunk( $coderef );
347            }
348  }  }
349    
Legend:
Removed from v.1  
changed lines
  Added in v.18
  ViewVC Help
Powered by ViewVC 1.1.26