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