/[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 34 by dpavlin, Wed Apr 8 15:03:49 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                    warn "# open connection to $meteor_server";
23                    $meteor_fh = IO::Socket::INET->new(
24                                    PeerAddr => $meteor_server,
25                                    Timeout => 1,
26                    ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
27                    $meteor_fh = 0; # don't try again
28            }
29    
30            warn ">> meteor ",dump( @a );
31            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
32    }
33    
34  my $debug = 0;  my $debug = 0;
35    
36    my $device    = "/dev/ttyUSB0";
37    my $baudrate  = "19200";
38    my $databits  = "8";
39    my $parity        = "none";
40    my $stopbits  = "1";
41    my $handshake = "none";
42    
43    my $program_path = './program/';
44    my $secure_path = './secure/';
45    
46  my $response = {  my $response = {
47          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
48          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 55  my $response = {
55          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
56  };  };
57    
58    GetOptions(
59            'd|debug+'    => \$debug,
60            'device=s'    => \$device,
61            'baudrate=i'  => \$baudrate,
62            'databits=i'  => \$databits,
63            'parity=s'    => \$parity,
64            'stopbits=i'  => \$stopbits,
65            'handshake=s' => \$handshake,
66            'meteor=s'    => \$meteor_server,
67    ) or die $!;
68    
69    my $verbose = $debug > 0 ? $debug-- : 0;
70    
71  =head1 NAME  =head1 NAME
72    
73  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
74    
75  =head1 SYNOPSIS  =head1 SYNOPSIS
76    
77  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
78    
79  =head1 DESCRIPTION  =head1 DESCRIPTION
80    
# Line 39  L<Device::SerialPort(3)> Line 86  L<Device::SerialPort(3)>
86    
87  L<perl(1)>  L<perl(1)>
88    
89    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
90    
91  =head1 AUTHOR  =head1 AUTHOR
92    
93  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 99  it under the same terms ans Perl itself.
99    
100  =cut  =cut
101    
102  # your serial port.  my $tags_data;
103  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
104  $device    ||= "/dev/ttyUSB0";  
105  $baudrate  ||= "19200";  my $item_type = {
106  $databits  ||= "8";          1 => 'Book',
107  $parity    ||= "none";          6 => 'CD/CD ROM',
108  $stopbits  ||= "1";          2 => 'Magazine',
109  $handshake ||= "none";          13 => 'Book with Audio Tape',
110            9 => 'Book with CD/CD ROM',
111            0 => 'Other',
112    
113            5 => 'Video',
114            4 => 'Audio Tape',
115            3 => 'Bound Journal',
116            8 => 'Book with Diskette',
117            7 => 'Diskette',
118    };
119    
120  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  warn "## known item type: ",dump( $item_type ) if $debug;
121    
122    my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
123    warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
124  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
125  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
126  $databits=$port->databits($databits);  $databits=$port->databits($databits);
127  $parity=$port->parity($parity);  $parity=$port->parity($parity);
128  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
129    
130  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
131    
132  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
133  $port->lookclear();  $port->lookclear();
# Line 79  $port->read_char_time(5); Line 140  $port->read_char_time(5);
140    
141  # initial hand-shake with device  # initial hand-shake with device
142    
143  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
144       '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 {
145          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
146            print "hardware version $hw_ver\n";
147            meteor( 'info', "Found reader hardware $hw_ver" );
148  });  });
149    
150  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?',
151       '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() }  );
152    
153  # start scanning for tags  # start scanning for tags
154    
155  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
156       '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
157  dispatch(                  my $rest = shift || die "no rest?";
158           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
159                  sub {  
160                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
161                          my $nr = ord( substr( $rest, 0, 1 ) );                          print "no tags in range\n";
162                            update_visible_tags();
163                            meteor( 'info-none-in-range' );
164                            $tags_data = {};
165                    } else {
166    
167                          my $tags = substr( $rest, 1 );                          my $tags = substr( $rest, 1 );
168    
169                          my $tl = length( $tags );                          my $tl = length( $tags );
170                          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;
171    
172                          my @tags;                          my @tags;
173                          push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
174                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
175                          print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";                          print "$nr tags in range: ", join(',', @tags ) , "\n";
176    
177                            meteor( 'info-in-range', join(' ',@tags));
178    
179                            update_visible_tags( @tags );
180                    }
181            }
182    ) while(1);
183    #) foreach ( 1 .. 100 );
184    
185    
186    
187    sub update_visible_tags {
188            my @tags = @_;
189    
190            my $last_visible_tags = $visible_tags;
191            $visible_tags = {};
192    
193            foreach my $tag ( @tags ) {
194                    if ( ! defined $last_visible_tags->{$tag} ) {
195                            if ( defined $tags_data->{$tag} ) {
196    #                               meteor( 'in-range', $tag );
197                            } else {
198                                    meteor( 'read', $tag );
199                                    read_tag( $tag );
200                            }
201                            $visible_tags->{$tag}++;
202                    } else {
203                            warn "## using cached data for $tag" if $debug;
204                    }
205                    delete $last_visible_tags->{$tag}; # leave just missing tags
206    
207                    if ( -e "$program_path/$tag" ) {
208                                    meteor( 'write', $tag );
209                                    write_tag( $tag );
210                    }
211                    if ( -e "$secure_path/$tag" ) {
212                                    meteor( 'secure', $tag );
213                                    secure_tag( $tag );
214                    }
215            }
216    
217            foreach my $tag ( keys %$last_visible_tags ) {
218                    my $data = delete $tags_data->{$tag};
219                    print "removed tag $tag with data ",dump( $data ),"\n";
220                    meteor( 'removed', $tag );
221            }
222    
223            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
224    }
225    
226    my $tag_data_block;
227    
228    sub read_tag_data {
229            my ($start_block,$rest) = @_;
230            die "no rest?" unless $rest;
231            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
232            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
233            my $blocks = ord(substr($rest,8,1));
234            $rest = substr($rest,9); # leave just data blocks
235            foreach my $nr ( 0 .. $blocks - 1 ) {
236                    my $block = substr( $rest, $nr * 6, 6 );
237                    warn "## block ",as_hex( $block ) if $debug;
238                    my $ord   = unpack('v',substr( $block, 0, 2 ));
239                    my $expected_ord = $nr + $start_block;
240                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
241                    my $data  = substr( $block, 2 );
242                    die "data payload should be 4 bytes" if length($data) != 4;
243                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
244                    $tag_data_block->{$tag}->[ $ord ] = $data;
245            }
246            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
247    
248            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
249            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
250    }
251    
252    sub read_tag {
253            my ( $tag ) = @_;
254    
255            confess "no tag?" unless $tag;
256    
257            print "read_tag $tag\n";
258    
259            cmd(
260                    "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
261                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
262                            print "FIXME: tag $tag ready?\n";
263                    },
264                    "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";
265                            read_tag_data( 0, @_ );
266                    },
267            );
268    
269            cmd(
270                    "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
271                    "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
272                            read_tag_data( 3, @_ );
273                    }
274            );
275    
276            my $security;
277    
278            cmd(
279                    "D6 00 0B 0A $tag 1234", "check security $tag",
280                    "D6 00 0D 0A 00", sub {
281                            my $rest = shift;
282                            my $from_tag;
283                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
284                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
285                            $security = as_hex( $security );
286                            warn "# SECURITY $tag = $security\n";
287                  }                  }
288  ) }          );
289    
290            my $data = $tags_data->{$tag} || die "no data for $tag";
291            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
292            my $set   = ( $set_item & 0xf0 ) >> 4;
293            my $total = ( $set_item & 0x0f );
294            my $branch  = $br_lib >> 20;
295            my $library = $br_lib & 0x000fffff;
296            print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n";
297    
298    }
299    
300    sub write_tag {
301            my ($tag) = @_;
302    
303  ) foreach ( 1 .. 100 );          my $path = "$program_path/$tag";
304    
305  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          my $data = read_file( $path );
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          $data = substr($data,0,16);
 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";  
