/[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 45 by dpavlin, Tue Jun 23 13:29:10 2009 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    
13    use IO::Socket::INET;
14    
15    my $meteor_server = '192.168.1.13:4671';
16    my $meteor_fh;
17    
18    sub meteor {
19            my @a = @_;
20            push @a, scalar localtime() if $a[0] =~ m{^info};
21    
22            if ( ! defined $meteor_fh ) {
23                    if ( $meteor_fh =
24                                    IO::Socket::INET->new(
25                                            PeerAddr => $meteor_server,
26                                            Timeout => 1,
27                                    )
28                    ) {
29                            warn "# meteor connected to $meteor_server";
30                    } else {
31                            warn "can't connect to meteor $meteor_server: $!";
32                            $meteor_fh = 0;
33                    }
34            }
35    
36            if ( $meteor_fh ) {
37                    warn ">> meteor ",dump( @a );
38                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
39            }
40    }
41    
42    my $listen_port = 9000;                  # pick something not in use
43    sub http_server {
44    
45            my $server = IO::Socket::INET->new(
46                    Proto     => 'tcp',
47                    LocalPort => $listen_port,
48                    Listen    => SOMAXCONN,
49                    Reuse     => 1
50            );
51                                                                      
52            die "can't setup server" unless $server;
53    
54            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
55    
56            sub static {
57                    my ($client,$path) = @_;
58    
59                    $path = "www/$path";
60    
61                    return unless -e $path;
62    
63                    my $type = 'text/plain';
64                    $type = 'text/html' if $path =~ m{\.htm};
65                    $type = 'application/javascript' if $path =~ m{\.js};
66    
67                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
68                    open(my $html, $path);
69                    while(<$html>) {
70                            print $client $_;
71                    }
72                    close($html);
73    
74                    return $path;
75            }
76    
77            while (my $client = $server->accept()) {
78                    $client->autoflush(1);
79                    my $request = <$client>;
80    
81                    warn "<< $request\n";
82    
83                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
84                            my $method = $1;
85                            if ( my $path = static( $client,$1 ) ) {
86                                    warn ">> $path";
87                            } elsif ( $method =~ m{/scan} ) {
88                                    my $callback = $1 if $method =~ m{\?callback=([^&;]+)};
89                                    my $tags = scan_for_tags();
90                                    my $json;
91                                    map {
92                                            my $d = decode_tag($_);
93                                            $d->{sid} = $_;
94                                            push @{ $json->{tags} },  $d;
95                                    } keys %$tags;
96                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n$callback(", to_json($json), ")\r\n";
97                            } else {
98                                    print $client "HTTP/1.0 404 Unkown method\r\n";
99                            }
100                    } else {
101                            print $client "HTTP/1.0 500 No method\r\n";
102                    }
103                    close $client;
104            }
105    
106            die "server died";
107    }
108    
109  my $debug = 0;  my $debug = 0;
110    
# Line 17  my $parity       = "none"; Line 115  my $parity       = "none";
115  my $stopbits  = "1";  my $stopbits  = "1";
116  my $handshake = "none";  my $handshake = "none";
117    
118    my $program_path = './program/';
119    my $secure_path = './secure/';
120    
121    # http server
122    my $http_server = 1;
123    
124    # 3M defaults: 8,4
125    my $max_rfid_block = 16;
126    my $read_blocks = 8;
127    
128  my $response = {  my $response = {
129          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
130          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 30  my $response = { Line 138  my $response = {
138  };  };
139    
140  GetOptions(  GetOptions(
141          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
142          'device=s'    => \$device,          'device=s'    => \$device,
143          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
144          'databits=i'  => \$databits,          'databits=i'  => \$databits,
145          'parity=s'    => \$parity,          'parity=s'    => \$parity,
146          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
147          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
148            'meteor=s'    => \$meteor_server,
149            'http-server!' => \$http_server,
150  ) or die $!;  ) or die $!;
151    
152    my $verbose = $debug > 0 ? $debug-- : 0;
153    
154  =head1 NAME  =head1 NAME
155    
156  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 182  it under the same terms ans Perl itself.
182    
183  =cut  =cut
184    
185    my $tags_data;
186    my $visible_tags;
187    
188    my $item_type = {
189            1 => 'Book',
190            6 => 'CD/CD ROM',
191            2 => 'Magazine',
192            13 => 'Book with Audio Tape',
193            9 => 'Book with CD/CD ROM',
194            0 => 'Other',
195    
196            5 => 'Video',
197            4 => 'Audio Tape',
198            3 => 'Bound Journal',
199            8 => 'Book with Diskette',
200            7 => 'Diskette',
201    };
202    
203    warn "## known item type: ",dump( $item_type ) if $debug;
204    
205  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";
206  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
207  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 78  $databits=$port->databits($databits); Line 210  $databits=$port->databits($databits);
210  $parity=$port->parity($parity);  $parity=$port->parity($parity);
211  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
212    
213  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
214    
215  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
216  $port->lookclear();  $port->lookclear();
# Line 91  $port->read_char_time(5); Line 223  $port->read_char_time(5);
223    
224  # initial hand-shake with device  # initial hand-shake with device
225    
226  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
227       '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 {
228          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
229            print "hardware version $hw_ver\n";
230            meteor( 'info', "Found reader hardware $hw_ver" );
231  });  });
232    
233  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?',
234       '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() }  );
235    
236  # start scanning for tags  sub scan_for_tags {
237    
238            my @tags;
239    
240  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
241       '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 {  
242                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
243                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
                         my $tags = substr( $rest, 1 );  
