/[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 65 by dpavlin, Thu Feb 11 13:23:26 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                    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/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/^tag_(\S+)/;
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                                    }
103    
104                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
105    
106                            } else {
107                                    print $client "HTTP/1.0 404 Unkown method\r\n";
108                            }
109                    } else {
110                            print $client "HTTP/1.0 500 No method\r\n";
111                    }
112                    close $client;
113            }
114    
115  sub meteor {          die "server died";
         my ( $item, $html ) = @_;  
         warn ">> meteor $item $html\n";  
         print $meteor "ADDMESSAGE test $item|" . localtime() . "<br>$html\n";  
116  }  }
117    
118  my $debug = 0;  
119    my $last_message = {};
120    sub _message {
121            my $type = shift @_;
122            my $text = join(' ',@_);
123            my $last = $last_message->{$type};
124            if ( $text ne $last ) {
125                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
126                    $last_message->{$type} = $text;
127            }
128    }
129    
130    sub _log { _message('log',@_) };
131    sub diag { _message('diag',@_) };
132    
133  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
134  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 27  my $parity       = "none"; Line 137  my $parity       = "none";
137  my $stopbits  = "1";  my $stopbits  = "1";
138  my $handshake = "none";  my $handshake = "none";
139    
140    my $program_path = './program/';
141    my $secure_path = './secure/';
142    
143    # http server
144    my $http_server = 1;
145    
146    # 3M defaults: 8,4
147    my $max_rfid_block = 16;
148    my $read_blocks = 8;
149    
150  my $response = {  my $response = {
151          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
152          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 47  GetOptions( Line 167  GetOptions(
167          'parity=s'    => \$parity,          'parity=s'    => \$parity,
168          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
169          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
170            'http-server!' => \$http_server,
171  ) or die $!;  ) or die $!;
172    
173  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 82  it under the same terms ans Perl itself. Line 203  it under the same terms ans Perl itself.
203    
204  =cut  =cut
205    
206  my $tags_data;  my $item_type = {
207  my $visible_tags;          1 => 'Book',
208            6 => 'CD/CD ROM',
209            2 => 'Magazine',
210            13 => 'Book with Audio Tape',
211            9 => 'Book with CD/CD ROM',
212            0 => 'Other',
213    
214            5 => 'Video',
215            4 => 'Audio Tape',
216            3 => 'Bound Journal',
217            8 => 'Book with Diskette',
218            7 => 'Diskette',
219    };
220    
221    warn "## known item type: ",dump( $item_type ) if $debug;
222    
223  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";
224  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 228  $databits=$port->databits($databits);
228  $parity=$port->parity($parity);  $parity=$port->parity($parity);
229  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
230    
231  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
232    
233  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
234  $port->lookclear();  $port->lookclear();
# Line 110  cmd( 'D5 00  05   04 00 11 Line 245  cmd( 'D5 00  05   04 00 11
245       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
246          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
247          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( -1, "Found reader $hw_ver" );  
248  });  });
249    
250  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?',
251       '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() }  );
252    
253  # start scanning for tags  sub scan_for_tags {
254    
255  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 {  
256    
257                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
258                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
259                            my $rest = shift || die "no rest?";
260                            my $nr = ord( substr( $rest, 0, 1 ) );
261    
262                          my $tl = length( $tags );                          if ( ! $nr ) {
263                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  _log "no tags in range\n";
264                                    update_visible_tags();
265                                    $tags_data = {};
266                            } else {
267    
268                                    my $tags = substr( $rest, 1 );
269                                    my $tl = length( $tags );
270                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
271    
272                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
273                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
274                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
275    
276                          my @tags;                                  update_visible_tags( @tags );
277                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
278                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
279                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
280    
281                          update_visible_tags( @tags );          diag "tags: ",dump( @tags );
282            return $tags_data;
283    
284                          my $html = join('', map { "<li><tt>$_</tt>" } @tags);  }
                         meteor( 0, "Tags:<ul>$html</ul>" );  
                 }  
         }  
 ) foreach ( 1 .. 1000 );  