308    
309  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) );
310    
311  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00            print "write_tag $tag = $data ",dump( $hex_data );
312  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
313  warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36          cmd(
314                                                                         05 00   00 00 00 00   06 00   00 00 00 00    524B\n";                  "d6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  fd3b", "write $tag",
315  warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";                  "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },
316            ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!
317    
318            my $to = $path;
319            $to .= '.' . time();
320    
321            rename $path, $to;
322            print ">> $to\n";
323    
324            delete $tags_data->{$tag};      # force re-read of tag
325    }
326    
327    sub secure_tag {
328            my ($tag) = @_;
329    
330            my $path = "$secure_path/$tag";
331            my $data = substr(read_file( $path ),0,2);
332    
333            cmd(
334                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
335                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
336            );
337    
338            my $to = $path;
339            $to .= '.' . time();
340    
341            rename $path, $to;
342            print ">> $to\n";
343    }
344    
345    exit;
346    
347  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
348    
# Line 153  sub writechunk Line 374  sub writechunk
374  {  {
375          my $str=shift;          my $str=shift;
376          my $count = $port->write($str);          my $count = $port->write($str);
377          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
378  }  }
379    
380  sub as_hex {  sub as_hex {
# Line 172  sub read_bytes { Line 393  sub read_bytes {
393          my $data = '';          my $data = '';
394          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
395                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
396                    die "no bytes on port: $!" unless defined $b;
397                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
398                  $data .= $b;                  $data .= $b;
399          }          }
# Line 201  sub assert { Line 423  sub assert {
423          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
424  }  }
425    
426  our $dispatch;  use Digest::CRC;
427  sub dispatch {  
428          my ( $pattern, $coderef ) = @_;  sub crcccitt {
429          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $bytes = shift;
430          my $l = length($patt);          my $crc = Digest::CRC->new(
431          my $p = substr( $assert->{payload}, 0, $l );                  # midified CCITT to xor with 0xffff instead of 0x0000
432          warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;                  width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
433            ) or die $!;
434          if ( $assert->{payload} eq $assert->{expect} ) {          $crc->add( $bytes );
435                  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;  
         }  
436  }  }
437    
438  # my $checksum = checksum( $bytes );  # my $checksum = checksum( $bytes );
# Line 224  sub dispatch { Line 440  sub dispatch {
440  sub checksum {  sub checksum {
441          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
442    
443          my $xor = $checksum; # FIXME          my $xor = crcccitt( substr($bytes,1) ); # skip D6
444            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
445    
446            my $len = ord(substr($bytes,2,1));
447            my $len_real = length($bytes) - 1;
448    
449            if ( $len_real != $len ) {
450                    print "length wrong: $len_real != $len\n";
451                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
452            }
453    
454          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
455                  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";
456                    return $bytes . $xor;
457          }          }
458            return $bytes . $checksum;
459  }  }
460    
461  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
462    
463    sub readchunk {
464          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
465    
466          # read header of packet          # read header of packet
# Line 247  sub readchunk { Line 474  sub readchunk {
474          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
475    
476          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
477          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
478    
479          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;
480    
481          $assert->{len}      = $len;          $assert->{len}      = $len;
482          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
483    
484          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          my $full = $header . $length . $data; # full
485            # find longest match for incomming data
486            my ($to) = grep {
487                    my $match = substr($payload,0,length($_));
488                    m/^\Q$match\E/
489            } sort { length($a) <=> length($b) } keys %$dispatch;
490            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
491    
492            if ( defined $to ) {
493                    my $rest = substr( $payload, length($to) );
494                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
495                    $dispatch->{ $to }->( $rest );
496            } else {
497                    print "NO DISPATCH for ",dump( $full ),"\n";
498            }
499    
500          return $data;          return $data;
501  }  }
# Line 262  sub readchunk { Line 503  sub readchunk {
503  sub str2bytes {  sub str2bytes {
504          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
505          my $b = $str;          my $b = $str;
506          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
507          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
508          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
509          my $bytes = eval $b;          my $bytes = eval $b;
510          die $@ if $@;          die $@ if $@;
511          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
# Line 273  sub str2bytes { Line 513  sub str2bytes {
513  }  }
514    
515  sub cmd {  sub cmd {
516          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
517            my $cmd_desc = shift || confess "no description?";
518            my @expect = @_;
519    
520          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
521    
522          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          # fix checksum if needed
523            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
524    
525            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
526          $assert->{send} = $cmd;          $assert->{send} = $cmd;
527          writechunk( $bytes );          writechunk( $bytes );
528    
529          if ( $expect ) {          while ( @expect ) {
530                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
531                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
532                  readchunk( $coderef );                  confess "not coderef" unless ref $coderef eq 'CODE';
533    
534                    next if defined $dispatch->{ $pattern };
535    
536                    $dispatch->{ substr($pattern,3) } = $coderef;
537                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
538          }          }
539    
540            readchunk;
541  }  }
542    
Legend:
Removed from v.10  
changed lines
  Added in v.34
  ViewVC Help
Powered by ViewVC 1.1.26