/[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 20 by dpavlin, Fri Oct 3 21:25:02 2008 UTC revision 46 by dpavlin, Tue Jun 23 13:50:13 2009 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    
13    use IO::Socket::INET;
14    
15    my $meteor_server = '192.168.1.13:4671';
16    my $meteor_fh;
17    
18    sub meteor {
19            my @a = @_;
20            push @a, scalar localtime() if $a[0] =~ m{^info};
21    
22            if ( ! defined $meteor_fh ) {
23                    if ( $meteor_fh =
24                                    IO::Socket::INET->new(
25                                            PeerAddr => $meteor_server,
26                                            Timeout => 1,
27                                    )
28                    ) {
29                            warn "# meteor connected to $meteor_server";
30                    } else {
31                            warn "can't connect to meteor $meteor_server: $!";
32                            $meteor_fh = 0;
33                    }
34            }
35    
36            if ( $meteor_fh ) {
37                    warn ">> meteor ",dump( @a );
38                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
39            }
40    }
41    
42    my $listen_port = 9000;                  # pick something not in use
43    sub http_server {
44    
45            my $server = IO::Socket::INET->new(
46                    Proto     => 'tcp',
47                    LocalPort => $listen_port,
48                    Listen    => SOMAXCONN,
49                    Reuse     => 1
50            );
51                                                                      
52            die "can't setup server" unless $server;
53    
54            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
55    
56            sub static {
57                    my ($client,$path) = @_;
58    
59                    $path = "www/$path";
60    
61                    return unless -e $path;
62    
63                    my $type = 'text/plain';
64                    $type = 'text/html' if $path =~ m{\.htm};
65                    $type = 'application/javascript' if $path =~ m{\.js};
66    
67                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
68                    open(my $html, $path);
69                    while(<$html>) {
70                            print $client $_;
71                    }
72                    close($html);
73    
74                    return $path;
75            }
76    
77            while (my $client = $server->accept()) {
78                    $client->autoflush(1);
79                    my $request = <$client>;
80    
81                    warn "<< $request\n";
82    
83                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
84                            my $method = $1;
85                            my $param;
86                            if ( $method =~ s{\?(.+)}{} ) {
87                                    foreach my $p ( split(/[&;]/, $1) ) {
88                                            my ($n,$v) = split(/=/, $p, 2);
89                                            $param->{$n} = $v;
90                                    }
91                                    warn "<< param: ",dump( $param );
92                            }
93                            if ( my $path = static( $client,$1 ) ) {
94                                    warn ">> $path";
95                            } elsif ( $method =~ m{/scan} ) {
96                                    my $tags = scan_for_tags();
97                                    my $json = {};
98                                    map {
99                                            my $d = decode_tag($_);
100                                            $d->{sid} = $_;
101                                            push @{ $json->{tags} },  $d;
102                                    } keys %$tags;
103                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
104                                            $param->{callback}, "(", to_json($json), ")\r\n";
105                            } else {
106                                    print $client "HTTP/1.0 404 Unkown method\r\n";
107                            }
108                    } else {
109                            print $client "HTTP/1.0 500 No method\r\n";
110                    }
111                    close $client;
112            }
113    
114            die "server died";
115    }
116    
117  my $debug = 0;  my $debug = 0;
118    
# Line 17  my $parity       = "none"; Line 123  my $parity       = "none";
123  my $stopbits  = "1";  my $stopbits  = "1";
124  my $handshake = "none";  my $handshake = "none";
125    
126    my $program_path = './program/';
127    my $secure_path = './secure/';
128    
129    # http server
130    my $http_server = 1;
131    
132    # 3M defaults: 8,4
133    my $max_rfid_block = 16;
134    my $read_blocks = 8;
135    
136  my $response = {  my $response = {
137          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
138          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 30  my $response = { Line 146  my $response = {
146  };  };
147    
148  GetOptions(  GetOptions(
149          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
150          'device=s'    => \$device,          'device=s'    => \$device,
151          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
152          'databits=i'  => \$databits,          'databits=i'  => \$databits,
153          'parity=s'    => \$parity,          'parity=s'    => \$parity,
154          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
155          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
156            'meteor=s'    => \$meteor_server,
157            'http-server!' => \$http_server,
158  ) or die $!;  ) or die $!;
159    
160    my $verbose = $debug > 0 ? $debug-- : 0;
161    
162  =head1 NAME  =head1 NAME
163    
164  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 190  it under the same terms ans Perl itself.
190    
191  =cut  =cut
192    
193    my $tags_data;
194    my $visible_tags;
195    
196    my $item_type = {
197            1 => 'Book',
198            6 => 'CD/CD ROM',
199            2 => 'Magazine',
200            13 => 'Book with Audio Tape',
201            9 => 'Book with CD/CD ROM',
202            0 => 'Other',
203    
204            5 => 'Video',
205            4 => 'Audio Tape',
206            3 => 'Bound Journal',
207            8 => 'Book with Diskette',
208            7 => 'Diskette',
209    };
210    
211    warn "## known item type: ",dump( $item_type ) if $debug;
212    
213  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";
214  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
215  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 218  $databits=$port->databits($databits);
218  $parity=$port->parity($parity);  $parity=$port->parity($parity);
219  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
220    
221  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
222    
223  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
224  $port->lookclear();  $port->lookclear();
# Line 93  $port->read_char_time(5); Line 233  $port->read_char_time(5);
233    
234  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
235       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
236          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
237            print "hardware version $hw_ver\n";
238            meteor( 'info', "Found reader hardware $hw_ver" );
239  });  });
240    
241  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?',
242       '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() }  );
243    
244  # start scanning for tags  sub scan_for_tags {
245    
246  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 ) );  
247    
248                  if ( ! $nr ) {          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
249                          print "no tags in range\n";                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
250                  } else {                          my $rest = shift || die "no rest?";
251                            my $nr = ord( substr( $rest, 0, 1 ) );
252    
253                            if ( ! $nr ) {
254                                    print "no tags in range\n";
255                                    update_visible_tags();
256                                    meteor( 'info-none-in-range' );
257                                    $tags_data = {};
258                            } else {
259    
260                                    my $tags = substr( $rest, 1 );
261    
262                          my $tags = substr( $rest, 1 );                                  my $tl = length( $tags );
263                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
264    
265                          my $tl = length( $tags );                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
266                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
267                                    print "$nr tags in range: ", join(',', @tags ) , "\n";
268    
269                          my @tags;                                  meteor( 'info-in-range', join(' ',@tags));
                         push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );  
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
270    
271                          # read data from tag                                  update_visible_tags( @tags );
272                          read_tag( $_ ) foreach @tags;                          }
273                    }
274            );
275    
276            warn "## tags: ",dump( @tags );
277            return $tags_data;
278    
279    }
280    
281    # start scanning for tags
282    
283    if ( $http_server ) {
284            http_server;
285    } else {
286            scan_for_tags while 1;
287    }
288    
289    die "over and out";
290    
291    sub update_visible_tags {
292            my @tags = @_;
293    
294            my $last_visible_tags = $visible_tags;
295            $visible_tags = {};
296    
297            foreach my $tag ( @tags ) {
298                    if ( ! defined $last_visible_tags->{$tag} ) {
299                            if ( defined $tags_data->{$tag} ) {
300    #                               meteor( 'in-range', $tag );
301                            } else {
302                                    meteor( 'read', $tag );
303                                    read_tag( $tag );
304                            }
305                            $visible_tags->{$tag}++;
306                    } else {
307                            warn "## using cached data for $tag" if $debug;
308                  }                  }
309                    delete $last_visible_tags->{$tag}; # leave just missing tags
310    
311                    if ( -e "$program_path/$tag" ) {
312                                    meteor( 'write', $tag );
313                                    write_tag( $tag );
314                    }
315                    if ( -e "$secure_path/$tag" ) {
316                                    meteor( 'secure', $tag );
317                                    secure_tag( $tag );
318                    }
319            }
320    
321            foreach my $tag ( keys %$last_visible_tags ) {
322                    my $data = delete $tags_data->{$tag};
323                    print "removed tag $tag with data ",dump( $data ),"\n";
324                    meteor( 'removed', $tag );
325          }          }
 ) foreach ( 1 .. 100 );  
