/[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 29 by dpavlin, Mon Apr 6 13:10:40 2009 UTC revision 68 by dpavlin, Thu Feb 11 15:10:39 2010 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  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;  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_server = '192.168.1.13:4671';  my $debug = 0;
17  my $meteor_fh;  
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  sub meteor {                  return unless -e $path;
45          my @a = @_;  
46          push @a, scalar localtime() if $a[0] =~ m{^info};                  my $type = 'text/plain';
47                    $type = 'text/html' if $path =~ m{\.htm};
48          if ( ! defined $meteor_fh ) {                  $type = 'application/javascript' if $path =~ m{\.js};
49                  warn "# open connection to $meteor_server";  
50                  $meteor_fh = IO::Socket::INET->new(                  print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                                  PeerAddr => $meteor_server,                  open(my $html, $path);
52                                  Timeout => 1,                  while(<$html>) {
53                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                          print $client $_;
54                  $meteor_fh = 0; # don't try again                  }
55                    close($html);
56    
57                    return $path;
58          }          }
59    
60          warn ">> meteor ",dump( @a );          while (my $client = $server->accept()) {
61          print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;                  $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 41  my $stopbits  = "1"; Line 155  my $stopbits  = "1";
155  my $handshake = "none";  my $handshake = "none";
156    
157  my $program_path = './program/';  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?',
# Line 62  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          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
188  ) or die $!;  ) or die $!;
189    
190  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 98  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 109  $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 126  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( 'info', "Found reader hardware $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( 'info-none-in-range' );  
                         $tags_data = {};  
                 } 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                            if ( ! $nr ) {
280                                    _log "no tags in range\n";
281                                    update_visible_tags();
282                                    $tags_data = {};
283                            } else {
284    
285                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
286                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  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                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
299            return $tags_data;
300    
301                          update_visible_tags( @tags );  }
                 }  
         }  
 ) while(1);  
 #) foreach ( 1 .. 100 );  
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 173  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                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
326  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
327                          } else {                          } else {
                                 meteor( 'read', $tag );  
328                                  read_tag( $tag );                                  read_tag( $tag );
329                          }                          }
                         $visible_tags->{$tag}++;  
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" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
336                                  write_tag( $tag );                                  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), $/;
                 meteor( 'removed', $tag );  
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;
# Line 206  my $tag_data_block; Line 353  my $tag_data_block;
353  sub read_tag_data {  sub read_tag_data {
354          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
355          die "no rest?" unless $rest;          die "no rest?" unless $rest;
356    
357            my $last_block = 0;
358    
359          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
360          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
361          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 215  sub read_tag_data { Line 365  sub read_tag_data {
365                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
366                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
367                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
368                  die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;                  warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
369                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
370                  die "data payload should be 4 bytes" if length($data) != 4;                  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;                  warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
372                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
373                    $last_block = $ord;
374          }          }
375          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
376          print "DATA $tag ",dump( $tags_data ), "\n";  
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 {
# Line 232  sub read_tag { Line 425  sub read_tag {
425    
426          print "read_tag $tag\n";          print "read_tag $tag\n";
427    
428          cmd(          my $start_block = 0;
429                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",  
430                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {          while ( $start_block < $max_rfid_block ) {
431                          print "FIXME: tag $tag ready?\n";  
432                  },                  cmd(
433                  "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";                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
434                          read_tag_data( 0, @_ );                                  "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   03   04     3970", "read $tag offset: 3 blocks: 4",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
450                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    "D6 00 0D 0A 00", sub {
451                          read_tag_data( 3, @_ );                          my $rest = shift;
452                            my $from_tag;
453                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
454                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
455                            $security = as_hex( $security );
456                            $tags_security->{$tag} = $security;
457                            warn "# SECURITY $tag = $security\n";
458                  }                  }
459          );          );
460    
461            print "TAG $tag ", dump(decode_tag( $tag ));
462  }  }
463    
464  sub write_tag {  sub write_tag {
465          my ($tag) = @_;          my ($tag,$data) = @_;
466    
467          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
468            $data = read_file( $path ) if -e $path;
469    
470          my $data = read_file( $path );          die "no data" unless $data;
471    
472          print "write_tag $tag = $data\n";          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(          cmd(
499                  "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
500                  "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
501          ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
502    
503          my $to = $path;          my $to = $path;
504          $to .= '.' . time();          $to .= '.' . time();
# Line 271  sub write_tag { Line 506  sub write_tag {
506          rename $path, $to;          rename $path, $to;
507          print ">> $to\n";          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            forget_tag $tag;
521    }
522    
523    sub secure_tag {
524            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 305  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 371  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 392  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 421  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.29  
changed lines
  Added in v.68
  ViewVC Help
Powered by ViewVC 1.1.26