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