326    
327  my $read_cached;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
328    }
329    
330    my $tag_data_block;
331    
332    sub read_tag_data {
333            my ($start_block,$rest) = @_;
334            die "no rest?" unless $rest;
335    
336            my $last_block = 0;
337    
338            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
339            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
340            my $blocks = ord(substr($rest,8,1));
341            $rest = substr($rest,9); # leave just data blocks
342            foreach my $nr ( 0 .. $blocks - 1 ) {
343                    my $block = substr( $rest, $nr * 6, 6 );
344                    warn "## block ",as_hex( $block ) if $debug;
345                    my $ord   = unpack('v',substr( $block, 0, 2 ));
346                    my $expected_ord = $nr + $start_block;
347                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
348                    my $data  = substr( $block, 2 );
349                    die "data payload should be 4 bytes" if length($data) != 4;
350                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
351                    $tag_data_block->{$tag}->[ $ord ] = $data;
352                    $last_block = $ord;
353            }
354            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
355    
356            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
357            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
358    
359            return $last_block + 1;
360    }
361    
362    sub decode_tag {
363            my $tag = shift;
364    
365            my $data = $tags_data->{$tag} || die "no data for $tag";
366    
367            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
368            my $hash = {
369                    u1 => $u1,
370                    u2 => $u2,
371                    set => ( $set_item & 0xf0 ) >> 4,
372                    total => ( $set_item & 0x0f ),
373    
374                    type => $type,
375                    content => $content,
376    
377                    branch => $br_lib >> 20,
378                    library => $br_lib & 0x000fffff,
379    
380                    custom => $custom,
381            };
382    
383            return $hash;
384    }
385    
386  sub read_tag {  sub read_tag {
387          my ( $tag ) = @_;          my ( $tag ) = @_;
388    
389          return if $read_cached->{ $tag }++;          confess "no tag?" unless $tag;
390            
391          print "read_tag $tag\n";          print "read_tag $tag\n";
392    
393            my $start_block = 0;
394    
395            while ( $start_block < $max_rfid_block ) {
396    
397                    cmd(
398                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
399                                    "read $tag offset: $start_block blocks: $read_blocks",
400                            "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";
401                                    $start_block = read_tag_data( $start_block, @_ );
402                                    warn "# read tag upto $start_block\n";
403                            },
404                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
405                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
406                            },
407                    );
408    
409            }
410    
411            my $security;
412    
413          cmd(          cmd(
414                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag 1234", "check security $tag",
415                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
416                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
417                  },                          my $from_tag;
418                  "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) );
419                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
420                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
421                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          warn "# SECURITY $tag = $security\n";
                         my $blocks = ord(substr($rest,8,1));  
                         $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;  
                         }  
                         $read_cached->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $read_cached ), "\n";  
