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