/[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 44 by dpavlin, Tue Jun 23 13:10:18 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                            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    
111    my $device    = "/dev/ttyUSB0";
112    my $baudrate  = "19200";
113    my $databits  = "8";
114    my $parity        = "none";
115    my $stopbits  = "1";
116    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 21  my $response = { Line 137  my $response = {
137          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
138  };  };
139    
140    GetOptions(
141            'd|debug+'    => \$debug,
142            'device=s'    => \$device,
143            'baudrate=i'  => \$baudrate,
144            'databits=i'  => \$databits,
145            'parity=s'    => \$parity,
146            'stopbits=i'  => \$stopbits,
147            'handshake=s' => \$handshake,
148            'meteor=s'    => \$meteor_server,
149    ) or die $!;
150    
151    my $verbose = $debug > 0 ? $debug-- : 0;
152    
153  =head1 NAME  =head1 NAME
154    
155  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
156    
157  =head1 SYNOPSIS  =head1 SYNOPSIS
158    
159  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
160    
161  =head1 DESCRIPTION  =head1 DESCRIPTION
162    
# Line 52  it under the same terms ans Perl itself. Line 181  it under the same terms ans Perl itself.
181    
182  =cut  =cut
183    
184  # your serial port.  my $tags_data;
185  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
186  $device    ||= "/dev/ttyUSB0";  
187  $baudrate  ||= "19200";  my $item_type = {
188  $databits  ||= "8";          1 => 'Book',
189  $parity    ||= "none";          6 => 'CD/CD ROM',
190  $stopbits  ||= "1";          2 => 'Magazine',
191  $handshake ||= "none";          13 => 'Book with Audio Tape',
192            9 => 'Book with CD/CD ROM',
193            0 => 'Other',
194    
195            5 => 'Video',
196            4 => 'Audio Tape',
197            3 => 'Bound Journal',
198            8 => 'Book with Diskette',
199            7 => 'Diskette',
200    };
201    
202    warn "## known item type: ",dump( $item_type ) if $debug;
203    
204  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
205    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
206  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
207  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
208  $databits=$port->databits($databits);  $databits=$port->databits($databits);
209  $parity=$port->parity($parity);  $parity=$port->parity($parity);
210  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
211    
212  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
213    
214  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
215  $port->lookclear();  $port->lookclear();
# Line 81  $port->read_char_time(5); Line 222  $port->read_char_time(5);
222    
223  # initial hand-shake with device  # initial hand-shake with device
224    
225  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
226       '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 {
227          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
228            print "hardware version $hw_ver\n";
229            meteor( 'info', "Found reader hardware $hw_ver" );
230  });  });
231    
232  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?',
233       '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() }  );
234    
235  # start scanning for tags  sub scan_for_tags {
236    
237  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          my @tags;
238       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {  
239  dispatch(          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
240           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
                 sub {  
241                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
242                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
                         my $tags = substr( $rest, 1 );  
243    
244                          my $tl = length( $tags );                          if ( ! $nr ) {
245                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  print "no tags in range\n";
246                                    update_visible_tags();
247                                    meteor( 'info-none-in-range' );
248                                    $tags_data = {};
249                            } else {
250    
251                                    my $tags = substr( $rest, 1 );
252    
253                          my @tags;                                  my $tl = length( $tags );
254                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
255    
256                          # XXX read first tag                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
257                          read_tag( @tags );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
258                                    print "$nr tags in range: ", join(',', @tags ) , "\n";
259    
260                                    meteor( 'info-in-range', join(' ',@tags));
261    
262                                    update_visible_tags( @tags );
263                            }
264                  }                  }
265  ) }          );
266    
267  ) foreach ( 1 .. 100 );          warn "## tags: ",dump( @tags );
268            return $tags_data;
269    
270  my $read_cached;  }
271    
272    # start scanning for tags
273    
274    if ( $http_server ) {
275            http_server;
276    } else {
277            scan_for_tags while 1;
278    }
279    
280    die "over and out";
281    
282    sub update_visible_tags {
283            my @tags = @_;
284    
285            my $last_visible_tags = $visible_tags;
286            $visible_tags = {};
287    
288            foreach my $tag ( @tags ) {
289                    if ( ! defined $last_visible_tags->{$tag} ) {
290                            if ( defined $tags_data->{$tag} ) {
291    #                               meteor( 'in-range', $tag );
292                            } else {
293                                    meteor( 'read', $tag );
294                                    read_tag( $tag );
295                            }
296                            $visible_tags->{$tag}++;
297                    } else {
298                            warn "## using cached data for $tag" if $debug;
299                    }
300                    delete $last_visible_tags->{$tag}; # leave just missing tags
301    
302                    if ( -e "$program_path/$tag" ) {
303                                    meteor( 'write', $tag );
304                                    write_tag( $tag );
305                    }
306                    if ( -e "$secure_path/$tag" ) {
307                                    meteor( 'secure', $tag );
308                                    secure_tag( $tag );
309                    }
310            }
311    
312            foreach my $tag ( keys %$last_visible_tags ) {
313                    my $data = delete $tags_data->{$tag};
314                    print "removed tag $tag with data ",dump( $data ),"\n";
315                    meteor( 'removed', $tag );
316            }
317    
318            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
319    }
320    
321    my $tag_data_block;
322    
323    sub read_tag_data {
324            my ($start_block,$rest) = @_;
325            die "no rest?" unless $rest;
326    
327            my $last_block = 0;
328    
329            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
330            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
331            my $blocks = ord(substr($rest,8,1));
332            $rest = substr($rest,9); # leave just data blocks
333            foreach my $nr ( 0 .. $blocks - 1 ) {
334                    my $block = substr( $rest, $nr * 6, 6 );
335                    warn "## block ",as_hex( $block ) if $debug;
336                    my $ord   = unpack('v',substr( $block, 0, 2 ));
337                    my $expected_ord = $nr + $start_block;
338                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
339                    my $data  = substr( $block, 2 );
340                    die "data payload should be 4 bytes" if length($data) != 4;
341                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
342                    $tag_data_block->{$tag}->[ $ord ] = $data;
343                    $last_block = $ord;
344            }
345            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
346    
347            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
348            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
349    
350            return $last_block + 1;
351    }
352    
353    sub decode_tag {
354            my $tag = shift;
355    
356            my $data = $tags_data->{$tag} || die "no data for $tag";
357    
358            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
359            my $hash = {
360                    u1 => $u1,
361                    u2 => $u2,
362                    set => ( $set_item & 0xf0 ) >> 4,
363                    total => ( $set_item & 0x0f ),
364    
365                    type => $type,
366                    content => $content,
367    
368                    branch => $br_lib >> 20,
369                    library => $br_lib & 0x000fffff,
370    
371                    custom => $custom,
372            };
373    
374            return $hash;
375    }
376    
377  sub read_tag {  sub read_tag {
378          my ( $tag ) = @_;          my ( $tag ) = @_;
379    
380            confess "no tag?" unless $tag;
381    
382          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
383    
384          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          my $start_block = 0;
385                          "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {  
386  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 ) {
387                          my $rest = shift || die "no rest?";  
388                          warn "## DATA ", dump( $rest ) if $debug;                  cmd(
389                          my $blocks = ord(substr($rest,0,1));                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
390                          my @data;                                  "read $tag offset: $start_block blocks: $read_blocks",
391                          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";
392                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  $start_block = read_tag_data( $start_block, @_ );
393                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "# read tag upto $start_block\n";
394                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                          },
395                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;                          "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
396                                  my $data  = substr( $block, 2 );                                  print "FIXME: tag $tag ready? (expected block read instead)\n";
397                                  die "data payload should be 4 bytes" if length($data) != 4;                          },
398                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  );
399                                  $data[ $ord ] = $data;  
400                          }          }
401                          $read_cached->{ $tag } = join('', @data);  
402                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";          my $security;
403                  })  
404          });          cmd(
405                    "D6 00 0B 0A $tag 1234", "check security $tag",
406          #        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 {
407  if (0) {                          my $rest = shift;
408          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );                          my $from_tag;
409                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
410          #        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 );
411          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          $security = as_hex( $security );
412          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";                          warn "# SECURITY $tag = $security\n";
413                    }
414            );
415    
416            print "TAG $tag ", dump(decode_tag( $tag ));
417    }
418    
419    sub write_tag {
420            my ($tag) = @_;
421    
422            my $path = "$program_path/$tag";
423    
424            my $data = read_file( $path );
425            my $hex_data;
426    
427            if ( $data =~ s{^hex\s+}{} ) {
428                    $hex_data = $data;
429                    $hex_data =~ s{\s+}{}g;
430            } else {
431    
432                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
433    
434                    my $max_len = $max_rfid_block * 4;
435    
436                    if ( length($data) > $max_len ) {
437                            $data = substr($data,0,$max_len);
438                            warn "strip content to $max_len bytes\n";
439                    }
440    
441                    $hex_data = unpack('H*', $data);
442            }
443    
444            my $len = length($hex_data) / 2;
445            # pad to block size
446            $hex_data .= '00' x ( 4 - $len % 4 );
447            my $blocks = sprintf('%02x', length($hex_data) / 4);
448    
449            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
450    
451            cmd(
452                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
453                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
454            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
455    
456            my $to = $path;
457            $to .= '.' . time();
458    
459            rename $path, $to;
460            print ">> $to\n";
461    
462            delete $tags_data->{$tag};      # force re-read of tag
463  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
464    
465    sub secure_tag {
466            my ($tag) = @_;
467    
468            my $path = "$secure_path/$tag";
469            my $data = substr(read_file( $path ),0,2);
470    
471            cmd(
472                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
473                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
474            );
475    
476            my $to = $path;
477            $to .= '.' . time();
478    
479            rename $path, $to;
480            print ">> $to\n";
481  }  }
482    
483    exit;
484    
485  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
486    
487  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 188  sub writechunk Line 512  sub writechunk
512  {  {
513          my $str=shift;          my $str=shift;
514          my $count = $port->write($str);          my $count = $port->write($str);
515          print "#> ", as_hex( $str ), "\t[$count]" if $debug;          my $len = length($str);
516            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
517            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
518  }  }
519    
520  sub as_hex {  sub as_hex {
# Line 207  sub read_bytes { Line 533  sub read_bytes {
533          my $data = '';          my $data = '';
534          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
535                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
536                    die "no bytes on port: $!" unless defined $b;
537                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
538                  $data .= $b;                  $data .= $b;
539          }          }
# Line 236  sub assert { Line 563  sub assert {
563          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
564  }  }
565    
 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;  
         }  
 }  
   