244    
245                          my $tl = length( $tags );                          if ( ! $nr ) {
246                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  print "no tags in range\n";
247                                    update_visible_tags();
248                                    meteor( 'info-none-in-range' );
249                                    $tags_data = {};
250                            } else {
251    
252                          my @tags;                                  my $tags = substr( $rest, 1 );
                         push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );  
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
253    
254                          # read data from tag                                  my $tl = length( $tags );
255                          read_tag( $_ ) foreach @tags;                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
256    
257                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
258                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
259                                    print "$nr tags in range: ", join(',', @tags ) , "\n";
260    
261                                    meteor( 'info-in-range', join(' ',@tags));
262    
263                                    update_visible_tags( @tags );
264                            }
265                  }                  }
266  ) }          );
267    
268            warn "## tags: ",dump( @tags );
269            return $tags_data;
270    
271    }
272    
273    # start scanning for tags
274    
275    if ( $http_server ) {
276            http_server;
277    } else {
278            scan_for_tags while 1;
279    }
280    
281    die "over and out";
282    
283    sub update_visible_tags {
284            my @tags = @_;
285    
286            my $last_visible_tags = $visible_tags;
287            $visible_tags = {};
288    
289            foreach my $tag ( @tags ) {
290                    if ( ! defined $last_visible_tags->{$tag} ) {
291                            if ( defined $tags_data->{$tag} ) {
292    #                               meteor( 'in-range', $tag );
293                            } else {
294                                    meteor( 'read', $tag );
295                                    read_tag( $tag );
296                            }
297                            $visible_tags->{$tag}++;
298                    } else {
299                            warn "## using cached data for $tag" if $debug;
300                    }
301                    delete $last_visible_tags->{$tag}; # leave just missing tags
302    
303                    if ( -e "$program_path/$tag" ) {
304                                    meteor( 'write', $tag );
305                                    write_tag( $tag );
306                    }
307                    if ( -e "$secure_path/$tag" ) {
308                                    meteor( 'secure', $tag );
309                                    secure_tag( $tag );
310                    }
311            }
312    
313            foreach my $tag ( keys %$last_visible_tags ) {
314                    my $data = delete $tags_data->{$tag};
315                    print "removed tag $tag with data ",dump( $data ),"\n";
316                    meteor( 'removed', $tag );
317            }
318    
319            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
320    }
321    
322    my $tag_data_block;
323    
324    sub read_tag_data {
325            my ($start_block,$rest) = @_;
326            die "no rest?" unless $rest;
327    
328            my $last_block = 0;
329    
330            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
331            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
332            my $blocks = ord(substr($rest,8,1));
333            $rest = substr($rest,9); # leave just data blocks
334            foreach my $nr ( 0 .. $blocks - 1 ) {
335                    my $block = substr( $rest, $nr * 6, 6 );
336                    warn "## block ",as_hex( $block ) if $debug;
337                    my $ord   = unpack('v',substr( $block, 0, 2 ));
338                    my $expected_ord = $nr + $start_block;
339                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
340                    my $data  = substr( $block, 2 );
341                    die "data payload should be 4 bytes" if length($data) != 4;
342                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
343                    $tag_data_block->{$tag}->[ $ord ] = $data;
344                    $last_block = $ord;
345            }
346            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
347    
348            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
349            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
350    
351            return $last_block + 1;
352    }
353    
354    sub decode_tag {
355            my $tag = shift;
356    
357            my $data = $tags_data->{$tag} || die "no data for $tag";
358    
359            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
360            my $hash = {
361                    u1 => $u1,
362                    u2 => $u2,
363                    set => ( $set_item & 0xf0 ) >> 4,
364                    total => ( $set_item & 0x0f ),
365    
366                    type => $type,
367                    content => $content,
368    
369  ) foreach ( 1 .. 100 );                  branch => $br_lib >> 20,
370                    library => $br_lib & 0x000fffff,
371    
372  my $read_cached;                  custom => $custom,
373            };
374    
375            return $hash;
376    }
377    
378  sub read_tag {  sub read_tag {
379          my ( $tag ) = @_;          my ( $tag ) = @_;
380    
381            confess "no tag?" unless $tag;
382    
383          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
384    
385          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          my $start_block = 0;
386                          "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {  
387  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 ) {
388                          my $rest = shift || die "no rest?";  
389                          warn "## DATA ", dump( $rest ) if $debug;                  cmd(
390                          my $blocks = ord(substr($rest,0,1));                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
391                          my @data;                                  "read $tag offset: $start_block blocks: $read_blocks",
392                          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";
393                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  $start_block = read_tag_data( $start_block, @_ );
394                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "# read tag upto $start_block\n";
395                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                          },
396                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;                          "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
397                                  my $data  = substr( $block, 2 );                                  print "FIXME: tag $tag ready? (expected block read instead)\n";
398                                  die "data payload should be 4 bytes" if length($data) != 4;                          },
399                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  );
400                                  $data[ $ord ] = $data;  
401                          }          }
402                          $read_cached->{ $tag } = join('', @data);  
403                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";          my $security;
404                  })  
405          });          cmd(
406                    "D6 00 0B 0A $tag 1234", "check security $tag",
407          #        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 {
408  if (0) {                          my $rest = shift;
409          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );                          my $from_tag;
410                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
411          #        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 );
412          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          $security = as_hex( $security );
413          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";                          warn "# SECURITY $tag = $security\n";
414                    }
415            );
416    
417            print "TAG $tag ", dump(decode_tag( $tag ));
418  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
419    
420    sub write_tag {
421            my ($tag) = @_;
422    
423            my $path = "$program_path/$tag";
424    
425            my $data = read_file( $path );
426            my $hex_data;
427    
428            if ( $data =~ s{^hex\s+}{} ) {
429                    $hex_data = $data;
430                    $hex_data =~ s{\s+}{}g;
431            } else {
432    
433                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
434    
435                    my $max_len = $max_rfid_block * 4;
436    
437                    if ( length($data) > $max_len ) {
438                            $data = substr($data,0,$max_len);
439                            warn "strip content to $max_len bytes\n";
440                    }
441    
442                    $hex_data = unpack('H*', $data);
443            }
444    
445            my $len = length($hex_data) / 2;
446            # pad to block size
447            $hex_data .= '00' x ( 4 - $len % 4 );
448            my $blocks = sprintf('%02x', length($hex_data) / 4);
449    
450            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
451    
452            cmd(
453                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
454                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
455            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
456    
457            my $to = $path;
458            $to .= '.' . time();
459    
460            rename $path, $to;
461            print ">> $to\n";
462    
463            delete $tags_data->{$tag};      # force re-read of tag
464    }
465    
466    sub secure_tag {
467            my ($tag) = @_;
468    
469            my $path = "$secure_path/$tag";
470            my $data = substr(read_file( $path ),0,2);
471    
472            cmd(
473                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
474                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
475            );
476    
477            my $to = $path;
478            $to .= '.' . time();
479    
480            rename $path, $to;
481            print ">> $to\n";
482  }  }
483    
484  exit;  exit;
# Line 200  sub writechunk Line 513  sub writechunk
513  {  {
514          my $str=shift;          my $str=shift;
515          my $count = $port->write($str);          my $count = $port->write($str);
516            my $len = length($str);
517            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
518          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
519  }  }
520    
# Line 219  sub read_bytes { Line 534  sub read_bytes {
534          my $data = '';          my $data = '';
535          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
536                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
537                    die "no bytes on port: $!" unless defined $b;
538                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
539                  $data .= $b;                  $data .= $b;
540          }          }
# Line 248  sub assert { Line 564  sub assert {
564          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
565  }  }
566    
 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;  
         }  
 }  
   
