/[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 21 by dpavlin, Fri Oct 3 21:47:24 2008 UTC revision 63 by dpavlin, Thu Feb 11 10:52:14 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;
15    
16  my $debug = 0;  my $debug = 0;
17    
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $meteor_server; # = '192.168.1.13:4671';
23    my $meteor_fh;
24    
25    sub meteor {
26            my @a = @_;
27            push @a, scalar localtime() if $a[0] =~ m{^info};
28    
29            if ( ! defined $meteor_fh ) {
30                    if ( $meteor_fh =
31                                    IO::Socket::INET->new(
32                                            PeerAddr => $meteor_server,
33                                            Timeout => 1,
34                                    )
35                    ) {
36                            warn "# meteor connected to $meteor_server";
37                    } else {
38                            warn "can't connect to meteor $meteor_server: $!";
39                            $meteor_fh = 0;
40                    }
41            }
42    
43            if ( $meteor_fh ) {
44                    warn ">> meteor ",dump( @a );
45                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
46            }
47    }
48    
49    my $listen_port = 9000;                  # pick something not in use
50    my $server_url  = "http://localhost:$listen_port";
51    
52    sub http_server {
53    
54            my $server = IO::Socket::INET->new(
55                    Proto     => 'tcp',
56                    LocalPort => $listen_port,
57                    Listen    => SOMAXCONN,
58                    Reuse     => 1
59            );
60                                                                      
61            die "can't setup server" unless $server;
62    
63            print "Server $0 ready at $server_url\n";
64    
65            sub static {
66                    my ($client,$path) = @_;
67    
68                    $path = "www/$path";
69                    $path .= 'rfid.html' if $path =~ m{/$};
70    
71                    return unless -e $path;
72    
73                    my $type = 'text/plain';
74                    $type = 'text/html' if $path =~ m{\.htm};
75                    $type = 'application/javascript' if $path =~ m{\.js};
76    
77                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
78                    open(my $html, $path);
79                    while(<$html>) {
80                            print $client $_;
81                    }
82                    close($html);
83    
84                    return $path;
85            }
86    
87            while (my $client = $server->accept()) {
88                    $client->autoflush(1);
89                    my $request = <$client>;
90    
91                    warn "WEB << $request\n" if $debug;
92    
93                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
94                            my $method = $1;
95                            my $param;
96                            if ( $method =~ s{\?(.+)}{} ) {
97                                    foreach my $p ( split(/[&;]/, $1) ) {
98                                            my ($n,$v) = split(/=/, $p, 2);
99                                            $param->{$n} = $v;
100                                    }
101                                    warn "WEB << param: ",dump( $param ) if $debug;
102                            }
103                            if ( my $path = static( $client,$1 ) ) {
104                                    warn "WEB >> $path" if $debug;
105                            } elsif ( $method =~ m{/scan} ) {
106                                    my $tags = scan_for_tags();
107                                    my $json = { time => time() };
108                                    map {
109                                            my $d = decode_tag($_);
110                                            $d->{sid} = $_;
111                                            $d->{security} = $tags_security->{$_};
112                                            push @{ $json->{tags} },  $d;
113                                    } keys %$tags;
114                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
115                                            $param->{callback}, "(", to_json($json), ")\r\n";
116                            } elsif ( $method =~ m{/program} ) {
117    
118                                    my $status = 501; # Not implementd
119    
120                                    foreach my $p ( keys %$param ) {
121                                            next unless $p =~ m/^tag_(\S+)/;
122                                            my $tag = $1;
123                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
124                                            $content = "\x00" if $param->{$p} eq 'blank';
125                                            $status = 302;
126    
127                                            warn "PROGRAM $tag $content\n";
128                                            write_tag( $tag, $content );
129                                    }
130    
131                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
132    
133                            } else {
134                                    print $client "HTTP/1.0 404 Unkown method\r\n";
135                            }
136                    } else {
137                            print $client "HTTP/1.0 500 No method\r\n";
138                    }
139                    close $client;
140            }
141    
142            die "server died";
143    }
144    
145    
146    my $last_message = {};
147    sub _message {
148            my $type = shift @_;
149            my $text = join(' ',@_);
150            my $last = $last_message->{$type};
151            if ( $text ne $last ) {
152                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
153                    $last_message->{$type} = $text;
154            }
155    }
156    
157    sub _log { _message('log',@_) };
158    sub diag { _message('diag',@_) };
159    
160  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
161  my $baudrate  = "19200";  my $baudrate  = "19200";
162  my $databits  = "8";  my $databits  = "8";
# Line 17  my $parity       = "none"; Line 164  my $parity       = "none";
164  my $stopbits  = "1";  my $stopbits  = "1";
165  my $handshake = "none";  my $handshake = "none";
166    
167    my $program_path = './program/';
168    my $secure_path = './secure/';
169    
170    # http server
171    my $http_server = 1;
172    
173    # 3M defaults: 8,4
174    my $max_rfid_block = 16;
175    my $read_blocks = 8;
176    
177  my $response = {  my $response = {
178          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
179          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 30  my $response = { Line 187  my $response = {
187  };  };
188    
189  GetOptions(  GetOptions(
190          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
191          'device=s'    => \$device,          'device=s'    => \$device,
192          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
193          'databits=i'  => \$databits,          'databits=i'  => \$databits,
194          'parity=s'    => \$parity,          'parity=s'    => \$parity,
195          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
196          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
197            'meteor=s'    => \$meteor_server,
198            'http-server!' => \$http_server,
199  ) or die $!;  ) or die $!;
200    
201    my $verbose = $debug > 0 ? $debug-- : 0;
202    
203  =head1 NAME  =head1 NAME
204    
205  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 231  it under the same terms ans Perl itself.
231    
232  =cut  =cut
233    
234  my $tags_data;  my $item_type = {
235  my $visible_tags;          1 => 'Book',
236            6 => 'CD/CD ROM',
237            2 => 'Magazine',
238            13 => 'Book with Audio Tape',
239            9 => 'Book with CD/CD ROM',
240            0 => 'Other',
241    
242            5 => 'Video',
243            4 => 'Audio Tape',
244            3 => 'Bound Journal',
245            8 => 'Book with Diskette',
246            7 => 'Diskette',
247    };
248    
249    warn "## known item type: ",dump( $item_type ) if $debug;
250    
251  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";
252  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
# Line 81  $databits=$port->databits($databits); Line 256  $databits=$port->databits($databits);
256  $parity=$port->parity($parity);  $parity=$port->parity($parity);
257  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
258    
259  print "## using $device $baudrate $databits $parity $stopbits\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
260    
261  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
262  $port->lookclear();  $port->lookclear();
# Line 96  $port->read_char_time(5); Line 271  $port->read_char_time(5);
271    
272  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
273       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
274          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
275            print "hardware version $hw_ver\n";
276            meteor( 'info', "Found reader hardware $hw_ver" );
277  });  });
278    
279  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?',
280       '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() }  );
281    
282  # start scanning for tags  sub scan_for_tags {
283    
284  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 ) );  
285    
286                  if ( ! $nr ) {          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
287                          print "no tags in range\n";                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
288                  } else {                          my $rest = shift || die "no rest?";
289                            my $nr = ord( substr( $rest, 0, 1 ) );
290    
291                            if ( ! $nr ) {
292                                    _log "no tags in range\n";
293                                    update_visible_tags();
294                                    meteor( 'info-none-in-range' );
295                                    $tags_data = {};
296                            } else {
297    
298                                    my $tags = substr( $rest, 1 );
299                                    my $tl = length( $tags );
300                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
301    
302                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
303                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
304                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
305    
306                                    meteor( 'info-in-range', join(' ',@tags));
307    
308                                    update_visible_tags( @tags );
309                            }
310                    }
311            );
312    
313            diag "tags: ",dump( @tags );
314            return $tags_data;
315    
316    }
317    
318                          my $tags = substr( $rest, 1 );  # start scanning for tags
319    
320    if ( $http_server ) {
321            http_server;
322    } else {
323            while (1) {
324                    scan_for_tags;
325                    sleep 1;
326            }
327    }
328    
329                          my $tl = length( $tags );  die "over and out";
                         die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;  
