/[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 18 by dpavlin, Fri Oct 3 12:31:58 2008 UTC revision 46 by dpavlin, Tue Jun 23 13:50:13 2009 UTC
# Line 6  use warnings; Line 6  use warnings;
6    
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9    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                            my $param;
86                            if ( $method =~ s{\?(.+)}{} ) {
87                                    foreach my $p ( split(/[&;]/, $1) ) {
88                                            my ($n,$v) = split(/=/, $p, 2);
89                                            $param->{$n} = $v;
90                                    }
91                                    warn "<< param: ",dump( $param );
92                            }
93                            if ( my $path = static( $client,$1 ) ) {
94                                    warn ">> $path";
95                            } elsif ( $method =~ m{/scan} ) {
96                                    my $tags = scan_for_tags();
97                                    my $json = {};
98                                    map {
99                                            my $d = decode_tag($_);
100                                            $d->{sid} = $_;
101                                            push @{ $json->{tags} },  $d;
102                                    } keys %$tags;
103                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
104                                            $param->{callback}, "(", to_json($json), ")\r\n";
105                            } else {
106                                    print $client "HTTP/1.0 404 Unkown method\r\n";
107                            }
108                    } else {
109                            print $client "HTTP/1.0 500 No method\r\n";
110                    }
111                    close $client;
112            }
113    
114            die "server died";
115    }
116    
117  my $debug = 0;  my $debug = 0;
118    
119    my $device    = "/dev/ttyUSB0";
120    my $baudrate  = "19200";
121    my $databits  = "8";
122    my $parity        = "none";
123    my $stopbits  = "1";
124    my $handshake = "none";
125    
126    my $program_path = './program/';
127    my $secure_path = './secure/';
128    
129    # http server
130    my $http_server = 1;
131    
132    # 3M defaults: 8,4
133    my $max_rfid_block = 16;
134    my $read_blocks = 8;
135    
136  my $response = {  my $response = {
137          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
138          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 145  my $response = {
145          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
146  };  };
147    
148    GetOptions(
149            'd|debug+'    => \$debug,
150            'device=s'    => \$device,
151            'baudrate=i'  => \$baudrate,
152            'databits=i'  => \$databits,
153            'parity=s'    => \$parity,
154            'stopbits=i'  => \$stopbits,
155            'handshake=s' => \$handshake,
156            'meteor=s'    => \$meteor_server,
157            'http-server!' => \$http_server,
158    ) or die $!;
159    
160    my $verbose = $debug > 0 ? $debug-- : 0;
161    
162  =head1 NAME  =head1 NAME
163    
164  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
165    
166  =head1 SYNOPSIS  =head1 SYNOPSIS
167    
168  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
169    
170  =head1 DESCRIPTION  =head1 DESCRIPTION
171    
# Line 52  it under the same terms ans Perl itself. Line 190  it under the same terms ans Perl itself.
190    
191  =cut  =cut
192    
193  # your serial port.  my $tags_data;
194  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
195  $device    ||= "/dev/ttyUSB0";  
196  $baudrate  ||= "19200";  my $item_type = {
197  $databits  ||= "8";          1 => 'Book',
198  $parity    ||= "none";          6 => 'CD/CD ROM',
199  $stopbits  ||= "1";          2 => 'Magazine',
200  $handshake ||= "none";          13 => 'Book with Audio Tape',
201            9 => 'Book with CD/CD ROM',
202            0 => 'Other',
203    
204            5 => 'Video',
205            4 => 'Audio Tape',
206            3 => 'Bound Journal',
207            8 => 'Book with Diskette',
208            7 => 'Diskette',
209    };
210    
211    warn "## known item type: ",dump( $item_type ) if $debug;
212    
213  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
214    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
215  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
216  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
217  $databits=$port->databits($databits);  $databits=$port->databits($databits);
218  $parity=$port->parity($parity);  $parity=$port->parity($parity);
219  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
220    
221  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
222    
223  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
224  $port->lookclear();  $port->lookclear();
# Line 81  $port->read_char_time(5); Line 231  $port->read_char_time(5);
231    
232  # initial hand-shake with device  # initial hand-shake with device
233    
234  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
235       '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 {
236          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
237            print "hardware version $hw_ver\n";
238            meteor( 'info', "Found reader hardware $hw_ver" );
239  });  });
240    
241  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?',
242       '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() }  );
243    
244  # start scanning for tags  sub scan_for_tags {
245    
246            my @tags;
247    
248  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
249       '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 {  
250                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
251                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
                         my $tags = substr( $rest, 1 );  
