/[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 54 by dpavlin, Wed Jun 24 13:39:43 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 $debug = 0;  my $debug = 0;
16    
17    my $tags_data;
18    my $tags_security;
19    my $visible_tags;
20    
21    my $meteor_server; # = '192.168.1.13:4671';
22    my $meteor_fh;
23    
24    sub meteor {
25            my @a = @_;
26            push @a, scalar localtime() if $a[0] =~ m{^info};
27    
28            if ( ! defined $meteor_fh ) {
29                    if ( $meteor_fh =
30                                    IO::Socket::INET->new(
31                                            PeerAddr => $meteor_server,
32                                            Timeout => 1,
33                                    )
34                    ) {
35                            warn "# meteor connected to $meteor_server";
36                    } else {
37                            warn "can't connect to meteor $meteor_server: $!";
38                            $meteor_fh = 0;
39                    }
40            }
41    
42            if ( $meteor_fh ) {
43                    warn ">> meteor ",dump( @a );
44                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
45            }
46    }
47    
48    my $listen_port = 9000;                  # pick something not in use
49    sub http_server {
50    
51            my $server = IO::Socket::INET->new(
52                    Proto     => 'tcp',
53                    LocalPort => $listen_port,
54                    Listen    => SOMAXCONN,
55                    Reuse     => 1
56            );
57                                                                      
58            die "can't setup server" unless $server;
59    
60            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
61    
62            sub static {
63                    my ($client,$path) = @_;
64    
65                    $path = "www/$path";
66    
67                    return unless -e $path;
68    
69                    my $type = 'text/plain';
70                    $type = 'text/html' if $path =~ m{\.htm};
71                    $type = 'application/javascript' if $path =~ m{\.js};
72    
73                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
74                    open(my $html, $path);
75                    while(<$html>) {
76                            print $client $_;
77                    }
78                    close($html);
79    
80                    return $path;
81            }
82    
83            while (my $client = $server->accept()) {
84                    $client->autoflush(1);
85                    my $request = <$client>;
86    
87                    warn "WEB << $request\n" if $debug;
88    
89                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
90                            my $method = $1;
91                            my $param;
92                            if ( $method =~ s{\?(.+)}{} ) {
93                                    foreach my $p ( split(/[&;]/, $1) ) {
94                                            my ($n,$v) = split(/=/, $p, 2);
95                                            $param->{$n} = $v;
96                                    }
97                                    warn "WEB << param: ",dump( $param ) if $debug;
98                            }
99                            if ( my $path = static( $client,$1 ) ) {
100                                    warn "WEB >> $path" if $debug;
101                            } elsif ( $method =~ m{/scan} ) {
102                                    my $tags = scan_for_tags();
103                                    my $json = { time => time() };
104                                    map {
105                                            my $d = decode_tag($_);
106                                            $d->{sid} = $_;
107                                            $d->{security} = $tags_security->{$_};
108                                            push @{ $json->{tags} },  $d;
109                                    } keys %$tags;
110                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
111                                            $param->{callback}, "(", to_json($json), ")\r\n";
112                            } else {
113                                    print $client "HTTP/1.0 404 Unkown method\r\n";
114                            }
115                    } else {
116                            print $client "HTTP/1.0 500 No method\r\n";
117                    }
118                    close $client;
119            }
120    
121            die "server died";
122    }
123    
124    
125    my $last_message = {};
126    sub _message {
127            my $type = shift @_;
128            my $text = join(' ',@_);
129            my $last = $last_message->{$type};
130            if ( $text ne $last ) {
131                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
132                    $last_message->{$type} = $text;
133            }
134    }
135    
136    sub _log { _message('log',@_) };
137    sub diag { _message('diag',@_) };
138    
139    my $device    = "/dev/ttyUSB0";
140    my $baudrate  = "19200";
141    my $databits  = "8";
142    my $parity        = "none";
143    my $stopbits  = "1";
144    my $handshake = "none";
145    
146    my $program_path = './program/';
147    my $secure_path = './secure/';
148    
149    # http server
150    my $http_server = 1;
151    
152    # 3M defaults: 8,4
153    my $max_rfid_block = 16;
154    my $read_blocks = 8;
155    
156  my $response = {  my $response = {
157          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
158          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 165  my $response = {
165          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
166  };  };
167    
168    GetOptions(
169            'd|debug+'    => \$debug,
170            'device=s'    => \$device,
171            'baudrate=i'  => \$baudrate,
172            'databits=i'  => \$databits,
173            'parity=s'    => \$parity,
174            'stopbits=i'  => \$stopbits,
175            'handshake=s' => \$handshake,
176            'meteor=s'    => \$meteor_server,
177            'http-server!' => \$http_server,
178    ) or die $!;
179    
180    my $verbose = $debug > 0 ? $debug-- : 0;
181    
182  =head1 NAME  =head1 NAME
183    
184  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
185    
186  =head1 SYNOPSIS  =head1 SYNOPSIS
187    
188  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
189    
190  =head1 DESCRIPTION  =head1 DESCRIPTION
191    
# Line 39  L<Device::SerialPort(3)> Line 197  L<Device::SerialPort(3)>
197    
198  L<perl(1)>  L<perl(1)>
199    
200    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
201    
202  =head1 AUTHOR  =head1 AUTHOR
203    
204  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 210  it under the same terms ans Perl itself.
210    
211  =cut  =cut
212    
213  # your serial port.  my $item_type = {
214  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;          1 => 'Book',
215  $device    ||= "/dev/ttyUSB0";          6 => 'CD/CD ROM',
216  $baudrate  ||= "19200";          2 => 'Magazine',
217  $databits  ||= "8";          13 => 'Book with Audio Tape',
218  $parity    ||= "none";          9 => 'Book with CD/CD ROM',
219  $stopbits  ||= "1";          0 => 'Other',
220  $handshake ||= "none";  
221            5 => 'Video',
222            4 => 'Audio Tape',
223            3 => 'Bound Journal',
224            8 => 'Book with Diskette',
225            7 => 'Diskette',
226    };
227    
228    warn "## known item type: ",dump( $item_type ) if $debug;
229    
230  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
231    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
232  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
233  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
234  $databits=$port->databits($databits);  $databits=$port->databits($databits);
235  $parity=$port->parity($parity);  $parity=$port->parity($parity);
236  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
237    
238  print "## using $device $baudrate $databits $parity $stopbits\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
239    
240  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
241  $port->lookclear();  $port->lookclear();
# Line 79  $port->read_char_time(5); Line 248  $port->read_char_time(5);
248    
249  # initial hand-shake with device  # initial hand-shake with device
250    
251  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
252       '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 {
253          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
254            print "hardware version $hw_ver\n";
255            meteor( 'info', "Found reader hardware $hw_ver" );
256  });  });
257    
258  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?',
259       '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() }  );
260    
261  # start scanning for tags  sub scan_for_tags {
262    
263            my @tags;
264    
265  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
266       '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 {  
267                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
268                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
                         my $tags = substr( $rest, 1 );  