285    
286    # start scanning for tags
287    
288    if ( $http_server ) {
289            http_server;
290    } else {
291            while (1) {
292                    scan_for_tags;
293                    sleep 1;
294            }
295    }
296    
297    die "over and out";
298    
299  sub update_visible_tags {  sub update_visible_tags {
300          my @tags = @_;          my @tags = @_;
# Line 156  sub update_visible_tags { Line 303  sub update_visible_tags {
303          $visible_tags = {};          $visible_tags = {};
304    
305          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
306                    $visible_tags->{$tag}++;
307                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
308                          read_tag( $tag );                          if ( defined $tags_data->{$tag} ) {
309                          $visible_tags->{$tag}++;                                  warn "$tag in range\n";
310                            } else {
311                                    read_tag( $tag );
312                            }
313                  } else {                  } else {
314                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
315                  }                  }
316                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
317    
318                    if ( -e "$program_path/$tag" ) {
319                                    write_tag( $tag );
320                    }
321                    if ( -e "$secure_path/$tag" ) {
322                                    secure_tag( $tag );
323                    }
324          }          }
325    
326          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
327                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
328                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
329          }          }
330    
331          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;
332  }  }
333    
334    my $tag_data_block;
335    
336    sub read_tag_data {
337            my ($start_block,$rest) = @_;
338            die "no rest?" unless $rest;
339    
340            my $last_block = 0;
341    
342            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
343            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
344            my $blocks = ord(substr($rest,8,1));
345            $rest = substr($rest,9); # leave just data blocks
346            foreach my $nr ( 0 .. $blocks - 1 ) {
347                    my $block = substr( $rest, $nr * 6, 6 );
348                    warn "## block ",as_hex( $block ) if $debug;
349                    my $ord   = unpack('v',substr( $block, 0, 2 ));
350                    my $expected_ord = $nr + $start_block;
351                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
352                    my $data  = substr( $block, 2 );
353                    die "data payload should be 4 bytes" if length($data) != 4;
354                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
355                    $tag_data_block->{$tag}->[ $ord ] = $data;
356                    $last_block = $ord;
357            }
358            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
359    
360            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
361            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
362    
363            return $last_block + 1;
364    }
365    
366    my $saved_in_log;
367    
368    sub decode_tag {
369            my $tag = shift;
370    
371            my $data = $tags_data->{$tag} || die "no data for $tag";
372    
373            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
374            my $hash = {
375                    u1 => $u1,
376                    u2 => $u2,
377                    set => ( $set_item & 0xf0 ) >> 4,
378                    total => ( $set_item & 0x0f ),
379    
380                    type => $type,
381                    content => $content,
382    
383                    branch => $br_lib >> 20,
384                    library => $br_lib & 0x000fffff,
385    
386                    custom => $custom,
387            };
388    
389            if ( ! $saved_in_log->{$tag}++ ) {
390                    open(my $log, '>>', 'rfid-log.txt');
391                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
392                    close($log);
393            }
394    
395            return $hash;
396    }
397    
398  sub read_tag {  sub read_tag {
399          my ( $tag ) = @_;          my ( $tag ) = @_;
400    
401          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
402    
         return if defined $tags_data->{$tag};  
   
403          print "read_tag $tag\n";          print "read_tag $tag\n";
404    
405            my $start_block = 0;
406    
407            while ( $start_block < $max_rfid_block ) {
408    
409                    cmd(
410                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
411                                    "read $tag offset: $start_block blocks: $read_blocks",
412                            "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";
413                                    $start_block = read_tag_data( $start_block, @_ );
414                                    warn "# read tag upto $start_block\n";
415                            },
416                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
417                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
418                            },
419                    );
420    
421            }
422    
423            my $security;
424    
425          cmd(          cmd(
426                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag BEEF", "check security $tag",
427                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
428                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
429                  },                          my $from_tag;
430                  "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) );
431                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
432                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
433                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          $tags_security->{$tag} = $security;
434                          my $blocks = ord(substr($rest,8,1));                          warn "# SECURITY $tag = $security\n";
                         $rest = substr($rest,9); # leave just data blocks  
                         my @data;  
                         foreach my $nr ( 0 .. $blocks - 1 ) {  
                                 my $block = substr( $rest, $nr * 6, 6 );  
                                 warn "## block ",as_hex( $block ) if $debug;  
                                 my $ord   = unpack('v',substr( $block, 0, 2 ));  
                                 die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;  
                                 my $data  = substr( $block, 2 );  
                                 die "data payload should be 4 bytes" if length($data) != 4;  
                                 warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;  
                                 $data[ $ord ] = $data;  
                         }  
                         $tags_data->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $tags_data ), "\n";  