330    
331                          my @tags;  sub update_visible_tags {
332                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );          my @tags = @_;
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
333    
334                          my $removed_tags = $visible_tags;          my $last_visible_tags = $visible_tags;
335                          $visible_tags = {};          $visible_tags = {};
336    
337                          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
338                                  next if $visible_tags->{$tag}++;                  $visible_tags->{$tag}++;
339                    if ( ! defined $last_visible_tags->{$tag} ) {
340                            if ( defined $tags_data->{$tag} ) {
341    #                               meteor( 'in-range', $tag );
342                            } else {
343                                    meteor( 'read', $tag );
344                                  read_tag( $tag );                                  read_tag( $tag );
                                 if ( delete $removed_tags->{$tag} ) {  
                                         print "removed tag $tag\n";  
                                 }  
345                          }                          }
346                    } else {
347                            warn "## using cached data for $tag" if $debug;
348                    }
349                    delete $last_visible_tags->{$tag}; # leave just missing tags
350    
351                    if ( -e "$program_path/$tag" ) {
352                                    meteor( 'write', $tag );
353                                    write_tag( $tag );
354                    }
355                    if ( -e "$secure_path/$tag" ) {
356                                    meteor( 'secure', $tag );
357                                    secure_tag( $tag );
358                  }                  }
359          }          }
360  ) foreach ( 1 .. 100 );  
361            foreach my $tag ( keys %$last_visible_tags ) {
362                    my $data = delete $tags_data->{$tag};
363                    print "removed tag $tag with data ",dump( $data ),"\n";
364                    meteor( 'removed', $tag );
365            }
366    
367            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
368    }
369    
370    my $tag_data_block;
371    
372    sub read_tag_data {
373            my ($start_block,$rest) = @_;
374            die "no rest?" unless $rest;
375    
376            my $last_block = 0;
377    
378            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
379            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
380            my $blocks = ord(substr($rest,8,1));
381            $rest = substr($rest,9); # leave just data blocks
382            foreach my $nr ( 0 .. $blocks - 1 ) {
383                    my $block = substr( $rest, $nr * 6, 6 );
384                    warn "## block ",as_hex( $block ) if $debug;
385                    my $ord   = unpack('v',substr( $block, 0, 2 ));
386                    my $expected_ord = $nr + $start_block;
387                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
388                    my $data  = substr( $block, 2 );
389                    die "data payload should be 4 bytes" if length($data) != 4;
390                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
391                    $tag_data_block->{$tag}->[ $ord ] = $data;
392                    $last_block = $ord;
393            }
394            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
395    
396            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
397            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
398    
399            return $last_block + 1;
400    }
401    
402    my $saved_in_log;
403    
404    sub decode_tag {
405            my $tag = shift;
406    
407            my $data = $tags_data->{$tag} || die "no data for $tag";
408    
409            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
410            my $hash = {
411                    u1 => $u1,
412                    u2 => $u2,
413                    set => ( $set_item & 0xf0 ) >> 4,
414                    total => ( $set_item & 0x0f ),
415    
416                    type => $type,
417                    content => $content,
418    
419                    branch => $br_lib >> 20,
420                    library => $br_lib & 0x000fffff,
421    
422                    custom => $custom,
423            };
424    
425            if ( ! $saved_in_log->{$tag}++ ) {
426                    open(my $log, '>>', 'rfid-log.txt');
427                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
428                    close($log);
429            }
430    
431            return $hash;
432    }
433    
434  sub read_tag {  sub read_tag {
435          my ( $tag ) = @_;          my ( $tag ) = @_;
436    
437            confess "no tag?" unless $tag;
438    
439          print "read_tag $tag\n";          print "read_tag $tag\n";
440    
441            my $start_block = 0;
442    
443            while ( $start_block < $max_rfid_block ) {
444    
445                    cmd(
446                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
447                                    "read $tag offset: $start_block blocks: $read_blocks",
448                            "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";
449                                    $start_block = read_tag_data( $start_block, @_ );
450                                    warn "# read tag upto $start_block\n";
451                            },
452                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
453                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
454                            },
455                    );
456    
457            }
458    
459            my $security;
460    
461          cmd(          cmd(
462                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag 1234", "check security $tag",
463                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
464                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
465                  },                          my $from_tag;
466                  "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) );
467                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
468                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
469                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          $tags_security->{$tag} = $security;
470                          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";  
471                  }                  }
472          );          );
473    
474          #        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";  
475  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
476    
477    sub write_tag {
478            my ($tag,$data) = @_;
479    
480            my $path = "$program_path/$tag";
481            $data = read_file( $path ) if -e $path;
482    
483            die "no data" unless $data;
484    
485            my $hex_data;
486    
487            if ( $data =~ s{^hex\s+}{} ) {
488                    $hex_data = $data;
489                    $hex_data =~ s{\s+}{}g;
490            } else {
491    
492                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
493    
494                    my $max_len = $max_rfid_block * 4;
495    
496                    if ( length($data) > $max_len ) {
497                            $data = substr($data,0,$max_len);
498                            warn "strip content to $max_len bytes\n";
499                    }
500    
501                    $hex_data = unpack('H*', $data);
502            }
503    
504            my $len = length($hex_data) / 2;
505            # pad to block size
506            $hex_data .= '00' x ( 4 - $len % 4 );
507            my $blocks = sprintf('%02x', length($hex_data) / 4);
508    
509            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
510    
511            cmd(
512                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
513                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
514            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
515    
516            my $to = $path;
517            $to .= '.' . time();
518    
519            rename $path, $to;
520            print ">> $to\n";
521    
522            # force re-read of tag
523            delete $tags_data->{$tag};
524            delete $visible_tags->{$tag};
525    }
526    
527    sub secure_tag {
528            my ($tag) = @_;
529    
530            my $path = "$secure_path/$tag";
531            my $data = substr(read_file( $path ),0,2);
532    
533            cmd(
534                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
535                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
536            );
537    
538            my $to = $path;
539            $to .= '.' . time();
540    
541            rename $path, $to;
542            print ">> $to\n";
543  }  }
544    
545  exit;  exit;
# Line 219  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 238  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 284  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";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
658                  return $bytes . $xor;                  return $bytes . $xor;
# Line 305  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 320  sub readchunk { Line 678  sub readchunk {
678          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
679          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
680    
681          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;
682    
683          $assert->{len}      = $len;          $assert->{len}      = $len;
684          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 334  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";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
700          }          }
701    
702          return $data;          return $data;
# Line 366  sub cmd { Line 724  sub cmd {
724          # fix checksum if needed          # fix checksum if needed
725          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
726    
727          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
728          $assert->{send} = $cmd;          $assert->{send} = $cmd;
729          writechunk( $bytes );          writechunk( $bytes );
730    
Legend:
Removed from v.21  
changed lines
  Added in v.63
  ViewVC Help
Powered by ViewVC 1.1.26