/[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 10 by dpavlin, Sun Sep 28 22:15:29 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 39  L<Device::SerialPort(3)> Line 177  L<Device::SerialPort(3)>
177    
178  L<perl(1)>  L<perl(1)>
179    
180    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
181    
182  =head1 AUTHOR  =head1 AUTHOR
183    
184  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
# Line 50  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;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
195    
196  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $item_type = {
197            1 => 'Book',
198            6 => 'CD/CD ROM',
199            2 => 'Magazine',
200            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 "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 79  $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  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          my @tags;
247       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {  
248  dispatch(          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
249           '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 {  
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 = substr( $rest, 1 );
261    
262                                    my $tl = length( $tags );
263                                    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                          my @tags;                  branch => $br_lib >> 20,
378                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                  library => $br_lib & 0x000fffff,
379                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
380                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                  custom => $custom,
381            };
382    
383            return $hash;
384    }
385    
386    sub read_tag {
387            my ( $tag ) = @_;
388    
389            confess "no tag?" unless $tag;
390    
391            print "read_tag $tag\n";
392    
393            my $start_block = 0;
394    
395            while ( $start_block < $max_rfid_block ) {
396    
397                    cmd(
398                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
399                                    "read $tag offset: $start_block blocks: $read_blocks",
400                            "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                                    $start_block = read_tag_data( $start_block, @_ );
402                                    warn "# read tag upto $start_block\n";
403                            },
404                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
405                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
406                            },
407                    );
408    
409            }
410    
411            my $security;
412    
413            cmd(
414                    "D6 00 0B 0A $tag 1234", "check security $tag",
415                    "D6 00 0D 0A 00", sub {
416                            my $rest = shift;
417                            my $from_tag;
418                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
419                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
420                            $security = as_hex( $security );
421                            warn "# SECURITY $tag = $security\n";
422                  }                  }
423  ) }          );
424    
425            print "TAG $tag ", dump(decode_tag( $tag ));
426    }
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  ) foreach ( 1 .. 100 );          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  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
459    
460  #     D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4          cmd(
461  warn "D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";                  "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  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          my $to = $path;
466            $to .= '.' . time();
467    
468  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            rename $path, $to;
469  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          print ">> $to\n";
470  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
471                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          delete $tags_data->{$tag};      # force re-read of tag
472  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";  }
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    
# Line 153  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]\n";          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 172  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 201  sub assert { Line 572  sub assert {
572          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
573  }  }
574    
575  our $dispatch;  use Digest::CRC;
576  sub dispatch {  
577          my ( $pattern, $coderef ) = @_;  sub crcccitt {
578          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
579          my $l = length($patt);          my $crc = Digest::CRC->new(
580          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
581          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
582            ) or die $!;
583          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
584                  warn "## no dispatch, payload expected" if $debug;          pack('n', $crc->digest);
         } elsif ( $p eq $patt ) {  
                 # if matched call with rest of payload  
                 $coderef->( substr( $assert->{payload}, $l ) );  
         } else {  
                 warn "## dispatch ignored" if $debug;  
         }  
585  }  }
586    
587  # my $checksum = checksum( $bytes );  # my $checksum = checksum( $bytes );
# Line 224  sub dispatch { Line 589  sub dispatch {
589  sub checksum {  sub checksum {
590          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
591    
592          my $xor = $checksum; # FIXME          my $len = ord(substr($bytes,2,1));
593            my $len_real = length($bytes) - 1;
594    
595            if ( $len_real != $len ) {
596                    print "length wrong: $len_real != $len\n";
597                    $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;
606          }          }
607            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 247  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 262  sub readchunk { Line 652  sub readchunk {
652  sub str2bytes {  sub str2bytes {
653          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
654          my $b = $str;          my $b = $str;
655          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
656          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
657          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
658          my $bytes = eval $b;          my $bytes = eval $b;
659          die $@ if $@;          die $@ if $@;
660          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 273  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          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
672            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
673    
674            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.10  
changed lines
  Added in v.46
  ViewVC Help
Powered by ViewVC 1.1.26