269    
270                          my $tl = length( $tags );                          if ( ! $nr ) {
271                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  _log "no tags in range\n";
272                                    update_visible_tags();
273                                    meteor( 'info-none-in-range' );
274                                    $tags_data = {};
275                            } else {
276    
277                                    my $tags = substr( $rest, 1 );
278                                    my $tl = length( $tags );
279                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
280    
281                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
282                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
283                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
284    
285                                    meteor( 'info-in-range', join(' ',@tags));
286    
287                                    update_visible_tags( @tags );
288                            }
289                    }
290            );
291    
292            diag "tags: ",dump( @tags );
293            return $tags_data;
294    
295    }
296    
297    # start scanning for tags
298    
299    if ( $http_server ) {
300            http_server;
301    } else {
302            scan_for_tags while 1;
303    }
304    
305    die "over and out";
306    
307    sub update_visible_tags {
308            my @tags = @_;
309    
310            my $last_visible_tags = $visible_tags;
311            $visible_tags = {};
312    
313            foreach my $tag ( @tags ) {
314                    $visible_tags->{$tag}++;
315                    if ( ! defined $last_visible_tags->{$tag} ) {
316                            if ( defined $tags_data->{$tag} ) {
317    #                               meteor( 'in-range', $tag );
318                            } else {
319                                    meteor( 'read', $tag );
320                                    read_tag( $tag );
321                            }
322                    } else {
323                            warn "## using cached data for $tag" if $debug;
324                    }
325                    delete $last_visible_tags->{$tag}; # leave just missing tags
326    
327                    if ( -e "$program_path/$tag" ) {
328                                    meteor( 'write', $tag );
329                                    write_tag( $tag );
330                    }
331                    if ( -e "$secure_path/$tag" ) {
332                                    meteor( 'secure', $tag );
333                                    secure_tag( $tag );
334                    }
335            }
336    
337            foreach my $tag ( keys %$last_visible_tags ) {
338                    my $data = delete $tags_data->{$tag};
339                    print "removed tag $tag with data ",dump( $data ),"\n";
340                    meteor( 'removed', $tag );
341            }
342    
343            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
344    }
345    
346    my $tag_data_block;
347    
348    sub read_tag_data {
349            my ($start_block,$rest) = @_;
350            die "no rest?" unless $rest;
351    
352            my $last_block = 0;
353    
354            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
355            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
356            my $blocks = ord(substr($rest,8,1));
357            $rest = substr($rest,9); # leave just data blocks
358            foreach my $nr ( 0 .. $blocks - 1 ) {
359                    my $block = substr( $rest, $nr * 6, 6 );
360                    warn "## block ",as_hex( $block ) if $debug;
361                    my $ord   = unpack('v',substr( $block, 0, 2 ));
362                    my $expected_ord = $nr + $start_block;
363                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
364                    my $data  = substr( $block, 2 );
365                    die "data payload should be 4 bytes" if length($data) != 4;
366                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
367                    $tag_data_block->{$tag}->[ $ord ] = $data;
368                    $last_block = $ord;
369            }
370            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
371    
372            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
373            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
374    
375            return $last_block + 1;
376    }
377    
378    sub decode_tag {
379            my $tag = shift;
380    
381                          my @tags;          my $data = $tags_data->{$tag} || die "no data for $tag";
382                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );  
383                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;          my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
384                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";          my $hash = {
385                    u1 => $u1,
386                    u2 => $u2,
387                    set => ( $set_item & 0xf0 ) >> 4,
388                    total => ( $set_item & 0x0f ),
389    
390                    type => $type,
391                    content => $content,
392    
393                    branch => $br_lib >> 20,
394                    library => $br_lib & 0x000fffff,
395    
396                    custom => $custom,
397            };
398    
399            return $hash;
400    }
401    
402    sub read_tag {
403            my ( $tag ) = @_;
404    
405            confess "no tag?" unless $tag;
406    
407            print "read_tag $tag\n";
408    
409            my $start_block = 0;
410    
411            while ( $start_block < $max_rfid_block ) {
412    
413                    cmd(
414                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
415                                    "read $tag offset: $start_block blocks: $read_blocks",
416                            "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";
417                                    $start_block = read_tag_data( $start_block, @_ );
418                                    warn "# read tag upto $start_block\n";
419                            },
420                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
421                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
422                            },
423                    );
424    
425            }
426    
427            my $security;
428    
429            cmd(
430                    "D6 00 0B 0A $tag 1234", "check security $tag",
431                    "D6 00 0D 0A 00", sub {
432                            my $rest = shift;
433                            my $from_tag;
434                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
435                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
436                            $security = as_hex( $security );
437                            $tags_security->{$tag} = $security;
438                            warn "# SECURITY $tag = $security\n";
439                    }
440            );
441    
442            print "TAG $tag ", dump(decode_tag( $tag ));
443    }
444    
445    sub write_tag {
446            my ($tag) = @_;
447    
448            my $path = "$program_path/$tag";
449    
450            my $data = read_file( $path );
451            my $hex_data;
452    
453            if ( $data =~ s{^hex\s+}{} ) {
454                    $hex_data = $data;
455                    $hex_data =~ s{\s+}{}g;
456            } else {
457    
458                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
459    
460                    my $max_len = $max_rfid_block * 4;
461    
462                    if ( length($data) > $max_len ) {
463                            $data = substr($data,0,$max_len);
464                            warn "strip content to $max_len bytes\n";
465                  }                  }
 ) }  