252    
253                          my $tl = length( $tags );                          if ( ! $nr ) {
254                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  print "no tags in range\n";
255                                    update_visible_tags();
256                                    meteor( 'info-none-in-range' );
257                                    $tags_data = {};
258                            } else {
259    
260                          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";  
261    
262                          # XXX read first tag                                  my $tl = length( $tags );
263                          read_tag( @tags );                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
264    
265                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
266                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
267                                    print "$nr tags in range: ", join(',', @tags ) , "\n";
268    
269                                    meteor( 'info-in-range', join(' ',@tags));
270    
271                                    update_visible_tags( @tags );
272                            }
273                  }                  }
274  ) }          );
275    
276            warn "## tags: ",dump( @tags );
277            return $tags_data;
278    
279    }
280    
281    # start scanning for tags
282    
283    if ( $http_server ) {
284            http_server;
285    } else {
286            scan_for_tags while 1;
287    }
288    
289    die "over and out";
290    
291    sub update_visible_tags {
292            my @tags = @_;
293    
294            my $last_visible_tags = $visible_tags;
295            $visible_tags = {};
296    
297            foreach my $tag ( @tags ) {
298                    if ( ! defined $last_visible_tags->{$tag} ) {
299                            if ( defined $tags_data->{$tag} ) {
300    #                               meteor( 'in-range', $tag );
301                            } else {
302                                    meteor( 'read', $tag );
303                                    read_tag( $tag );
304                            }
305                            $visible_tags->{$tag}++;
306                    } else {
307                            warn "## using cached data for $tag" if $debug;
308                    }
309                    delete $last_visible_tags->{$tag}; # leave just missing tags
310    
311                    if ( -e "$program_path/$tag" ) {
312                                    meteor( 'write', $tag );
313                                    write_tag( $tag );
314                    }
315                    if ( -e "$secure_path/$tag" ) {
316                                    meteor( 'secure', $tag );
317                                    secure_tag( $tag );
318                    }
319            }
320    
321            foreach my $tag ( keys %$last_visible_tags ) {
322                    my $data = delete $tags_data->{$tag};
323                    print "removed tag $tag with data ",dump( $data ),"\n";
324                    meteor( 'removed', $tag );
325            }
326    
327            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
328    }
329    
330    my $tag_data_block;
331    
332    sub read_tag_data {
333            my ($start_block,$rest) = @_;
334            die "no rest?" unless $rest;
335    
336            my $last_block = 0;
337    
338            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
339            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
340            my $blocks = ord(substr($rest,8,1));
341            $rest = substr($rest,9); # leave just data blocks
342            foreach my $nr ( 0 .. $blocks - 1 ) {
343                    my $block = substr( $rest, $nr * 6, 6 );
344                    warn "## block ",as_hex( $block ) if $debug;
345                    my $ord   = unpack('v',substr( $block, 0, 2 ));
346                    my $expected_ord = $nr + $start_block;
347                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
348                    my $data  = substr( $block, 2 );
349                    die "data payload should be 4 bytes" if length($data) != 4;
350                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
351                    $tag_data_block->{$tag}->[ $ord ] = $data;
352                    $last_block = $ord;
353            }
354            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
355    
356            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
357            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
358    
359            return $last_block + 1;
360    }
361    
362    sub decode_tag {
363            my $tag = shift;
364    
365            my $data = $tags_data->{$tag} || die "no data for $tag";
366    
367            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
368            my $hash = {
369                    u1 => $u1,
370                    u2 => $u2,
371                    set => ( $set_item & 0xf0 ) >> 4,
372                    total => ( $set_item & 0x0f ),
373    
374                    type => $type,
375                    content => $content,
376    
377                    branch => $br_lib >> 20,
378                    library => $br_lib & 0x000fffff,
379    
380  ) foreach ( 1 .. 100 );                  custom => $custom,
381            };
382    
383  my $read_cached;          return $hash;
384    }
385    
386  sub read_tag {  sub read_tag {
387          my ( $tag ) = @_;          my ( $tag ) = @_;
388    
389            confess "no tag?" unless $tag;
390    
391          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
392    
393          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          my $start_block = 0;
394                          "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {  
395  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 ) {
396                          my $rest = shift || die "no rest?";  
397                          warn "## DATA ", dump( $rest ) if $debug;                  cmd(
398                          my $blocks = ord(substr($rest,0,1));                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
399                          my @data;                                  "read $tag offset: $start_block blocks: $read_blocks",
400                          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";
401                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  $start_block = read_tag_data( $start_block, @_ );
402                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "# read tag upto $start_block\n";
403                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                          },
404                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;                          "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
405                                  my $data  = substr( $block, 2 );                                  print "FIXME: tag $tag ready? (expected block read instead)\n";
406                                  die "data payload should be 4 bytes" if length($data) != 4;                          },
407                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  );
408                                  $data[ $ord ] = $data;  
409                          }          }
410                          $read_cached->{ $tag } = join('', @data);  
411                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";          my $security;
412                  })  
413          });          cmd(
414                    "D6 00 0B 0A $tag 1234", "check security $tag",
415          #        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 {
416  if (0) {                          my $rest = shift;
417          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );                          my $from_tag;
418                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
419          #        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 );
420          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          $security = as_hex( $security );
421          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";                          warn "# SECURITY $tag = $security\n";
422                    }
423            );
424    
425            print "TAG $tag ", dump(decode_tag( $tag ));
426  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
427    
428    sub write_tag {
429            my ($tag) = @_;
430    
431            my $path = "$program_path/$tag";
432    
433            my $data = read_file( $path );
434            my $hex_data;
435    
436            if ( $data =~ s{^hex\s+}{} ) {
437                    $hex_data = $data;
438                    $hex_data =~ s{\s+}{}g;
439            } else {
440    
441                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
442    
443                    my $max_len = $max_rfid_block * 4;
444    
445                    if ( length($data) > $max_len ) {
446                            $data = substr($data,0,$max_len);
447                            warn "strip content to $max_len bytes\n";
448                    }
449    
450                    $hex_data = unpack('H*', $data);
451            }
452    
453            my $len = length($hex_data) / 2;
454            # pad to block size
455            $hex_data .= '00' x ( 4 - $len % 4 );
456            my $blocks = sprintf('%02x', length($hex_data) / 4);
457    
458            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
459    
460            cmd(
461                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
462                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
463            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
464    
465            my $to = $path;
466            $to .= '.' . time();
467    
468            rename $path, $to;
469            print ">> $to\n";
470    
471            delete $tags_data->{$tag};      # force re-read of tag
472  }  }
473    
474    sub secure_tag {
475            my ($tag) = @_;
476    
477            my $path = "$secure_path/$tag";
478            my $data = substr(read_file( $path ),0,2);
479    
480            cmd(
481                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
482                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
483            );
484    
485            my $to = $path;
486            $to .= '.' . time();
487    
488            rename $path, $to;
489            print ">> $to\n";
490    }
491    
492    exit;
493    
494  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
495    
496  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 188  sub writechunk Line 521  sub writechunk
521  {  {
522          my $str=shift;          my $str=shift;
523          my $count = $port->write($str);          my $count = $port->write($str);
524          print "#> ", as_hex( $str ), "\t[$count]" if $debug;          my $len = length($str);
525            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
526            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
527  }  }
528    
529  sub as_hex {  sub as_hex {
# Line 207  sub read_bytes { Line 542  sub read_bytes {
542          my $data = '';          my $data = '';
543          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
544                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
545                    die "no bytes on port: $!" unless defined $b;
546                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
547                  $data .= $b;                  $data .= $b;
548          }          }
# Line 236  sub assert { Line 572  sub assert {
572          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
573  }  }
574    
 our $dispatch;  
 sub dispatch {  
         my ( $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;  
         }  
 }  
   