422                  }                  }
423          );          );
424    
425          #        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 ));
426  if (0) {  }
427          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
428    sub write_tag {
429          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00            my ($tag) = @_;
430          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
431          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";          my $path = "$program_path/$tag";
432    
433            my $data = read_file( $path );
434            my $hex_data;
435    
436            if ( $data =~ s{^hex\s+}{} ) {
437                    $hex_data = $data;
438                    $hex_data =~ s{\s+}{}g;
439            } else {
440    
441                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
442    
443                    my $max_len = $max_rfid_block * 4;
444    
445                    if ( length($data) > $max_len ) {
446                            $data = substr($data,0,$max_len);
447                            warn "strip content to $max_len bytes\n";
448                    }
449    
450                    $hex_data = unpack('H*', $data);
451            }
452    
453            my $len = length($hex_data) / 2;
454            # pad to block size
455            $hex_data .= '00' x ( 4 - $len % 4 );
456            my $blocks = sprintf('%02x', length($hex_data) / 4);
457    
458            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
459    
460            cmd(
461                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
462                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
463            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
464    
465            my $to = $path;
466            $to .= '.' . time();
467    
468            rename $path, $to;
469            print ">> $to\n";
470    
471            delete $tags_data->{$tag};      # force re-read of tag
472  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
473    
474    sub secure_tag {
475            my ($tag) = @_;
476    
477            my $path = "$secure_path/$tag";
478            my $data = substr(read_file( $path ),0,2);
479    
480            cmd(
481                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
482                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
483            );
484    
485            my $to = $path;
486            $to .= '.' . time();
487    
488            rename $path, $to;
489            print ">> $to\n";
490  }  }
491    
492  exit;  exit;
# Line 212  sub writechunk Line 521  sub writechunk
521  {  {
522          my $str=shift;          my $str=shift;
523          my $count = $port->write($str);          my $count = $port->write($str);
524            my $len = length($str);
525            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
526          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
527  }  }
528    
# Line 231  sub read_bytes { Line 542  sub read_bytes {
542          my $data = '';          my $data = '';
543          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
544                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
545                    die "no bytes on port: $!" unless defined $b;
546                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
547                  $data .= $b;                  $data .= $b;
548          }          }
# Line 277  sub crcccitt { Line 589  sub crcccitt {
589  sub checksum {  sub checksum {
590          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
591    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
592          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
593          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
594    
595          if ( $len_real != $len ) {          if ( $len_real != $len ) {
596                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
597                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
598          }          }
599    
600            my $xor = crcccitt( substr($bytes,1) ); # skip D6
601            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
602    
603          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
604                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
605                  return $bytes . $xor;                  return $bytes . $xor;
# Line 298  sub checksum { Line 610  sub checksum {
610  our $dispatch;  our $dispatch;
611    
612  sub readchunk {  sub readchunk {
613          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
614    
615          # read header of packet          # read header of packet
616          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 313  sub readchunk { Line 625  sub readchunk {
625          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
626          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
627    
628          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;
629    
630          $assert->{len}      = $len;          $assert->{len}      = $len;
631          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 327  sub readchunk { Line 639  sub readchunk {
639          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
640    
641          if ( defined $to ) {          if ( defined $to ) {
642                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
643                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
644                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
645          } else {          } else {
# Line 359  sub cmd { Line 671  sub cmd {
671          # fix checksum if needed          # fix checksum if needed
672          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
673    
674          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
675          $assert->{send} = $cmd;          $assert->{send} = $cmd;
676          writechunk( $bytes );          writechunk( $bytes );
677    
Legend:
Removed from v.20  
changed lines
  Added in v.46
  ViewVC Help
Powered by ViewVC 1.1.26