/[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 40 by dpavlin, Mon Jun 1 21:17:12 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;  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?',
55          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  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 39  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 50  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 79  $port->read_char_time(5); Line 147  $port->read_char_time(5);
147    
148  # initial hand-shake with device  # initial hand-shake with device
149    
150  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
151       '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 {
152          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\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','FIXME: unimplemented', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
159    
160  # start scanning for tags  # start scanning for tags
161    
162  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
163       '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
164  dispatch(                  my $rest = shift || die "no rest?";
165           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
166                  sub {  
167                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
168                          my $nr = ord( substr( $rest, 0, 1 ) );                          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 );                          my $tags = substr( $rest, 1 );
175    
176                          my $tl = length( $tags );                          my $tl = length( $tags );
177                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
178    
179                          my @tags;                          my @tags;
180                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
181                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
182                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
183    
184                            meteor( 'info-in-range', join(' ',@tags));
185    
186                            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  ) foreach ( 1 .. 100 );          my $security;
284    
285  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          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    sub write_tag {
308            my ($tag) = @_;
309    
310            my $path = "$program_path/$tag";
311    
312            my $data = read_file( $path );
313            my $hex_data;
314    
315            if ( $data =~ s{^hex\s+}{} ) {
316                    $hex_data = $data;
317                    $hex_data =~ s{\s+}{}g;
318            } else {
319    
320                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
321    
322                    my $max_len = 7 * 4;
323    
324                    if ( length($data) > $max_len ) {
325                            $data = substr($data,0,$max_len);
326                            warn "strip content to $max_len bytes\n";
327                    }
328    
329                    $hex_data = unpack('H*', $data);
330            }
331    
332            my $len = length($hex_data) / 2;
333            # pad to block size
334            $hex_data .= '00' x ( 4 - $len % 4 );
335            my $blocks = sprintf('%02x', length($hex_data) / 4);
336    
337            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
338    
339            cmd(
340                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
341                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
342            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
343    
344            my $to = $path;
345            $to .= '.' . time();
346    
347            rename $path, $to;
348            print ">> $to\n";
349    
350            delete $tags_data->{$tag};      # force re-read of tag
351    }
352    
353  #     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 secure_tag {
354  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) = @_;
355    
356  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          my $path = "$secure_path/$tag";
357            my $data = substr(read_file( $path ),0,2);
358    
359  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            cmd(
360  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA                  "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
361  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36                  "d6 00  0c  09 00  $tag  1234", sub { assert() },
362                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";          );
363  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";  
364            my $to = $path;
365            $to .= '.' . time();
366    
367            rename $path, $to;
368            print ">> $to\n";
369    }
370    
371    exit;
372    
373  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
374    
# Line 153  sub writechunk Line 400  sub writechunk
400  {  {
401          my $str=shift;          my $str=shift;
402          my $count = $port->write($str);          my $count = $port->write($str);
403          print "#> ", as_hex( $str ), "\t[$count]\n";          my $len = length($str);
404            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
405            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
406  }  }
407    
408  sub as_hex {  sub as_hex {
# Line 172  sub read_bytes { Line 421  sub read_bytes {
421          my $data = '';          my $data = '';
422          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
423                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
424                    die "no bytes on port: $!" unless defined $b;
425                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
426                  $data .= $b;                  $data .= $b;
427          }          }
# Line 190  sub skip_assert { Line 440  sub skip_assert {
440  sub assert {  sub assert {
441          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
442    
443            return unless $assert->{expect};
444    
445          $from ||= 0;          $from ||= 0;
446          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
447    
# Line 201  sub assert { Line 453  sub assert {
453          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
454  }  }
455    
456  our $dispatch;  use Digest::CRC;
457  sub dispatch {  
458          my ( $pattern, $coderef ) = @_;  sub crcccitt {
459          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
460          my $l = length($patt);          my $crc = Digest::CRC->new(
461          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
462          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
463            ) or die $!;
464          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
465                  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;  
         }  
466  }  }
467    
468  # my $checksum = checksum( $bytes );  # my $checksum = checksum( $bytes );
# Line 224  sub dispatch { Line 470  sub dispatch {
470  sub checksum {  sub checksum {
471          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
472    
473          my $xor = $checksum; # FIXME          my $len = ord(substr($bytes,2,1));
474            my $len_real = length($bytes) - 1;
475    
476            if ( $len_real != $len ) {
477                    print "length wrong: $len_real != $len\n";
478                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
479            }
480    
481            my $xor = crcccitt( substr($bytes,1) ); # skip D6
482            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
483    
484          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
485                  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";
486                    return $bytes . $xor;
487          }          }
488            return $bytes . $checksum;
489  }  }
490    
491  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
492    
493    sub readchunk {
494          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
495    
496          # read header of packet          # read header of packet
# Line 247  sub readchunk { Line 504  sub readchunk {
504          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
505    
506          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
507          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
508    
509          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;
510    
511          $assert->{len}      = $len;          $assert->{len}      = $len;
512          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
513    
514          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
515            # find longest match for incomming data
516            my ($to) = grep {
517                    my $match = substr($payload,0,length($_));
518                    m/^\Q$match\E/
519            } sort { length($a) <=> length($b) } keys %$dispatch;
520            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
521    
522            if ( defined $to && $payload ) {
523                    my $rest = substr( $payload, length($to) );
524                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
525                    $dispatch->{ $to }->( $rest );
526            } else {
527                    print "NO DISPATCH for ",dump( $full ),"\n";
528            }
529    
530          return $data;          return $data;
531  }  }
# Line 262  sub readchunk { Line 533  sub readchunk {
533  sub str2bytes {  sub str2bytes {
534          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
535          my $b = $str;          my $b = $str;
536          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
537          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
538          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
539          my $bytes = eval $b;          my $bytes = eval $b;
540          die $@ if $@;          die $@ if $@;
541          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 273  sub str2bytes { Line 543  sub str2bytes {
543  }  }
544    
545  sub cmd {  sub cmd {
546          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
547            my $cmd_desc = shift || confess "no description?";
548            my @expect = @_;
549    
550          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
551    
552          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
553            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
554    
555            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
556          $assert->{send} = $cmd;          $assert->{send} = $cmd;
557          writechunk( $bytes );          writechunk( $bytes );
558    
559          if ( $expect ) {          while ( @expect ) {
560                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
561                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
562                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
563    
564                    next if defined $dispatch->{ $pattern };
565    
566                    $dispatch->{ substr($pattern,3) } = $coderef;
567                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
568          }          }
569    
570            readchunk;
571  }  }
572    
Legend:
Removed from v.10  
changed lines
  Added in v.40
  ViewVC Help
Powered by ViewVC 1.1.26