/[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 2 by dpavlin, Sun Sep 28 14:05:43 2008 UTC revision 42 by dpavlin, Thu Jun 4 13:52:10 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    
12    use IO::Socket::INET;
13    
14    my $meteor_server = '192.168.1.13:4671';
15    my $meteor_fh;
16    
17    sub meteor {
18            my @a = @_;
19            push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21            if ( ! defined $meteor_fh ) {
22                    if ( $meteor_fh =
23                                    IO::Socket::INET->new(
24                                            PeerAddr => $meteor_server,
25                                            Timeout => 1,
26                                    )
27                    ) {
28                            warn "# meteor connected to $meteor_server";
29                    } else {
30                            warn "can't connect to meteor $meteor_server: $!";
31                            $meteor_fh = 0;
32                    }
33            }
34    
35            if ( $meteor_fh ) {
36                    warn ">> meteor ",dump( @a );
37                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
38            }
39    }
40    
41    my $debug = 0;
42    
43    my $device    = "/dev/ttyUSB0";
44    my $baudrate  = "19200";
45    my $databits  = "8";
46    my $parity        = "none";
47    my $stopbits  = "1";
48    my $handshake = "none";
49    
50    my $program_path = './program/';
51    my $secure_path = './secure/';
52    
53    # 3M defaults: 8,4
54    my $max_rfid_block = 16;
55    my $read_blocks = 8;
56    
57  my $response = {  my $response = {
58          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 19  my $response = { Line 66  my $response = {
66          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
67  };  };
68    
69    GetOptions(
70            'd|debug+'    => \$debug,
71            'device=s'    => \$device,
72            'baudrate=i'  => \$baudrate,
73            'databits=i'  => \$databits,
74            'parity=s'    => \$parity,
75            'stopbits=i'  => \$stopbits,
76            'handshake=s' => \$handshake,
77            'meteor=s'    => \$meteor_server,
78    ) or die $!;
79    
80    my $verbose = $debug > 0 ? $debug-- : 0;
81    
82  =head1 NAME  =head1 NAME
83    
84  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
85    
86  =head1 SYNOPSIS  =head1 SYNOPSIS
87    
88  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
89    
90  =head1 DESCRIPTION  =head1 DESCRIPTION
91    
# Line 37  L<Device::SerialPort(3)> Line 97  L<Device::SerialPort(3)>
97    
98  L<perl(1)>  L<perl(1)>
99    
100    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
101    
102  =head1 AUTHOR  =head1 AUTHOR
103    
104  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
# Line 48  it under the same terms ans Perl itself. Line 110  it under the same terms ans Perl itself.
110    
111  =cut  =cut
112    
113  # your serial port.  my $tags_data;
114  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
115    
116  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  my $item_type = {
117            1 => 'Book',
118            6 => 'CD/CD ROM',
119            2 => 'Magazine',
120            13 => 'Book with Audio Tape',
121            9 => 'Book with CD/CD ROM',
122            0 => 'Other',
123    
124            5 => 'Video',
125            4 => 'Audio Tape',
126            3 => 'Bound Journal',
127            8 => 'Book with Diskette',
128            7 => 'Diskette',
129    };
130    
131    warn "## known item type: ",dump( $item_type ) if $debug;
132    
133    my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
134    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
135  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
136  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
137  $databits=$port->databits($databits);  $databits=$port->databits($databits);
138  $parity=$port->parity($parity);  $parity=$port->parity($parity);
139  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
140    
141  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
142    
143  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
144  $port->lookclear();  $port->lookclear();
# Line 75  $port->read_char_time(5); Line 149  $port->read_char_time(5);
149  #$port->stty_inpck(1);  #$port->stty_inpck(1);
150  #$port->stty_istrip(1);  #$port->stty_istrip(1);
151    
152  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  # initial hand-shake with device
153       'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {  
154          my ( $len, $payload, $checksum ) = @_;  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
155          assert( 0, 3 );       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
156          print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
157            print "hardware version $hw_ver\n";
158            meteor( 'info', "Found reader hardware $hw_ver" );
159  });  });
160    
161  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?',
162  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
163    
164    # start scanning for tags
165    
166    cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
167             'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
168                    my $rest = shift || die "no rest?";
169                    my $nr = ord( substr( $rest, 0, 1 ) );
170    
171  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",                  if ( ! $nr ) {
172       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );                          print "no tags in range\n";
173                            update_visible_tags();
174                            meteor( 'info-none-in-range' );
175                            $tags_data = {};
176                    } else {
177    
178  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen                          my $tags = substr( $rest, 1 );
179    
180                            my $tl = length( $tags );
181                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
182    
183                            my @tags;
184                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
185                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
186                            print "$nr tags in range: ", join(',', @tags ) , "\n";
187    
188                            meteor( 'info-in-range', join(' ',@tags));
189    
190                            update_visible_tags( @tags );
191                    }
192            }
193    ) while(1);
194    #) foreach ( 1 .. 100 );
195    
 cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );  
