/[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 23 by dpavlin, Sat Mar 28 03:47:10 2009 UTC revision 68 by dpavlin, Thu Feb 11 15:10:39 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;  use IO::Socket::INET;
15    
16  my $meteor = IO::Socket::INET->new( '192.168.1.13:4671' ) || die "can't connect to meteor: $!";  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  sub meteor {                  return $path;
58          my ( $item, $html ) = @_;          }
59          warn ">> meteor $item $html\n";  
60          print $meteor "ADDMESSAGE test $item|" . localtime() . "<br>$html\n";          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/x-javascript\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} ) {
108    
109                                    my $status = 501; # Not implementd
110    
111                                    foreach my $p ( keys %$param ) {
112                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
113                                            my $tag = $1;
114                                            my $data = $param->{$p};
115                                            $status = 302;
116    
117                                            warn "SECURE $tag $data\n";
118                                            secure_tag_with( $tag, $data );
119                                    }
120    
121                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
122    
123                            } else {
124                                    print $client "HTTP/1.0 404 Unkown method\r\n";
125                            }
126                    } else {
127                            print $client "HTTP/1.0 500 No method\r\n";
128                    }
129                    close $client;
130            }
131    
132            die "server died";
133  }  }
134    
135  my $debug = 0;  
136    my $last_message = {};
137    sub _message {
138            my $type = shift @_;
139            my $text = join(' ',@_);
140            my $last = $last_message->{$type};
141            if ( $text ne $last ) {
142                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
143                    $last_message->{$type} = $text;
144            }
145    }
146    
147    sub _log { _message('log',@_) };
148    sub diag { _message('diag',@_) };
149    
150  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
151  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 27  my $parity       = "none"; Line 154  my $parity       = "none";
154  my $stopbits  = "1";  my $stopbits  = "1";
155  my $handshake = "none";  my $handshake = "none";
156    
157    my $program_path = './program/';
158    my $secure_path = './secure/';
159    
160    # http server
161    my $http_server = 1;
162    
163    # 3M defaults: 8,4
164    my $max_rfid_block = 16;
165    my $read_blocks = 8;
166    
167  my $response = {  my $response = {
168          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
169          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 47  GetOptions( Line 184  GetOptions(
184          'parity=s'    => \$parity,          'parity=s'    => \$parity,
185          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
186          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
187            'http-server!' => \$http_server,
188  ) or die $!;  ) or die $!;
189    
190  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 82  it under the same terms ans Perl itself. Line 220  it under the same terms ans Perl itself.
220    
221  =cut  =cut
222    
223  my $tags_data;  my $item_type = {
224  my $visible_tags;          1 => 'Book',
225            6 => 'CD/CD ROM',
226            2 => 'Magazine',
227            13 => 'Book with Audio Tape',
228            9 => 'Book with CD/CD ROM',
229            0 => 'Other',
230    
231            5 => 'Video',
232            4 => 'Audio Tape',
233            3 => 'Bound Journal',
234            8 => 'Book with Diskette',
235            7 => 'Diskette',
236    };
237    
238    warn "## known item type: ",dump( $item_type ) if $debug;
239    
240  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";
241  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
# Line 93  $databits=$port->databits($databits); Line 245  $databits=$port->databits($databits);
245  $parity=$port->parity($parity);  $parity=$port->parity($parity);
246  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
247    
248  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
249    
250  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
251  $port->lookclear();  $port->lookclear();
# Line 110  cmd( 'D5 00  05   04 00 11 Line 262  cmd( 'D5 00  05   04 00 11
262       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
263          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
264          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( -1, "Found reader $hw_ver" );  
265  });  });
266    
267  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?',
268       '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() }  );
269    
270  # start scanning for tags  sub scan_for_tags {
271    
272  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
          '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 ) );  
   
                 if ( ! $nr ) {  
                         print "no tags in range\n";  
                         update_visible_tags();  
                         meteor( -1, "No tags in range" );  
                 } else {  
273    
274                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
275                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
276                            my $rest = shift || die "no rest?";
277                            my $nr = ord( substr( $rest, 0, 1 ) );
278    
279                          my $tl = length( $tags );                          if ( ! $nr ) {
280                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  _log "no tags in range\n";
281                                    update_visible_tags();
282                                    $tags_data = {};
283                            } else {
284    
285                                    my $tags = substr( $rest, 1 );
286                                    my $tl = length( $tags );
287                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
288    
289                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
290                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
291                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
292    
293                          my @tags;                                  update_visible_tags( @tags );
294                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
295                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
296                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
297    
298                          update_visible_tags( @tags );          diag "tags: ",dump( @tags );
299            return $tags_data;
300    
301                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);  }
                         meteor( 0, "Tags:<ul>$html</ul>" );  
                 }  
         }  
 ) foreach ( 1 .. 1000 );  