566  use Digest::CRC;  use Digest::CRC;
567    
568  sub crcccitt {  sub crcccitt {
# Line 271  sub crcccitt { Line 580  sub crcccitt {
580  sub checksum {  sub checksum {
581          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
582    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
583          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
584          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
585    
586          if ( $len_real != $len ) {          if ( $len_real != $len ) {
587                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
588                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
589          }          }
590    
591            my $xor = crcccitt( substr($bytes,1) ); # skip D6
592            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
593    
594          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
595                  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";
596                  return $bytes . $xor;                  return $bytes . $xor;
# Line 289  sub checksum { Line 598  sub checksum {
598          return $bytes . $checksum;          return $bytes . $checksum;
599  }  }
600    
601  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
602    
603          sleep 1;        # FIXME remove  sub readchunk {
604    #       sleep 1;        # FIXME remove
605    
606          # read header of packet          # read header of packet
607          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 305  sub readchunk { Line 614  sub readchunk {
614          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
615    
616          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
617          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
618    
619          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;
620    
621          $assert->{len}      = $len;          $assert->{len}      = $len;
622          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
623    
624          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
625            # find longest match for incomming data
626            my ($to) = grep {
627                    my $match = substr($payload,0,length($_));
628                    m/^\Q$match\E/
629            } sort { length($a) <=> length($b) } keys %$dispatch;
630            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
631    
632            if ( defined $to ) {
633                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
634                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
635                    $dispatch->{ $to }->( $rest );
636            } else {
637                    print "NO DISPATCH for ",dump( $full ),"\n";
638            }
639    
640          return $data;          return $data;
641  }  }
# Line 330  sub str2bytes { Line 653  sub str2bytes {
653  }  }
654    
655  sub cmd {  sub cmd {
656          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
657            my $cmd_desc = shift || confess "no description?";
658            my @expect = @_;
659    
660          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
661    
662          # fix checksum if needed          # fix checksum if needed
663          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
664    
665          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
666          $assert->{send} = $cmd;          $assert->{send} = $cmd;
667          writechunk( $bytes );          writechunk( $bytes );
668    
669          if ( $expect ) {          while ( @expect ) {
670                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
671                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
672                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
673    
674                    next if defined $dispatch->{ $pattern };
675    
676                    $dispatch->{ substr($pattern,3) } = $coderef;
677                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
678          }          }
679    
680            readchunk;
681  }  }
682    
Legend:
Removed from v.18  
changed lines
  Added in v.44
  ViewVC Help
Powered by ViewVC 1.1.26