/[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 21 by dpavlin, Fri Oct 3 21:47:24 2008 UTC revision 75 by dpavlin, Thu Feb 11 22:12:34 2010 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  use Getopt::Long;  use Getopt::Long;
10    use File::Slurp;
11    use JSON;
12    use POSIX qw(strftime);
13    
14    use IO::Socket::INET;
15    
16  my $debug = 0;  my $debug = 0;
17    
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $listen_port = 9000;                  # pick something not in use
23    my $server_url  = "http://localhost:$listen_port";
24    
25    sub http_server {
26    
27            my $server = IO::Socket::INET->new(
28                    Proto     => 'tcp',
29                    LocalPort => $listen_port,
30                    Listen    => SOMAXCONN,
31                    Reuse     => 1
32            );
33                                                                      
34            die "can't setup server" unless $server;
35    
36            print "Server $0 ready at $server_url\n";
37    
38            sub static {
39                    my ($client,$path) = @_;
40    
41                    $path = "www/$path";
42                    $path .= 'rfid.html' if $path =~ m{/$};
43    
44                    return unless -e $path;
45    
46                    my $type = 'text/plain';
47                    $type = 'text/html' if $path =~ m{\.htm};
48                    $type = 'application/javascript' if $path =~ m{\.js};
49    
50                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                    open(my $html, $path);
52                    while(<$html>) {
53                            print $client $_;
54                    }
55                    close($html);
56    
57                    return $path;
58            }
59    
60            while (my $client = $server->accept()) {
61                    $client->autoflush(1);
62                    my $request = <$client>;
63    
64                    warn "WEB << $request\n" if $debug;
65    
66                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                            my $method = $1;
68                            my $param;
69                            if ( $method =~ s{\?(.+)}{} ) {
70                                    foreach my $p ( split(/[&;]/, $1) ) {
71                                            my ($n,$v) = split(/=/, $p, 2);
72                                            $param->{$n} = $v;
73                                    }
74                                    warn "WEB << param: ",dump( $param ) if $debug;
75                            }
76                            if ( my $path = static( $client,$1 ) ) {
77                                    warn "WEB >> $path" if $debug;
78                            } elsif ( $method =~ m{/scan} ) {
79                                    my $tags = scan_for_tags();
80                                    my $json = { time => time() };
81                                    map {
82                                            my $d = decode_tag($_);
83                                            $d->{sid} = $_;
84                                            $d->{security} = $tags_security->{$_};
85                                            push @{ $json->{tags} },  $d;
86                                    } keys %$tags;
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
88                                            $param->{callback}, "(", to_json($json), ")\r\n";
89                            } elsif ( $method =~ m{/program} ) {
90    
91                                    my $status = 501; # Not implementd
92    
93                                    foreach my $p ( keys %$param ) {
94                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
95                                            my $tag = $1;
96                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
97                                            $content = "\x00" if $param->{$p} eq 'blank';
98                                            $status = 302;
99    
100                                            warn "PROGRAM $tag $content\n";
101                                            write_tag( $tag, $content );
102                                            secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
103                                    }
104    
105                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
106    
107                            } elsif ( $method =~ m{/secure(.js)} ) {
108    
109                                    my $json = $1;
110    
111                                    my $status = 501; # Not implementd
112    
113                                    foreach my $p ( keys %$param ) {
114                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
115                                            my $tag = $1;
116                                            my $data = $param->{$p};
117                                            $status = 302;
118    
119                                            warn "SECURE $tag $data\n";
120                                            secure_tag_with( $tag, $data );
121                                    }
122    
123                                    if ( $json ) {
124                                            print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
125                                                    $param->{callback}, "({ ok: 1 })\r\n";
126                                    } else {
127                                            print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
128                                    }
129    
130                            } else {
131                                    print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
132                            }
133                    } else {
134                            print $client "HTTP/1.0 500 No method\r\n\r\n";
135                    }
136                    close $client;
137            }
138    
139            die "server died";
140    }
141    
142    
143    my $last_message = {};
144    sub _message {
145            my $type = shift @_;
146            my $text = join(' ',@_);
147            my $last = $last_message->{$type};
148            if ( $text ne $last ) {
149                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
150                    $last_message->{$type} = $text;
151            }
152    }
153    
154    sub _log { _message('log',@_) };
155    sub diag { _message('diag',@_) };
156    
157  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
158  my $baudrate  = "19200";  my $baudrate  = "19200";
159  my $databits  = "8";  my $databits  = "8";
# Line 17  my $parity       = "none"; Line 161  my $parity       = "none";
161  my $stopbits  = "1";  my $stopbits  = "1";
162  my $handshake = "none";  my $handshake = "none";
163    
164    my $program_path = './program/';
165    my $secure_path = './secure/';
166    
167    # http server
168    my $http_server = 1;
169    
170    # 3M defaults: 8,4
171    # cards 16, stickers: 8
172    my $max_rfid_block = 8;
173    my $read_blocks = 8;
174    
175  my $response = {  my $response = {
176          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
177          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 30  my $response = { Line 185  my $response = {
185  };  };
186    
187  GetOptions(  GetOptions(
188          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
189          'device=s'    => \$device,          'device=s'    => \$device,
190          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
191          'databits=i'  => \$databits,          'databits=i'  => \$databits,
192          'parity=s'    => \$parity,          'parity=s'    => \$parity,
193          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
194          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
195            'http-server!' => \$http_server,
196  ) or die $!;  ) or die $!;
197    
198    my $verbose = $debug > 0 ? $debug-- : 0;
199    
200  =head1 NAME  =head1 NAME
201    
202  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
# Line 70  it under the same terms ans Perl itself. Line 228  it under the same terms ans Perl itself.
228    
229  =cut  =cut
230    
231  my $tags_data;  my $item_type = {
232  my $visible_tags;          1 => 'Book',
233            6 => 'CD/CD ROM',
234            2 => 'Magazine',
235            13 => 'Book with Audio Tape',
236            9 => 'Book with CD/CD ROM',
237            0 => 'Other',
238    
239            5 => 'Video',
240            4 => 'Audio Tape',
241            3 => 'Bound Journal',
242            8 => 'Book with Diskette',
243            7 => 'Diskette',
244    };
245    
246    warn "## known item type: ",dump( $item_type ) if $debug;
247    
248  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
249  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
# Line 81  $databits=$port->databits($databits); Line 253  $databits=$port->databits($databits);
253  $parity=$port->parity($parity);  $parity=$port->parity($parity);
254  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
255    
256  print "## using $device $baudrate $databits $parity $stopbits\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
257    
258  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
259  $port->lookclear();  $port->lookclear();
# Line 96  $port->read_char_time(5); Line 268  $port->read_char_time(5);
268    
269  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
270       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
271          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
272            print "hardware version $hw_ver\n";
273  });  });
274    
275  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
276       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
277    
278  # start scanning for tags  sub scan_for_tags {
279    
280  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
      'D6 00  07   FE  00 00  05     00  C97B', sub {  
                 assert();  
                 print "no tag in range\n";  
   
         },  
          'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
                 my $rest = shift || die "no rest?";  
                 my $nr = ord( substr( $rest, 0, 1 ) );  