302    
303    # start scanning for tags
304    
305    if ( $http_server ) {
306            http_server;
307    } else {
308            while (1) {
309                    scan_for_tags;
310                    sleep 1;
311            }
312    }
313    
314    die "over and out";
315    
316  sub update_visible_tags {  sub update_visible_tags {
317          my @tags = @_;          my @tags = @_;
# Line 156  sub update_visible_tags { Line 320  sub update_visible_tags {
320          $visible_tags = {};          $visible_tags = {};
321    
322          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
323                    $visible_tags->{$tag}++;
324                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
325                          read_tag( $tag );                          if ( defined $tags_data->{$tag} ) {
326                          $visible_tags->{$tag}++;                                  warn "$tag in range\n";
327                            } else {
328                                    read_tag( $tag );
329                            }
330                  } else {                  } else {
331                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
332                  }                  }
333                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
334    
335                    if ( -e "$program_path/$tag" ) {
336                                    write_tag( $tag );
337                    }
338                    if ( -e "$secure_path/$tag" ) {
339                                    secure_tag( $tag );
340                    }
341          }          }
342    
343          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
344                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
345                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
346          }          }
347    
348          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
349  }  }
350    
351    my $tag_data_block;
352    
353    sub read_tag_data {
354            my ($start_block,$rest) = @_;
355            die "no rest?" unless $rest;
356    
357            my $last_block = 0;
358    
359            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
360            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
361            my $blocks = ord(substr($rest,8,1));
362            $rest = substr($rest,9); # leave just data blocks
363            foreach my $nr ( 0 .. $blocks - 1 ) {
364                    my $block = substr( $rest, $nr * 6, 6 );
365                    warn "## block ",as_hex( $block ) if $debug;
366                    my $ord   = unpack('v',substr( $block, 0, 2 ));
367                    my $expected_ord = $nr + $start_block;
368                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
369                    my $data  = substr( $block, 2 );
370                    die "data payload should be 4 bytes" if length($data) != 4;
371                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
372                    $tag_data_block->{$tag}->[ $ord ] = $data;
373                    $last_block = $ord;
374            }
375            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
376    
377            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
378            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
379    
380            return $last_block + 1;
381    }
382    
383    my $saved_in_log;
384    
385    sub decode_tag {
386            my $tag = shift;
387    
388            my $data = $tags_data->{$tag} || die "no data for $tag";
389    
390            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
391            my $hash = {
392                    u1 => $u1,
393                    u2 => $u2,
394                    set => ( $set_item & 0xf0 ) >> 4,
395                    total => ( $set_item & 0x0f ),
396    
397                    type => $type,
398                    content => $content,
399    
400                    branch => $br_lib >> 20,
401                    library => $br_lib & 0x000fffff,
402    
403                    custom => $custom,
404            };
405    
406            if ( ! $saved_in_log->{$tag}++ ) {
407                    open(my $log, '>>', 'rfid-log.txt');
408                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
409                    close($log);
410            }
411    
412            return $hash;
413    }
414    
415    sub forget_tag {
416            my $tag = shift;
417            delete $tags_data->{$tag};
418            delete $visible_tags->{$tag};
419    }
420    
421  sub read_tag {  sub read_tag {
422          my ( $tag ) = @_;          my ( $tag ) = @_;
423    
424          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
425    
         return if defined $tags_data->{$tag};  
   
426          print "read_tag $tag\n";          print "read_tag $tag\n";
427    
428            my $start_block = 0;
429    
430            while ( $start_block < $max_rfid_block ) {
431    
432                    cmd(
433                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
434                                    "read $tag offset: $start_block blocks: $read_blocks",
435                            "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";
436                                    $start_block = read_tag_data( $start_block, @_ );
437                                    warn "# read tag upto $start_block\n";
438                            },
439                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
440                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
441                            },
442                    );
443    
444            }
445    
446            my $security;
447    
448          cmd(          cmd(
449                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag BEEF", "check security $tag",
450                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
451                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
452                  },                          my $from_tag;
453                  "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) );
454                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
455                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
456                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          $tags_security->{$tag} = $security;
457                          my $blocks = ord(substr($rest,8,1));                          warn "# SECURITY $tag = $security\n";
458                          $rest = substr($rest,9); # leave just data blocks                  }
459                          my @data;          );
460                          foreach my $nr ( 0 .. $blocks - 1 ) {  
461                                  my $block = substr( $rest, $nr * 6, 6 );          print "TAG $tag ", dump(decode_tag( $tag ));
462                                  warn "## block ",as_hex( $block ) if $debug;  }
463                                  my $ord   = unpack('v',substr( $block, 0, 2 ));  
464                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;  sub write_tag {
465                                  my $data  = substr( $block, 2 );          my ($tag,$data) = @_;
466                                  die "data payload should be 4 bytes" if length($data) != 4;  
467                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;          my $path = "$program_path/$tag";
468                                  $data[ $ord ] = $data;          $data = read_file( $path ) if -e $path;
469                          }  
470                          $tags_data->{ $tag } = join('', @data);          die "no data" unless $data;
471                          print "DATA $tag ",dump( $tags_data ), "\n";  
472            my $hex_data;
473    
474            if ( $data =~ s{^hex\s+}{} ) {
475                    $hex_data = $data;
476                    $hex_data =~ s{\s+}{}g;
477            } else {
478    
479                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
480    
481                    my $max_len = $max_rfid_block * 4;
482    
483                    if ( length($data) > $max_len ) {
484                            $data = substr($data,0,$max_len);
485                            warn "strip content to $max_len bytes\n";
486                  }                  }
487    
488                    $hex_data = unpack('H*', $data);
489            }
490    
491            my $len = length($hex_data) / 2;
492            # pad to block size
493            $hex_data .= '00' x ( 4 - $len % 4 );
494            my $blocks = sprintf('%02x', length($hex_data) / 4);
495    
496            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
497    
498            cmd(
499                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
500                    "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
501            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
502    
503            my $to = $path;
504            $to .= '.' . time();
505    
506            rename $path, $to;
507            print ">> $to\n";
508    
509            forget_tag $tag;
510    }
511    
512    sub secure_tag_with {
513            my ( $tag, $data ) = @_;
514    
515            cmd(
516                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
517                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
518          );          );
519    
520          #        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";  
521  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
522    
523          my $item = unpack('H*', substr($tag,-8) ) % 100000;  sub secure_tag {
524          meteor( $item, "Loading $item" );          my ($tag) = @_;
525    
526            my $path = "$secure_path/$tag";
527            my $data = substr(read_file( $path ),0,2);
528    
529            secure_tag_with( $tag, $data );
530    
531            my $to = $path;
532            $to .= '.' . time();
533    
534            rename $path, $to;
535            print ">> $to\n";
536  }  }
537    
538  exit;  exit;
# Line 257  sub writechunk Line 567  sub writechunk
567  {  {
568          my $str=shift;          my $str=shift;
569          my $count = $port->write($str);          my $count = $port->write($str);
570            my $len = length($str);
571            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
572          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
573  }  }
574    
# Line 276  sub read_bytes { Line 588  sub read_bytes {
588          my $data = '';          my $data = '';
589          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
590                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
591                    die "no bytes on port: $!" unless defined $b;
592                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
593                  $data .= $b;                  $data .= $b;
594          }          }
# Line 322  sub crcccitt { Line 635  sub crcccitt {
635  sub checksum {  sub checksum {
636          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
637    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
638          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
639          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
640    
641          if ( $len_real != $len ) {          if ( $len_real != $len ) {
642                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
643                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
644          }          }
645    
646            my $xor = crcccitt( substr($bytes,1) ); # skip D6
647            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
648    
649          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
650                  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";
651                  return $bytes . $xor;                  return $bytes . $xor;
652          }          }
653          return $bytes . $checksum;          return $bytes . $checksum;
# Line 343  sub checksum { Line 656  sub checksum {
656  our $dispatch;  our $dispatch;
657    
658  sub readchunk {  sub readchunk {
659          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
660    
661          # read header of packet          # read header of packet
662          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 372  sub readchunk { Line 685  sub readchunk {
685          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
686    
687          if ( defined $to ) {          if ( defined $to ) {
688                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
689                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
690                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
691          } else {          } else {
692                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
693          }          }
694    
695          return $data;          return $data;
Legend:
Removed from v.23  
changed lines
  Added in v.68
  ViewVC Help
Powered by ViewVC 1.1.26