567  use Digest::CRC;  use Digest::CRC;
568    
569  sub crcccitt {  sub crcccitt {
# Line 286  sub crcccitt { Line 581  sub crcccitt {
581  sub checksum {  sub checksum {
582          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
583    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
584          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
585          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
586    
587          if ( $len_real != $len ) {          if ( $len_real != $len ) {
588                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
589                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
590          }          }
591    
592            my $xor = crcccitt( substr($bytes,1) ); # skip D6
593            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
594    
595          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
596                  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";
597                  return $bytes . $xor;                  return $bytes . $xor;
# Line 304  sub checksum { Line 599  sub checksum {
599          return $bytes . $checksum;          return $bytes . $checksum;
600  }  }
601    
602  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
603    
604          sleep 1;        # FIXME remove  sub readchunk {
605    #       sleep 1;        # FIXME remove
606    
607          # read header of packet          # read header of packet
608          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 320  sub readchunk { Line 615  sub readchunk {
615          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
616    
617          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
618          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
619    
620          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;
621    
622          $assert->{len}      = $len;          $assert->{len}      = $len;
623          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
624    
625          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
626            # find longest match for incomming data
627            my ($to) = grep {
628                    my $match = substr($payload,0,length($_));
629                    m/^\Q$match\E/
630            } sort { length($a) <=> length($b) } keys %$dispatch;
631            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
632    
633            if ( defined $to ) {
634                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
635                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
636                    $dispatch->{ $to }->( $rest );
637            } else {
638                    print "NO DISPATCH for ",dump( $full ),"\n";
639            }
640    
641          return $data;          return $data;
642  }  }
# Line 345  sub str2bytes { Line 654  sub str2bytes {
654  }  }
655    
656  sub cmd {  sub cmd {
657          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
658            my $cmd_desc = shift || confess "no description?";
659            my @expect = @_;
660    
661          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
662    
663          # fix checksum if needed          # fix checksum if needed
664          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
665    
666          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
667          $assert->{send} = $cmd;          $assert->{send} = $cmd;
668          writechunk( $bytes );          writechunk( $bytes );
669    
670          if ( $expect ) {          while ( @expect ) {
671                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
672                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
673                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
674    
675                    next if defined $dispatch->{ $pattern };
676    
677                    $dispatch->{ substr($pattern,3) } = $coderef;
678                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
679          }          }
680    
681            readchunk;
682  }  }
683    
Legend:
Removed from v.19  
changed lines
  Added in v.45
  ViewVC Help
Powered by ViewVC 1.1.26