575  use Digest::CRC;  use Digest::CRC;
576    
577  sub crcccitt {  sub crcccitt {
# Line 271  sub crcccitt { Line 589  sub crcccitt {
589  sub checksum {  sub checksum {
590          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
591    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
592          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
593          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
594    
595          if ( $len_real != $len ) {          if ( $len_real != $len ) {
596                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
597                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
598          }          }
599    
600            my $xor = crcccitt( substr($bytes,1) ); # skip D6
601            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
602    
603          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
604                  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";
605                  return $bytes . $xor;                  return $bytes . $xor;
# Line 289  sub checksum { Line 607  sub checksum {
607          return $bytes . $checksum;          return $bytes . $checksum;
608  }  }
609    
610  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
611    
612          sleep 1;        # FIXME remove  sub readchunk {
613    #       sleep 1;        # FIXME remove
614    
615          # read header of packet          # read header of packet
616          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 305  sub readchunk { Line 623  sub readchunk {
623          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
624    
625          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
626          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
627    
628          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;
629    
630          $assert->{len}      = $len;          $assert->{len}      = $len;
631          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
632    
633          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
634            # find longest match for incomming data
635            my ($to) = grep {
636                    my $match = substr($payload,0,length($_));
637                    m/^\Q$match\E/
638            } sort { length($a) <=> length($b) } keys %$dispatch;
639            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
640    
641            if ( defined $to ) {
642                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
643                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
644                    $dispatch->{ $to }->( $rest );
645            } else {
646                    print "NO DISPATCH for ",dump( $full ),"\n";
647            }
648    
649          return $data;          return $data;
650  }  }
# Line 330  sub str2bytes { Line 662  sub str2bytes {
662  }  }
663    
664  sub cmd {  sub cmd {
665          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
666            my $cmd_desc = shift || confess "no description?";
667            my @expect = @_;
668    
669          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
670    
671          # fix checksum if needed          # fix checksum if needed
672          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
673    
674          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
675          $assert->{send} = $cmd;          $assert->{send} = $cmd;
676          writechunk( $bytes );          writechunk( $bytes );
677    
678          if ( $expect ) {          while ( @expect ) {
679                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
680                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
681                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
682    
683                    next if defined $dispatch->{ $pattern };
684    
685                    $dispatch->{ substr($pattern,3) } = $coderef;
686                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
687          }          }
688    
689            readchunk;
690  }  }
691    
Legend:
Removed from v.18  
changed lines
  Added in v.46
  ViewVC Help
Powered by ViewVC 1.1.26