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