/[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

Annotation of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 36 - (hide annotations)
Mon Jun 1 09:39:44 2009 UTC (14 years, 10 months ago) by dpavlin
File MIME type: text/plain
File size: 14995 byte(s)
fix programming of data not to swap nibbles (sigh!)

1 dpavlin 1 #!/usr/bin/perl
2    
3     use Device::SerialPort qw (:STAT);
4     use strict;
5     use warnings;
6    
7     use Data::Dump qw/dump/;
8 dpavlin 2 use Carp qw/confess/;
9 dpavlin 19 use Getopt::Long;
10 dpavlin 29 use File::Slurp;
11 dpavlin 1
12 dpavlin 23 use IO::Socket::INET;
13    
14 dpavlin 25 my $meteor_server = '192.168.1.13:4671';
15 dpavlin 26 my $meteor_fh;
16 dpavlin 23
17     sub meteor {
18 dpavlin 25 my @a = @_;
19     push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21 dpavlin 26 if ( ! defined $meteor_fh ) {
22 dpavlin 35 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 dpavlin 26 }
34    
35 dpavlin 35 if ( $meteor_fh ) {
36     warn ">> meteor ",dump( @a );
37     print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
38     }
39 dpavlin 23 }
40    
41 dpavlin 4 my $debug = 0;
42    
43 dpavlin 19 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 dpavlin 29 my $program_path = './program/';
51 dpavlin 34 my $secure_path = './secure/';
52 dpavlin 29
53 dpavlin 1 my $response = {
54     'd500090400110a0500027250' => 'version?',
55     'd60007fe00000500c97b' => 'no tag in range',
56    
57     'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
58     'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
59     'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
60    
61     'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
62     'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
63     };
64    
65 dpavlin 19 GetOptions(
66 dpavlin 22 'd|debug+' => \$debug,
67 dpavlin 19 'device=s' => \$device,
68     'baudrate=i' => \$baudrate,
69     'databits=i' => \$databits,
70     'parity=s' => \$parity,
71     'stopbits=i' => \$stopbits,
72     'handshake=s' => \$handshake,
73 dpavlin 26 'meteor=s' => \$meteor_server,
74 dpavlin 19 ) or die $!;
75    
76 dpavlin 22 my $verbose = $debug > 0 ? $debug-- : 0;
77    
78 dpavlin 1 =head1 NAME
79    
80     3m-810 - support for 3M 810 RFID reader
81    
82     =head1 SYNOPSIS
83    
84 dpavlin 19 3m-810.pl --device /dev/ttyUSB0
85 dpavlin 1
86     =head1 DESCRIPTION
87    
88     Communicate with 3M 810 RFID reader and document it's protocol
89    
90     =head1 SEE ALSO
91    
92     L<Device::SerialPort(3)>
93    
94     L<perl(1)>
95    
96 dpavlin 15 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
97    
98 dpavlin 1 =head1 AUTHOR
99    
100     Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
101    
102     =head1 COPYRIGHT AND LICENSE
103    
104     This program is free software; you may redistribute it and/or modify
105     it under the same terms ans Perl itself.
106    
107     =cut
108    
109 dpavlin 23 my $tags_data;
110     my $visible_tags;
111    
112 dpavlin 31 my $item_type = {
113     1 => 'Book',
114     6 => 'CD/CD ROM',
115     2 => 'Magazine',
116     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 dpavlin 19 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 dpavlin 1 $handshake=$port->handshake($handshake);
132     $baudrate=$port->baudrate($baudrate);
133     $databits=$port->databits($databits);
134     $parity=$port->parity($parity);
135     $stopbits=$port->stopbits($stopbits);
136    
137 dpavlin 22 print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
138 dpavlin 1
139     # Just in case: reset our timing and buffers
140     $port->lookclear();
141     $port->read_const_time(100);
142     $port->read_char_time(5);
143    
144     # Turn on parity checking:
145     #$port->stty_inpck(1);
146     #$port->stty_istrip(1);
147    
148 dpavlin 4 # initial hand-shake with device
149    
150 dpavlin 20 cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
151     'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
152 dpavlin 23 my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
153     print "hardware version $hw_ver\n";
154 dpavlin 25 meteor( 'info', "Found reader hardware $hw_ver" );
155 dpavlin 2 });
156 dpavlin 1
157 dpavlin 20 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', sub { assert() } );
159 dpavlin 1
160 dpavlin 4 # start scanning for tags
161 dpavlin 1
162 dpavlin 20 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 dpavlin 22 update_visible_tags();
170 dpavlin 25 meteor( 'info-none-in-range' );
171 dpavlin 24 $tags_data = {};
172 dpavlin 20 } else {
173    
174 dpavlin 5 my $tags = substr( $rest, 1 );
175 dpavlin 1
176 dpavlin 5 my $tl = length( $tags );
177     die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
178    
179     my @tags;
180 dpavlin 16 push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
181 dpavlin 8 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
182 dpavlin 22 print "$nr tags in range: ", join(',', @tags ) , "\n";
183 dpavlin 16
184 dpavlin 25 meteor( 'info-in-range', join(' ',@tags));
185    
186 dpavlin 22 update_visible_tags( @tags );
187 dpavlin 5 }
188 dpavlin 20 }
189 dpavlin 24 ) while(1);
190     #) foreach ( 1 .. 100 );
191 dpavlin 5
192 dpavlin 22
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 dpavlin 25 if ( defined $tags_data->{$tag} ) {
203     # meteor( 'in-range', $tag );
204     } else {
205     meteor( 'read', $tag );
206     read_tag( $tag );
207     }
208 dpavlin 22 $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 dpavlin 29
214     if ( -e "$program_path/$tag" ) {
215     meteor( 'write', $tag );
216     write_tag( $tag );
217     }
218 dpavlin 34 if ( -e "$secure_path/$tag" ) {
219     meteor( 'secure', $tag );
220     secure_tag( $tag );
221     }
222 dpavlin 22 }
223    
224     foreach my $tag ( keys %$last_visible_tags ) {
225 dpavlin 23 my $data = delete $tags_data->{$tag};
226     print "removed tag $tag with data ",dump( $data ),"\n";
227 dpavlin 25 meteor( 'removed', $tag );
228 dpavlin 22 }
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 dpavlin 28 my $tag_data_block;
234 dpavlin 22
235 dpavlin 28 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 dpavlin 31
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 dpavlin 28 }
258    
259 dpavlin 16 sub read_tag {
260     my ( $tag ) = @_;
261 dpavlin 1
262 dpavlin 22 confess "no tag?" unless $tag;
263    
264 dpavlin 16 print "read_tag $tag\n";
265 dpavlin 1
266 dpavlin 20 cmd(
267 dpavlin 28 "D6 00 0D 02 $tag 00 03 1CC4", "read $tag offset: 0 blocks: 3",
268 dpavlin 20 "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 dpavlin 28 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 dpavlin 20 }
281     );
282 dpavlin 1
283 dpavlin 33 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 dpavlin 32 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 dpavlin 33 print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n";
304 dpavlin 32
305 dpavlin 16 }
306    
307 dpavlin 29 sub write_tag {
308     my ($tag) = @_;
309    
310     my $path = "$program_path/$tag";
311    
312     my $data = read_file( $path );
313    
314 dpavlin 30 $data = substr($data,0,16);
315 dpavlin 29
316 dpavlin 36 my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
317 dpavlin 30
318 dpavlin 36 print "write_tag $tag = ",dump( $data ), " == $hex_data\n";
319 dpavlin 30
320 dpavlin 29 cmd(
321 dpavlin 34 "d6 00 26 04 $tag 00 06 00 04 11 00 01 $hex_data 00 00 00 00 fd3b", "write $tag",
322     "d6 00 0d 04 00 $tag 06 afb1", sub { assert() },
323     ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!
324 dpavlin 29
325     my $to = $path;
326     $to .= '.' . time();
327    
328     rename $path, $to;
329     print ">> $to\n";
330    
331 dpavlin 30 delete $tags_data->{$tag}; # force re-read of tag
332 dpavlin 29 }
333    
334 dpavlin 34 sub secure_tag {
335     my ($tag) = @_;
336    
337     my $path = "$secure_path/$tag";
338     my $data = substr(read_file( $path ),0,2);
339    
340     cmd(
341     "d6 00 0c 09 $tag $data 1234", "secure $tag -> $data",
342     "d6 00 0c 09 00 $tag 1234", sub { assert() },
343     );
344    
345     my $to = $path;
346     $to .= '.' . time();
347    
348     rename $path, $to;
349     print ">> $to\n";
350     }
351    
352 dpavlin 19 exit;
353    
354 dpavlin 1 for ( 1 .. 3 ) {
355    
356     # ++-->type 00-0a
357     # D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4
358     # D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7
359     # D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F
360    
361     cmd(' D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00 8843', "write offset 0, block: 7 -- 0000000000 $_" );
362     warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
363    
364     }
365     warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
366    
367     cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
368    
369     cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
370     'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
371     cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
372     'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
373    
374     cmd('D6 00 26 04 E00401003123AA26 00 06 00 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 A98B', 'blank offset: 0 blocks: 6',
375     'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
376    
377     undef $port;
378     print "Port closed\n";
379    
380     sub writechunk
381     {
382     my $str=shift;
383     my $count = $port->write($str);
384 dpavlin 19 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
385 dpavlin 1 }
386    
387     sub as_hex {
388     my @out;
389     foreach my $str ( @_ ) {
390     my $hex = unpack( 'H*', $str );
391 dpavlin 2 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
392 dpavlin 8 $hex =~ s/\s+$//;
393 dpavlin 1 push @out, $hex;
394     }
395 dpavlin 8 return join(' | ', @out);
396 dpavlin 1 }
397    
398     sub read_bytes {
399     my ( $len, $desc ) = @_;
400     my $data = '';
401     while ( length( $data ) < $len ) {
402     my ( $c, $b ) = $port->read(1);
403 dpavlin 28 die "no bytes on port: $!" unless defined $b;
404 dpavlin 1 #warn "## got $c bytes: ", as_hex($b), "\n";
405     $data .= $b;
406     }
407     $desc ||= '?';
408 dpavlin 4 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
409 dpavlin 1 return $data;
410     }
411    
412 dpavlin 5 our $assert;
413 dpavlin 2
414 dpavlin 5 # my $rest = skip_assert( 3 );
415     sub skip_assert {
416     assert( 0, shift );
417     }
418    
419 dpavlin 2 sub assert {
420     my ( $from, $to ) = @_;
421    
422 dpavlin 5 $from ||= 0;
423 dpavlin 4 $to = length( $assert->{expect} ) if ! defined $to;
424    
425 dpavlin 2 my $p = substr( $assert->{payload}, $from, $to );
426     my $e = substr( $assert->{expect}, $from, $to );
427 dpavlin 3 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
428 dpavlin 5
429     # return the rest
430     return substr( $assert->{payload}, $to );
431 dpavlin 2 }
432    
433 dpavlin 15 use Digest::CRC;
434    
435     sub crcccitt {
436     my $bytes = shift;
437     my $crc = Digest::CRC->new(
438     # midified CCITT to xor with 0xffff instead of 0x0000
439     width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
440     ) or die $!;
441     $crc->add( $bytes );
442     pack('n', $crc->digest);
443     }
444    
445 dpavlin 8 # my $checksum = checksum( $bytes );
446     # my $checksum = checksum( $bytes, $original_checksum );
447     sub checksum {
448     my ( $bytes, $checksum ) = @_;
449    
450 dpavlin 15 my $xor = crcccitt( substr($bytes,1) ); # skip D6
451     warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
452 dpavlin 10
453 dpavlin 16 my $len = ord(substr($bytes,2,1));
454 dpavlin 17 my $len_real = length($bytes) - 1;
455 dpavlin 16
456 dpavlin 17 if ( $len_real != $len ) {
457     print "length wrong: $len_real != $len\n";
458     $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
459     }
460    
461 dpavlin 8 if ( defined $checksum && $xor ne $checksum ) {
462 dpavlin 10 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
463 dpavlin 16 return $bytes . $xor;
464 dpavlin 8 }
465 dpavlin 16 return $bytes . $checksum;
466 dpavlin 8 }
467    
468 dpavlin 20 our $dispatch;
469    
470 dpavlin 1 sub readchunk {
471 dpavlin 2 sleep 1; # FIXME remove
472    
473 dpavlin 1 # read header of packet
474     my $header = read_bytes( 2, 'header' );
475 dpavlin 2 my $length = read_bytes( 1, 'length' );
476     my $len = ord($length);
477 dpavlin 1 my $data = read_bytes( $len, 'data' );
478    
479 dpavlin 2 my $payload = substr( $data, 0, -2 );
480     my $payload_len = length($data);
481     warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
482 dpavlin 8
483 dpavlin 2 my $checksum = substr( $data, -2, 2 );
484 dpavlin 20 checksum( $header . $length . $payload , $checksum );
485 dpavlin 1
486 dpavlin 22 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
487 dpavlin 2
488     $assert->{len} = $len;
489     $assert->{payload} = $payload;
490    
491 dpavlin 20 my $full = $header . $length . $data; # full
492     # find longest match for incomming data
493     my ($to) = grep {
494     my $match = substr($payload,0,length($_));
495     m/^\Q$match\E/
496     } sort { length($a) <=> length($b) } keys %$dispatch;
497     warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
498 dpavlin 2
499 dpavlin 20 if ( defined $to ) {
500     my $rest = substr( $payload, length($to) );
501     warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
502     $dispatch->{ $to }->( $rest );
503     } else {
504     print "NO DISPATCH for ",dump( $full ),"\n";
505     }
506    
507 dpavlin 2 return $data;
508 dpavlin 1 }
509    
510 dpavlin 2 sub str2bytes {
511     my $str = shift || confess "no str?";
512 dpavlin 5 my $b = $str;
513 dpavlin 17 $b =~ s/\s+//g;
514     $b =~ s/(..)/\\x$1/g;
515     $b = "\"$b\"";
516 dpavlin 5 my $bytes = eval $b;
517 dpavlin 2 die $@ if $@;
518 dpavlin 5 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
519 dpavlin 2 return $bytes;
520     }
521    
522     sub cmd {
523 dpavlin 20 my $cmd = shift || confess "no cmd?";
524     my $cmd_desc = shift || confess "no description?";
525     my @expect = @_;
526    
527 dpavlin 2 my $bytes = str2bytes( $cmd );
528    
529 dpavlin 16 # fix checksum if needed
530     $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
531    
532 dpavlin 22 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
533 dpavlin 2 $assert->{send} = $cmd;
534     writechunk( $bytes );
535    
536 dpavlin 20 while ( @expect ) {
537     my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
538     my $coderef = shift @expect || confess "no coderef?";
539     confess "not coderef" unless ref $coderef eq 'CODE';
540    
541     next if defined $dispatch->{ $pattern };
542    
543     $dispatch->{ substr($pattern,3) } = $coderef;
544     warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
545 dpavlin 2 }
546 dpavlin 20
547     readchunk;
548 dpavlin 2 }
549    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26