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