435                  }                  }
436          );          );
437    
438          #        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          print "TAG $tag ", dump(decode_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";  
439  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
440    
441          my $item = unpack('H*', substr($tag,-8) ) % 100000;  sub write_tag {
442          meteor( $item, "Loading $item" );          my ($tag,$data) = @_;
443    
444            my $path = "$program_path/$tag";
445            $data = read_file( $path ) if -e $path;
446    
447            die "no data" unless $data;
448    
449            my $hex_data;
450    
451            if ( $data =~ s{^hex\s+}{} ) {
452                    $hex_data = $data;
453                    $hex_data =~ s{\s+}{}g;
454            } else {
455    
456                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
457    
458                    my $max_len = $max_rfid_block * 4;
459    
460                    if ( length($data) > $max_len ) {
461                            $data = substr($data,0,$max_len);
462                            warn "strip content to $max_len bytes\n";
463                    }
464    
465                    $hex_data = unpack('H*', $data);
466            }
467    
468            my $len = length($hex_data) / 2;
469            # pad to block size
470            $hex_data .= '00' x ( 4 - $len % 4 );
471            my $blocks = sprintf('%02x', length($hex_data) / 4);
472    
473            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
474    
475            cmd(
476                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
477                    "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
478            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
479    
480            my $to = $path;
481            $to .= '.' . time();
482    
483            rename $path, $to;
484            print ">> $to\n";
485    
486            # force re-read of tag
487            delete $tags_data->{$tag};
488            delete $visible_tags->{$tag};
489    }
490    
491    sub secure_tag {
492            my ($tag) = @_;
493    
494            my $path = "$secure_path/$tag";
495            my $data = substr(read_file( $path ),0,2);
496    
497            cmd(
498                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
499                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
500            );
501    
502            my $to = $path;
503            $to .= '.' . time();
504    
505            rename $path, $to;
506            print ">> $to\n";
507  }  }
508    
509  exit;  exit;
# Line 257  sub writechunk Line 538  sub writechunk
538  {  {
539          my $str=shift;          my $str=shift;
540          my $count = $port->write($str);          my $count = $port->write($str);
541            my $len = length($str);
542            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
543          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
544  }  }
545    
# Line 276  sub read_bytes { Line 559  sub read_bytes {
559          my $data = '';          my $data = '';
560          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
561                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
562                    die "no bytes on port: $!" unless defined $b;
563                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
564                  $data .= $b;                  $data .= $b;
565          }          }
# Line 322  sub crcccitt { Line 606  sub crcccitt {
606  sub checksum {  sub checksum {
607          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
608    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
609          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
610          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
611    
612          if ( $len_real != $len ) {          if ( $len_real != $len ) {
613                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
614                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
615          }          }
616    
617            my $xor = crcccitt( substr($bytes,1) ); # skip D6
618            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
619    
620          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
621                  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";
622                  return $bytes . $xor;                  return $bytes . $xor;
623          }          }
624          return $bytes . $checksum;          return $bytes . $checksum;
# Line 343  sub checksum { Line 627  sub checksum {
627  our $dispatch;  our $dispatch;
628    
629  sub readchunk {  sub readchunk {
630          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
631    
632          # read header of packet          # read header of packet
633          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 372  sub readchunk { Line 656  sub readchunk {
656          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
657    
658          if ( defined $to ) {          if ( defined $to ) {
659                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
660                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
661                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
662          } else {          } else {
663                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
664          }          }
665    
666          return $data;          return $data;
Legend:
Removed from v.23  
changed lines
  Added in v.65
  ViewVC Help
Powered by ViewVC 1.1.26