466    
467  ) foreach ( 1 .. 100 );                  $hex_data = unpack('H*', $data);
468            }
469    
470  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          my $len = length($hex_data) / 2;
471            # pad to block size
472            $hex_data .= '00' x ( 4 - $len % 4 );
473            my $blocks = sprintf('%02x', length($hex_data) / 4);
474    
475  #     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          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
 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";  
476    
477  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          cmd(
478                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
479                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
480            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
481    
482  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            my $to = $path;
483  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          $to .= '.' . time();
484  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
485                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          rename $path, $to;
486  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";          print ">> $to\n";
487    
488            delete $tags_data->{$tag};      # force re-read of tag
489    }
490    
491    sub secure_tag {
492            my ($tag) = @_;
493    
494            my $path = "$secure_path/$tag";
495            my $data = substr(read_file( $path ),0,2);
496    
497            cmd(
498                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
499                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
500            );
501    
502            my $to = $path;
503            $to .= '.' . time();
504    
505            rename $path, $to;
506            print ">> $to\n";
507    }
508    
509    exit;
510    
511  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
512    
# Line 153  sub writechunk Line 538  sub writechunk
538  {  {
539          my $str=shift;          my $str=shift;
540          my $count = $port->write($str);          my $count = $port->write($str);
541          print "#> ", as_hex( $str ), "\t[$count]\n";          my $len = length($str);
542            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
543            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
544  }  }
545    
546  sub as_hex {  sub as_hex {
# Line 172  sub read_bytes { Line 559  sub read_bytes {
559          my $data = '';          my $data = '';
560          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
561                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
562                    die "no bytes on port: $!" unless defined $b;
563                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
564                  $data .= $b;                  $data .= $b;
565          }          }
# Line 201  sub assert { Line 589  sub assert {
589          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
590  }  }
591    
592  our $dispatch;  use Digest::CRC;
593  sub dispatch {  
594          my ( $pattern, $coderef ) = @_;  sub crcccitt {
595          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
596          my $l = length($patt);          my $crc = Digest::CRC->new(
597          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
598          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
599            ) or die $!;
600          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
601                  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;  
         }  
602  }  }
603    
604  # my $checksum = checksum( $bytes );  # my $checksum = checksum( $bytes );
# Line 224  sub dispatch { Line 606  sub dispatch {
606  sub checksum {  sub checksum {
607          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
608    
609          my $xor = $checksum; # FIXME          my $len = ord(substr($bytes,2,1));
610            my $len_real = length($bytes) - 1;
611    
612            if ( $len_real != $len ) {
613                    print "length wrong: $len_real != $len\n";
614                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
615            }
616    
617            my $xor = crcccitt( substr($bytes,1) ); # skip D6
618            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
619    
620          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
621                  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";
622                    return $bytes . $xor;
623          }          }
624            return $bytes . $checksum;
625  }  }
626    
627  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
628    
629          sleep 1;        # FIXME remove  sub readchunk {
630    #       sleep 1;        # FIXME remove
631    
632          # read header of packet          # read header of packet
633          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 247  sub readchunk { Line 640  sub readchunk {
640          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
641    
642          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
643          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
644    
645          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;
646    
647          $assert->{len}      = $len;          $assert->{len}      = $len;
648          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
649    
650          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
651            # find longest match for incomming data
652            my ($to) = grep {
653                    my $match = substr($payload,0,length($_));
654                    m/^\Q$match\E/
655            } sort { length($a) <=> length($b) } keys %$dispatch;
656            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
657    
658            if ( defined $to ) {
659                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
660                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
661                    $dispatch->{ $to }->( $rest );
662            } else {
663                    print "NO DISPATCH for ",as_hex( $full ),"\n";
664            }
665    
666          return $data;          return $data;
667  }  }
# Line 262  sub readchunk { Line 669  sub readchunk {
669  sub str2bytes {  sub str2bytes {
670          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
671          my $b = $str;          my $b = $str;
672          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
673          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
674          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
675          my $bytes = eval $b;          my $bytes = eval $b;
676          die $@ if $@;          die $@ if $@;
677          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 273  sub str2bytes { Line 679  sub str2bytes {
679  }  }
680    
681  sub cmd {  sub cmd {
682          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
683            my $cmd_desc = shift || confess "no description?";
684            my @expect = @_;
685    
686          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
687    
688          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
689            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
690    
691            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
692          $assert->{send} = $cmd;          $assert->{send} = $cmd;
693          writechunk( $bytes );          writechunk( $bytes );
694    
695          if ( $expect ) {          while ( @expect ) {
696                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
697                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
698                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
699    
700                    next if defined $dispatch->{ $pattern };
701    
702                    $dispatch->{ substr($pattern,3) } = $coderef;
703                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
704          }          }
705    
706            readchunk;
707  }  }
708    
Legend:
Removed from v.10  
changed lines
  Added in v.54
  ViewVC Help
Powered by ViewVC 1.1.26