196    
 #     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  
 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";  
197    
198  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  sub update_visible_tags {
199            my @tags = @_;
200    
201  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            my $last_visible_tags = $visible_tags;
202  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA          $visible_tags = {};
203  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36  
204                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          foreach my $tag ( @tags ) {
205  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";                  if ( ! defined $last_visible_tags->{$tag} ) {
206                            if ( defined $tags_data->{$tag} ) {
207    #                               meteor( 'in-range', $tag );
208                            } else {
209                                    meteor( 'read', $tag );
210                                    read_tag( $tag );
211                            }
212                            $visible_tags->{$tag}++;
213                    } else {
214                            warn "## using cached data for $tag" if $debug;
215                    }
216                    delete $last_visible_tags->{$tag}; # leave just missing tags
217    
218                    if ( -e "$program_path/$tag" ) {
219                                    meteor( 'write', $tag );
220                                    write_tag( $tag );
221                    }
222                    if ( -e "$secure_path/$tag" ) {
223                                    meteor( 'secure', $tag );
224                                    secure_tag( $tag );
225                    }
226            }
227    
228            foreach my $tag ( keys %$last_visible_tags ) {
229                    my $data = delete $tags_data->{$tag};
230                    print "removed tag $tag with data ",dump( $data ),"\n";
231                    meteor( 'removed', $tag );
232            }
233    
234            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
235    }
236    
237    my $tag_data_block;
238    
239    sub read_tag_data {
240            my ($start_block,$rest) = @_;
241            die "no rest?" unless $rest;
242    
243            my $last_block = 0;
244    
245            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
246            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
247            my $blocks = ord(substr($rest,8,1));
248            $rest = substr($rest,9); # leave just data blocks
249            foreach my $nr ( 0 .. $blocks - 1 ) {
250                    my $block = substr( $rest, $nr * 6, 6 );
251                    warn "## block ",as_hex( $block ) if $debug;
252                    my $ord   = unpack('v',substr( $block, 0, 2 ));
253                    my $expected_ord = $nr + $start_block;
254                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
255                    my $data  = substr( $block, 2 );
256                    die "data payload should be 4 bytes" if length($data) != 4;
257                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
258                    $tag_data_block->{$tag}->[ $ord ] = $data;
259                    $last_block = $ord;
260            }
261            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
262    
263            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
264            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
265    
266            return $last_block + 1;
267    }
268    
269    sub read_tag {
270            my ( $tag ) = @_;
271    
272            confess "no tag?" unless $tag;
273    
274            print "read_tag $tag\n";
275    
276            my $start_block = 0;
277    
278            while ( $start_block < $max_rfid_block ) {
279    
280                    cmd(
281                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
282                                    "read $tag offset: $start_block blocks: $read_blocks",
283                            "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";
284                                    $start_block = read_tag_data( $start_block, @_ );
285                                    warn "# read tag upto $start_block\n";
286                            },
287                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
288                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
289                            },
290                    );
291    
292            }
293    
294            my $security;
295    
296            cmd(
297                    "D6 00 0B 0A $tag 1234", "check security $tag",
298                    "D6 00 0D 0A 00", sub {
299                            my $rest = shift;
300                            my $from_tag;
301                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
302                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
303                            $security = as_hex( $security );
304                            warn "# SECURITY $tag = $security\n";
305                    }
306            );
307    
308            my $data = $tags_data->{$tag} || die "no data for $tag";
309            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
310            my $set   = ( $set_item & 0xf0 ) >> 4;
311            my $total = ( $set_item & 0x0f );
312            my $branch  = $br_lib >> 20;
313            my $library = $br_lib & 0x000fffff;
314            print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' library: $library branch: $branch custom: $custom security: $security\n";
315    
316    }
317    
318    sub write_tag {
319            my ($tag) = @_;
320    
321            my $path = "$program_path/$tag";
322    
323            my $data = read_file( $path );
324            my $hex_data;
325    
326            if ( $data =~ s{^hex\s+}{} ) {
327                    $hex_data = $data;
328                    $hex_data =~ s{\s+}{}g;
329            } else {
330    
331                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
332    
333                    my $max_len = $max_rfid_block * 4;
334    
335                    if ( length($data) > $max_len ) {
336                            $data = substr($data,0,$max_len);
337                            warn "strip content to $max_len bytes\n";
338                    }
339    
340                    $hex_data = unpack('H*', $data);
341            }
342    
343            my $len = length($hex_data) / 2;
344            # pad to block size
345            $hex_data .= '00' x ( 4 - $len % 4 );
346            my $blocks = sprintf('%02x', length($hex_data) / 4);
347    
348            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
349    
350            cmd(
351                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
352                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
353            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
354    
355            my $to = $path;
356            $to .= '.' . time();
357    
358            rename $path, $to;
359            print ">> $to\n";
360    
361            delete $tags_data->{$tag};      # force re-read of tag
362    }
363    
364    sub secure_tag {
365            my ($tag) = @_;
366    
367            my $path = "$secure_path/$tag";
368            my $data = substr(read_file( $path ),0,2);
369    
370            cmd(
371                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
372                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
373            );
374    
375            my $to = $path;
376            $to .= '.' . time();
377    
378            rename $path, $to;
379            print ">> $to\n";
380    }
381    
382    exit;
383    
384  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
385    
# Line 133  sub writechunk Line 411  sub writechunk
411  {  {
412          my $str=shift;          my $str=shift;
413          my $count = $port->write($str);          my $count = $port->write($str);
414          print ">> ", as_hex( $str ), "\t[$count]\n";          my $len = length($str);
415            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
416            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
417  }  }
418    
419  sub as_hex {  sub as_hex {
# Line 141  sub as_hex { Line 421  sub as_hex {
421          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
422                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
423                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
424                    $hex =~ s/\s+$//;
425                  push @out, $hex;                  push @out, $hex;
426          }          }
427          return join('  ', @out);          return join(' | ', @out);
428  }  }
429    
430  sub read_bytes {  sub read_bytes {
# Line 151  sub read_bytes { Line 432  sub read_bytes {
432          my $data = '';          my $data = '';
433          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
434                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
435                    die "no bytes on port: $!" unless defined $b;
436                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
437                  $data .= $b;                  $data .= $b;
438          }          }
439          $desc ||= '?';          $desc ||= '?';
440          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
441          return $data;          return $data;
442  }  }
443    
444  my $assert;  our $assert;
445    
446    # my $rest = skip_assert( 3 );
447    sub skip_assert {
448            assert( 0, shift );
449    }
450    
451  sub assert {  sub assert {
452          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
453    
454          warn "# assert ", dump( $assert );          $from ||= 0;
455            $to = length( $assert->{expect} ) if ! defined $to;
456    
457          my $p = substr( $assert->{payload}, $from, $to );          my $p = substr( $assert->{payload}, $from, $to );
458          my $e = substr( $assert->{expect},  $from, $to );          my $e = substr( $assert->{expect},  $from, $to );
459          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), "\t[$from-$to]\n" if $e ne $p;          warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
460    
461            # return the rest
462            return substr( $assert->{payload}, $to );
463  }  }
464    
465  sub readchunk {  use Digest::CRC;
466          my ( $parser ) = @_;  
467    sub crcccitt {
468            my $bytes = shift;
469            my $crc = Digest::CRC->new(
470                    # midified CCITT to xor with 0xffff instead of 0x0000
471                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
472            ) or die $!;
473            $crc->add( $bytes );
474            pack('n', $crc->digest);
475    }
476    
477    # my $checksum = checksum( $bytes );
478    # my $checksum = checksum( $bytes, $original_checksum );
479    sub checksum {
480            my ( $bytes, $checksum ) = @_;
481    
482            my $len = ord(substr($bytes,2,1));
483            my $len_real = length($bytes) - 1;
484    
485            if ( $len_real != $len ) {
486                    print "length wrong: $len_real != $len\n";
487                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
488            }
489    
490            my $xor = crcccitt( substr($bytes,1) ); # skip D6
491            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
492    
493            if ( defined $checksum && $xor ne $checksum ) {
494                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
495                    return $bytes . $xor;
496            }
497            return $bytes . $checksum;
498    }
499    
500    our $dispatch;
501    
502    sub readchunk {
503          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
504    
505          # read header of packet          # read header of packet
# Line 181  sub readchunk { Line 507  sub readchunk {
507          my $length = read_bytes( 1, 'length' );          my $length = read_bytes( 1, 'length' );
508          my $len = ord($length);          my $len = ord($length);
509          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
         my ( $cmd ) = unpack('C', $data );  
510    
511          my $payload  = substr( $data, 0, -2 );          my $payload  = substr( $data, 0, -2 );
512          my $payload_len = length($data);          my $payload_len = length($data);
513          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
514    
515          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
516          # FIXME check checksum          checksum( $header . $length . $payload , $checksum );
517    
518          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
519    
520          $assert->{len}      = $len;          $assert->{len}      = $len;
521          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
         $assert->{checksum} = $checksum;  
522    
523          $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
524            # find longest match for incomming data
525            my ($to) = grep {
526                    my $match = substr($payload,0,length($_));
527                    m/^\Q$match\E/
528            } sort { length($a) <=> length($b) } keys %$dispatch;
529            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
530    
531            if ( defined $to ) {
532                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
533                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
534                    $dispatch->{ $to }->( $rest );
535            } else {
536                    print "NO DISPATCH for ",dump( $full ),"\n";
537            }
538    
539          return $data;          return $data;
540  }  }
541    
542  sub str2bytes {  sub str2bytes {
543          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
544          $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum          my $b = $str;
545          $str =~ s/\s+/\\x/g;          $b =~ s/\s+//g;
546          $str = '"\x' . $str . '"';          $b =~ s/(..)/\\x$1/g;
547          my $bytes = eval $str;          $b = "\"$b\"";
548            my $bytes = eval $b;
549          die $@ if $@;          die $@ if $@;
550            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
551          return $bytes;          return $bytes;
552  }  }
553    
554  sub cmd {  sub cmd {
555          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
556            my $cmd_desc = shift || confess "no description?";
557            my @expect = @_;
558    
559          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
560    
561          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
562            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
563    
564            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
565          $assert->{send} = $cmd;          $assert->{send} = $cmd;
566          writechunk( $bytes );          writechunk( $bytes );
567    
568          if ( $expect ) {          while ( @expect ) {
569                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
570                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
571                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
572    
573                    next if defined $dispatch->{ $pattern };
574    
575                    $dispatch->{ substr($pattern,3) } = $coderef;
576                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
577          }          }
578    
579            readchunk;
580  }  }
581    
Legend:
Removed from v.2  
changed lines
  Added in v.42
  ViewVC Help
Powered by ViewVC 1.1.26