281    
282                  if ( ! $nr ) {          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
283                          print "no tags in range\n";                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
284                  } else {                          my $rest = shift || die "no rest?";
285                            my $nr = ord( substr( $rest, 0, 1 ) );
286    
287                          my $tags = substr( $rest, 1 );                          if ( ! $nr ) {
288                                    _log "no tags in range\n";
289                                    update_visible_tags();
290                                    $tags_data = {};
291                            } else {
292    
293                                    my $tags = substr( $rest, 1 );
294                                    my $tl = length( $tags );
295                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
296    
297                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
298                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
299                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
300    
301                          my $tl = length( $tags );                                  update_visible_tags( @tags );
302                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                          }
303                    }
304            );
305    
306                          my @tags;          diag "tags: ",dump( @tags );
307                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );          return $tags_data;
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
308    
309                          my $removed_tags = $visible_tags;  }
                         $visible_tags = {};  
310    
311                          foreach my $tag ( @tags ) {  # start scanning for tags
312                                  next if $visible_tags->{$tag}++;  
313    if ( $http_server ) {
314            http_server;
315    } else {
316            while (1) {
317                    scan_for_tags;
318                    sleep 1;
319            }
320    }
321    
322    die "over and out";
323    
324    sub update_visible_tags {
325            my @tags = @_;
326    
327            my $last_visible_tags = $visible_tags;
328            $visible_tags = {};
329    
330            foreach my $tag ( @tags ) {
331                    $visible_tags->{$tag}++;
332                    if ( ! defined $last_visible_tags->{$tag} ) {
333                            if ( defined $tags_data->{$tag} ) {
334                                    warn "$tag in range\n";
335                            } else {
336                                  read_tag( $tag );                                  read_tag( $tag );
                                 if ( delete $removed_tags->{$tag} ) {  
                                         print "removed tag $tag\n";  
                                 }  
337                          }                          }
338                    } else {
339                            warn "## using cached data for $tag" if $debug;
340                    }
341                    delete $last_visible_tags->{$tag}; # leave just missing tags
342    
343                    if ( -e "$program_path/$tag" ) {
344                                    write_tag( $tag );
345                    }
346                    if ( -e "$secure_path/$tag" ) {
347                                    secure_tag( $tag );
348                  }                  }
349          }          }
350  ) foreach ( 1 .. 100 );  
351            foreach my $tag ( keys %$last_visible_tags ) {
352                    my $data = delete $tags_data->{$tag};
353                    warn "$tag removed ", dump($data), $/;
354            }
355    
356            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
357    }
358    
359    my $tag_data_block;
360    
361    sub read_tag_data {
362            my ($start_block,$rest) = @_;
363            die "no rest?" unless $rest;
364    
365            my $last_block = 0;
366    
367            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
368            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
369            my $blocks = ord(substr($rest,8,1));
370            $rest = substr($rest,9); # leave just data blocks
371            foreach my $nr ( 0 .. $blocks - 1 ) {
372                    my $block = substr( $rest, $nr * 6, 6 );
373                    warn "## block ",as_hex( $block ) if $debug;
374                    my $ord   = unpack('v',substr( $block, 0, 2 ));
375                    my $expected_ord = $nr + $start_block;
376                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
377                    my $data  = substr( $block, 2 );
378                    die "data payload should be 4 bytes" if length($data) != 4;
379                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
380                    $tag_data_block->{$tag}->[ $ord ] = $data;
381                    $last_block = $ord;
382            }
383            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
384    
385            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
386            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
387    
388            return $last_block + 1;
389    }
390    
391    my $saved_in_log;
392    
393    sub decode_tag {
394            my $tag = shift;
395    
396            my $data = $tags_data->{$tag} || die "no data for $tag";
397    
398            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
399            my $hash = {
400                    u1 => $u1,
401                    u2 => $u2,
402                    set => ( $set_item & 0xf0 ) >> 4,
403                    total => ( $set_item & 0x0f ),
404    
405                    type => $type,
406                    content => $content,
407    
408                    branch => $br_lib >> 20,
409                    library => $br_lib & 0x000fffff,
410    
411                    custom => $custom,
412            };
413    
414            if ( ! $saved_in_log->{$tag}++ ) {
415                    open(my $log, '>>', 'rfid-log.txt');
416                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
417                    close($log);
418            }
419    
420            return $hash;
421    }
422    
423    sub forget_tag {
424            my $tag = shift;
425            delete $tags_data->{$tag};
426            delete $visible_tags->{$tag};
427    }
428    
429  sub read_tag {  sub read_tag {
430          my ( $tag ) = @_;          my ( $tag ) = @_;
431    
432            confess "no tag?" unless $tag;
433    
434          print "read_tag $tag\n";          print "read_tag $tag\n";
435    
436            my $start_block = 0;
437    
438            while ( $start_block < $max_rfid_block ) {
439    
440                    cmd(
441                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
442                                    "read $tag offset: $start_block blocks: $read_blocks",
443                            "D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
444                                    $start_block = read_tag_data( $start_block, @_ );
445                                    warn "# read tag upto $start_block\n";
446                            },
447                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
448                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
449                            },
450                    );
451    
452            }
453    
454            my $security;
455    
456          cmd(          cmd(
457                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag BEEF", "check security $tag",
458                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
459                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
460                  },                          my $from_tag;
461                  "D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
462                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
463                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
464                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          $tags_security->{$tag} = $security;
465                          my $blocks = ord(substr($rest,8,1));                          warn "# SECURITY $tag = $security\n";
466                          $rest = substr($rest,9); # leave just data blocks                  }
467                          my @data;          );
468                          foreach my $nr ( 0 .. $blocks - 1 ) {  
469                                  my $block = substr( $rest, $nr * 6, 6 );          print "TAG $tag ", dump(decode_tag( $tag ));
470                                  warn "## block ",as_hex( $block ) if $debug;  }
471                                  my $ord   = unpack('v',substr( $block, 0, 2 ));  
472                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;  sub write_tag {
473                                  my $data  = substr( $block, 2 );          my ($tag,$data) = @_;
474                                  die "data payload should be 4 bytes" if length($data) != 4;  
475                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;          my $path = "$program_path/$tag";
476                                  $data[ $ord ] = $data;          $data = read_file( $path ) if -e $path;
477                          }  
478                          $tags_data->{ $tag } = join('', @data);          die "no data" unless $data;
479                          print "DATA $tag ",dump( $tags_data ), "\n";  
480            my $hex_data;
481    
482            if ( $data =~ s{^hex\s+}{} ) {
483                    $hex_data = $data;
484                    $hex_data =~ s{\s+}{}g;
485            } else {
486    
487                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
488    
489                    my $max_len = $max_rfid_block * 4;
490    
491                    if ( length($data) > $max_len ) {
492                            $data = substr($data,0,$max_len);
493                            warn "strip content to $max_len bytes\n";
494                  }                  }
495    
496                    $hex_data = unpack('H*', $data);
497            }
498    
499            my $len = length($hex_data) / 2;
500            # pad to block size
501            $hex_data .= '00' x ( 4 - $len % 4 );
502            my $blocks = sprintf('%02x', length($hex_data) / 4);
503    
504            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
505    
506            cmd(
507                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
508                    "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
509            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
510    
511            my $to = $path;
512            $to .= '.' . time();
513    
514            rename $path, $to;
515            print ">> $to\n";
516    
517            forget_tag $tag;
518    }
519    
520    sub secure_tag_with {
521            my ( $tag, $data ) = @_;
522    
523            cmd(
524                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
525                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
526          );          );
527    
528          #        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          forget_tag $tag;
 if (0) {  
         cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
   
         #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
         #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
         warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";  
529  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
530    
531    sub secure_tag {
532            my ($tag) = @_;
533    
534            my $path = "$secure_path/$tag";
535            my $data = substr(read_file( $path ),0,2);
536    
537            secure_tag_with( $tag, $data );
538    
539            my $to = $path;
540            $to .= '.' . time();
541    
542            rename $path, $to;
543            print ">> $to\n";
544  }  }
545    
546  exit;  exit;
# Line 219  sub writechunk Line 575  sub writechunk
575  {  {
576          my $str=shift;          my $str=shift;
577          my $count = $port->write($str);          my $count = $port->write($str);
578            my $len = length($str);
579            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
580          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
581  }  }
582    
# Line 238  sub read_bytes { Line 596  sub read_bytes {
596          my $data = '';          my $data = '';
597          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
598                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
599                    die "no bytes on port: $!" unless defined $b;
600                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
601                  $data .= $b;                  $data .= $b;
602          }          }
# Line 284  sub crcccitt { Line 643  sub crcccitt {
643  sub checksum {  sub checksum {
644          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
645    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
646          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
647          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
648    
649          if ( $len_real != $len ) {          if ( $len_real != $len ) {
650                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
651                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
652          }          }
653    
654            my $xor = crcccitt( substr($bytes,1) ); # skip D6
655            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
656    
657          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
658                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  warn "checksum error: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n" if $checksum ne "\xBE\xEF";
659                  return $bytes . $xor;                  return $bytes . $xor;
660          }          }
661          return $bytes . $checksum;          return $bytes . $checksum;
# Line 305  sub checksum { Line 664  sub checksum {
664  our $dispatch;  our $dispatch;
665    
666  sub readchunk {  sub readchunk {
667          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
668    
669          # read header of packet          # read header of packet
670          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 320  sub readchunk { Line 679  sub readchunk {
679          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
680          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
681    
682          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
683    
684          $assert->{len}      = $len;          $assert->{len}      = $len;
685          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 334  sub readchunk { Line 693  sub readchunk {
693          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
694    
695          if ( defined $to ) {          if ( defined $to ) {
696                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
697                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
698                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
699          } else {          } else {
700                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
701          }          }
702    
703          return $data;          return $data;
# Line 366  sub cmd { Line 725  sub cmd {
725          # fix checksum if needed          # fix checksum if needed
726          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
727    
728          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
729          $assert->{send} = $cmd;          $assert->{send} = $cmd;
730          writechunk( $bytes );          writechunk( $bytes );
731    
Legend:
Removed from v.21  
changed lines
  Added in v.75
  ViewVC Help
Powered by ViewVC 1.1.26