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

Contents of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 61 - (show annotations)
Tue Feb 9 13:55:18 2010 UTC (14 years, 1 month ago) by dpavlin
File MIME type: text/plain
File size: 18881 byte(s)
program first 4 bytes as 3M software does

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 use Carp qw/confess/;
9 use Getopt::Long;
10 use File::Slurp;
11 use JSON;
12 use POSIX qw(strftime);
13
14 use IO::Socket::INET;
15
16 my $debug = 0;
17
18 my $tags_data;
19 my $tags_security;
20 my $visible_tags;
21
22 my $meteor_server; # = '192.168.1.13:4671';
23 my $meteor_fh;
24
25 sub meteor {
26 my @a = @_;
27 push @a, scalar localtime() if $a[0] =~ m{^info};
28
29 if ( ! defined $meteor_fh ) {
30 if ( $meteor_fh =
31 IO::Socket::INET->new(
32 PeerAddr => $meteor_server,
33 Timeout => 1,
34 )
35 ) {
36 warn "# meteor connected to $meteor_server";
37 } else {
38 warn "can't connect to meteor $meteor_server: $!";
39 $meteor_fh = 0;
40 }
41 }
42
43 if ( $meteor_fh ) {
44 warn ">> meteor ",dump( @a );
45 print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
46 }
47 }
48
49 my $listen_port = 9000; # pick something not in use
50 my $server_url = "http://localhost:$listen_port";
51
52 sub http_server {
53
54 my $server = IO::Socket::INET->new(
55 Proto => 'tcp',
56 LocalPort => $listen_port,
57 Listen => SOMAXCONN,
58 Reuse => 1
59 );
60
61 die "can't setup server" unless $server;
62
63 print "Server $0 ready at $server_url\n";
64
65 sub static {
66 my ($client,$path) = @_;
67
68 $path = "www/$path";
69 $path .= 'rfid.html' if $path =~ m{/$};
70
71 return unless -e $path;
72
73 my $type = 'text/plain';
74 $type = 'text/html' if $path =~ m{\.htm};
75 $type = 'application/javascript' if $path =~ m{\.js};
76
77 print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
78 open(my $html, $path);
79 while(<$html>) {
80 print $client $_;
81 }
82 close($html);
83
84 return $path;
85 }
86
87 while (my $client = $server->accept()) {
88 $client->autoflush(1);
89 my $request = <$client>;
90
91 warn "WEB << $request\n" if $debug;
92
93 if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
94 my $method = $1;
95 my $param;
96 if ( $method =~ s{\?(.+)}{} ) {
97 foreach my $p ( split(/[&;]/, $1) ) {
98 my ($n,$v) = split(/=/, $p, 2);
99 $param->{$n} = $v;
100 }
101 warn "WEB << param: ",dump( $param ) if $debug;
102 }
103 if ( my $path = static( $client,$1 ) ) {
104 warn "WEB >> $path" if $debug;
105 } elsif ( $method =~ m{/scan} ) {
106 my $tags = scan_for_tags();
107 my $json = { time => time() };
108 map {
109 my $d = decode_tag($_);
110 $d->{sid} = $_;
111 $d->{security} = $tags_security->{$_};
112 push @{ $json->{tags} }, $d;
113 } keys %$tags;
114 print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
115 $param->{callback}, "(", to_json($json), ")\r\n";
116 } elsif ( $method =~ m{/program} ) {
117
118 my $status = 501; # Not implementd
119
120 foreach my $p ( keys %$param ) {
121 next unless $p =~ m/^tag_(\S+)/;
122 my $tag = $1;
123 my $content = "\x04\x11\x00\x01" . $param->{$p};
124 $status = 302;
125
126 warn "PROGRAM $tag $content\n";
127 write_tag( $tag, $content );
128 }
129
130 print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
131
132 } else {
133 print $client "HTTP/1.0 404 Unkown method\r\n";
134 }
135 } else {
136 print $client "HTTP/1.0 500 No method\r\n";
137 }
138 close $client;
139 }
140
141 die "server died";
142 }
143
144
145 my $last_message = {};
146 sub _message {
147 my $type = shift @_;
148 my $text = join(' ',@_);
149 my $last = $last_message->{$type};
150 if ( $text ne $last ) {
151 warn $type eq 'diag' ? '# ' : '', $text, "\n";
152 $last_message->{$type} = $text;
153 }
154 }
155
156 sub _log { _message('log',@_) };
157 sub diag { _message('diag',@_) };
158
159 my $device = "/dev/ttyUSB0";
160 my $baudrate = "19200";
161 my $databits = "8";
162 my $parity = "none";
163 my $stopbits = "1";
164 my $handshake = "none";
165
166 my $program_path = './program/';
167 my $secure_path = './secure/';
168
169 # http server
170 my $http_server = 1;
171
172 # 3M defaults: 8,4
173 my $max_rfid_block = 16;
174 my $read_blocks = 8;
175
176 my $response = {
177 'd500090400110a0500027250' => 'version?',
178 'd60007fe00000500c97b' => 'no tag in range',
179
180 'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
181 'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
182 'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
183
184 'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
185 'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
186 };
187
188 GetOptions(
189 'd|debug+' => \$debug,
190 'device=s' => \$device,
191 'baudrate=i' => \$baudrate,
192 'databits=i' => \$databits,
193 'parity=s' => \$parity,
194 'stopbits=i' => \$stopbits,
195 'handshake=s' => \$handshake,
196 'meteor=s' => \$meteor_server,
197 'http-server!' => \$http_server,
198 ) or die $!;
199
200 my $verbose = $debug > 0 ? $debug-- : 0;
201
202 =head1 NAME
203
204 3m-810 - support for 3M 810 RFID reader
205
206 =head1 SYNOPSIS
207
208 3m-810.pl --device /dev/ttyUSB0
209
210 =head1 DESCRIPTION
211
212 Communicate with 3M 810 RFID reader and document it's protocol
213
214 =head1 SEE ALSO
215
216 L<Device::SerialPort(3)>
217
218 L<perl(1)>
219
220 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
221
222 =head1 AUTHOR
223
224 Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
225
226 =head1 COPYRIGHT AND LICENSE
227
228 This program is free software; you may redistribute it and/or modify
229 it under the same terms ans Perl itself.
230
231 =cut
232
233 my $item_type = {
234 1 => 'Book',
235 6 => 'CD/CD ROM',
236 2 => 'Magazine',
237 13 => 'Book with Audio Tape',
238 9 => 'Book with CD/CD ROM',
239 0 => 'Other',
240
241 5 => 'Video',
242 4 => 'Audio Tape',
243 3 => 'Bound Journal',
244 8 => 'Book with Diskette',
245 7 => 'Diskette',
246 };
247
248 warn "## known item type: ",dump( $item_type ) if $debug;
249
250 my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
251 warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
252 $handshake=$port->handshake($handshake);
253 $baudrate=$port->baudrate($baudrate);
254 $databits=$port->databits($databits);
255 $parity=$port->parity($parity);
256 $stopbits=$port->stopbits($stopbits);
257
258 warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
259
260 # Just in case: reset our timing and buffers
261 $port->lookclear();
262 $port->read_const_time(100);
263 $port->read_char_time(5);
264
265 # Turn on parity checking:
266 #$port->stty_inpck(1);
267 #$port->stty_istrip(1);
268
269 # initial hand-shake with device
270
271 cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
272 'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
273 my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
274 print "hardware version $hw_ver\n";
275 meteor( 'info', "Found reader hardware $hw_ver" );
276 });
277
278 cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?',
279 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } );
280
281 sub scan_for_tags {
282
283 my @tags;
284
285 cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags",
286 'D6 00 0F FE 00 00 05 ', sub { # 01 E00401003123AA26 941A # seen, serial length: 8
287 my $rest = shift || die "no rest?";
288 my $nr = ord( substr( $rest, 0, 1 ) );
289
290 if ( ! $nr ) {
291 _log "no tags in range\n";
292 update_visible_tags();
293 meteor( 'info-none-in-range' );
294 $tags_data = {};
295 } else {
296
297 my $tags = substr( $rest, 1 );
298 my $tl = length( $tags );
299 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
300
301 push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
302 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
303 _log "$nr tags in range: ", join(',', @tags ) , "\n";
304
305 meteor( 'info-in-range', join(' ',@tags));
306
307 update_visible_tags( @tags );
308 }
309 }
310 );
311
312 diag "tags: ",dump( @tags );
313 return $tags_data;
314
315 }
316
317 # start scanning for tags
318
319 if ( $http_server ) {
320 http_server;
321 } else {
322 while (1) {
323 scan_for_tags;
324 sleep 1;
325 }
326 }
327
328 die "over and out";
329
330 sub update_visible_tags {
331 my @tags = @_;
332
333 my $last_visible_tags = $visible_tags;
334 $visible_tags = {};
335
336 foreach my $tag ( @tags ) {
337 $visible_tags->{$tag}++;
338 if ( ! defined $last_visible_tags->{$tag} ) {
339 if ( defined $tags_data->{$tag} ) {
340 # meteor( 'in-range', $tag );
341 } else {
342 meteor( 'read', $tag );
343 read_tag( $tag );
344 }
345 } else {
346 warn "## using cached data for $tag" if $debug;
347 }
348 delete $last_visible_tags->{$tag}; # leave just missing tags
349
350 if ( -e "$program_path/$tag" ) {
351 meteor( 'write', $tag );
352 write_tag( $tag );
353 }
354 if ( -e "$secure_path/$tag" ) {
355 meteor( 'secure', $tag );
356 secure_tag( $tag );
357 }
358 }
359
360 foreach my $tag ( keys %$last_visible_tags ) {
361 my $data = delete $tags_data->{$tag};
362 print "removed tag $tag with data ",dump( $data ),"\n";
363 meteor( 'removed', $tag );
364 }
365
366 warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
367 }
368
369 my $tag_data_block;
370
371 sub read_tag_data {
372 my ($start_block,$rest) = @_;
373 die "no rest?" unless $rest;
374
375 my $last_block = 0;
376
377 warn "## DATA [$start_block] ", dump( $rest ) if $debug;
378 my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
379 my $blocks = ord(substr($rest,8,1));
380 $rest = substr($rest,9); # leave just data blocks
381 foreach my $nr ( 0 .. $blocks - 1 ) {
382 my $block = substr( $rest, $nr * 6, 6 );
383 warn "## block ",as_hex( $block ) if $debug;
384 my $ord = unpack('v',substr( $block, 0, 2 ));
385 my $expected_ord = $nr + $start_block;
386 warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
387 my $data = substr( $block, 2 );
388 die "data payload should be 4 bytes" if length($data) != 4;
389 warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
390 $tag_data_block->{$tag}->[ $ord ] = $data;
391 $last_block = $ord;
392 }
393 $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
394
395 my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
396 print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
397
398 return $last_block + 1;
399 }
400
401 my $saved_in_log;
402
403 sub decode_tag {
404 my $tag = shift;
405
406 my $data = $tags_data->{$tag} || die "no data for $tag";
407
408 my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
409 my $hash = {
410 u1 => $u1,
411 u2 => $u2,
412 set => ( $set_item & 0xf0 ) >> 4,
413 total => ( $set_item & 0x0f ),
414
415 type => $type,
416 content => $content,
417
418 branch => $br_lib >> 20,
419 library => $br_lib & 0x000fffff,
420
421 custom => $custom,
422 };
423
424 if ( ! $saved_in_log->{$tag}++ ) {
425 open(my $log, '>>', 'rfid-log.txt');
426 print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
427 close($log);
428 }
429
430 return $hash;
431 }
432
433 sub read_tag {
434 my ( $tag ) = @_;
435
436 confess "no tag?" unless $tag;
437
438 print "read_tag $tag\n";
439
440 my $start_block = 0;
441
442 while ( $start_block < $max_rfid_block ) {
443
444 cmd(
445 sprintf( "D6 00 0D 02 $tag %02x %02x ffff", $start_block, $read_blocks ),
446 "read $tag offset: $start_block blocks: $read_blocks",
447 "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";
448 $start_block = read_tag_data( $start_block, @_ );
449 warn "# read tag upto $start_block\n";
450 },
451 "D6 00 0F FE 00 00 05 01 $tag 941A", sub {
452 print "FIXME: tag $tag ready? (expected block read instead)\n";
453 },
454 );
455
456 }
457
458 my $security;
459
460 cmd(
461 "D6 00 0B 0A $tag 1234", "check security $tag",
462 "D6 00 0D 0A 00", sub {
463 my $rest = shift;
464 my $from_tag;
465 ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
466 die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
467 $security = as_hex( $security );
468 $tags_security->{$tag} = $security;
469 warn "# SECURITY $tag = $security\n";
470 }
471 );
472
473 print "TAG $tag ", dump(decode_tag( $tag ));
474 }
475
476 sub write_tag {
477 my ($tag,$data) = @_;
478
479 my $path = "$program_path/$tag";
480 $data = read_file( $path ) if -e $path;
481
482 die "no data" unless $data;
483
484 my $hex_data;
485
486 if ( $data =~ s{^hex\s+}{} ) {
487 $hex_data = $data;
488 $hex_data =~ s{\s+}{}g;
489 } else {
490
491 $data .= "\0" x ( 4 - ( length($data) % 4 ) );
492
493 my $max_len = $max_rfid_block * 4;
494
495 if ( length($data) > $max_len ) {
496 $data = substr($data,0,$max_len);
497 warn "strip content to $max_len bytes\n";
498 }
499
500 $hex_data = unpack('H*', $data);
501 }
502
503 my $len = length($hex_data) / 2;
504 # pad to block size
505 $hex_data .= '00' x ( 4 - $len % 4 );
506 my $blocks = sprintf('%02x', length($hex_data) / 4);
507
508 print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
509
510 cmd(
511 "d6 00 ff 04 $tag 00 $blocks 00 $hex_data ffff", "write $tag",
512 "d6 00 0d 04 00 $tag $blocks afb1", sub { assert() },
513 ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
514
515 my $to = $path;
516 $to .= '.' . time();
517
518 rename $path, $to;
519 print ">> $to\n";
520
521 delete $tags_data->{$tag}; # force re-read of tag
522 }
523
524 sub secure_tag {
525 my ($tag) = @_;
526
527 my $path = "$secure_path/$tag";
528 my $data = substr(read_file( $path ),0,2);
529
530 cmd(
531 "d6 00 0c 09 $tag $data 1234", "secure $tag -> $data",
532 "d6 00 0c 09 00 $tag 1234", sub { assert() },
533 );
534
535 my $to = $path;
536 $to .= '.' . time();
537
538 rename $path, $to;
539 print ">> $to\n";
540 }
541
542 exit;
543
544 for ( 1 .. 3 ) {
545
546 # ++-->type 00-0a
547 # 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
548 # 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
549 # 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
550
551 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 $_" );
552 warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
553
554 }
555 warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
556
557 cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
558
559 cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
560 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
561 cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
562 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
563
564 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',
565 'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
566
567 undef $port;
568 print "Port closed\n";
569
570 sub writechunk
571 {
572 my $str=shift;
573 my $count = $port->write($str);
574 my $len = length($str);
575 die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
576 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
577 }
578
579 sub as_hex {
580 my @out;
581 foreach my $str ( @_ ) {
582 my $hex = unpack( 'H*', $str );
583 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
584 $hex =~ s/\s+$//;
585 push @out, $hex;
586 }
587 return join(' | ', @out);
588 }
589
590 sub read_bytes {
591 my ( $len, $desc ) = @_;
592 my $data = '';
593 while ( length( $data ) < $len ) {
594 my ( $c, $b ) = $port->read(1);
595 die "no bytes on port: $!" unless defined $b;
596 #warn "## got $c bytes: ", as_hex($b), "\n";
597 $data .= $b;
598 }
599 $desc ||= '?';
600 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
601 return $data;
602 }
603
604 our $assert;
605
606 # my $rest = skip_assert( 3 );
607 sub skip_assert {
608 assert( 0, shift );
609 }
610
611 sub assert {
612 my ( $from, $to ) = @_;
613
614 $from ||= 0;
615 $to = length( $assert->{expect} ) if ! defined $to;
616
617 my $p = substr( $assert->{payload}, $from, $to );
618 my $e = substr( $assert->{expect}, $from, $to );
619 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
620
621 # return the rest
622 return substr( $assert->{payload}, $to );
623 }
624
625 use Digest::CRC;
626
627 sub crcccitt {
628 my $bytes = shift;
629 my $crc = Digest::CRC->new(
630 # midified CCITT to xor with 0xffff instead of 0x0000
631 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
632 ) or die $!;
633 $crc->add( $bytes );
634 pack('n', $crc->digest);
635 }
636
637 # my $checksum = checksum( $bytes );
638 # my $checksum = checksum( $bytes, $original_checksum );
639 sub checksum {
640 my ( $bytes, $checksum ) = @_;
641
642 my $len = ord(substr($bytes,2,1));
643 my $len_real = length($bytes) - 1;
644
645 if ( $len_real != $len ) {
646 print "length wrong: $len_real != $len\n";
647 $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
648 }
649
650 my $xor = crcccitt( substr($bytes,1) ); # skip D6
651 warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
652
653 if ( defined $checksum && $xor ne $checksum ) {
654 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
655 return $bytes . $xor;
656 }
657 return $bytes . $checksum;
658 }
659
660 our $dispatch;
661
662 sub readchunk {
663 # sleep 1; # FIXME remove
664
665 # read header of packet
666 my $header = read_bytes( 2, 'header' );
667 my $length = read_bytes( 1, 'length' );
668 my $len = ord($length);
669 my $data = read_bytes( $len, 'data' );
670
671 my $payload = substr( $data, 0, -2 );
672 my $payload_len = length($data);
673 warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
674
675 my $checksum = substr( $data, -2, 2 );
676 checksum( $header . $length . $payload , $checksum );
677
678 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
679
680 $assert->{len} = $len;
681 $assert->{payload} = $payload;
682
683 my $full = $header . $length . $data; # full
684 # find longest match for incomming data
685 my ($to) = grep {
686 my $match = substr($payload,0,length($_));
687 m/^\Q$match\E/
688 } sort { length($a) <=> length($b) } keys %$dispatch;
689 warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
690
691 if ( defined $to ) {
692 my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
693 warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
694 $dispatch->{ $to }->( $rest );
695 } else {
696 print "NO DISPATCH for ",as_hex( $full ),"\n";
697 }
698
699 return $data;
700 }
701
702 sub str2bytes {
703 my $str = shift || confess "no str?";
704 my $b = $str;
705 $b =~ s/\s+//g;
706 $b =~ s/(..)/\\x$1/g;
707 $b = "\"$b\"";
708 my $bytes = eval $b;
709 die $@ if $@;
710 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
711 return $bytes;
712 }
713
714 sub cmd {
715 my $cmd = shift || confess "no cmd?";
716 my $cmd_desc = shift || confess "no description?";
717 my @expect = @_;
718
719 my $bytes = str2bytes( $cmd );
720
721 # fix checksum if needed
722 $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
723
724 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
725 $assert->{send} = $cmd;
726 writechunk( $bytes );
727
728 while ( @expect ) {
729 my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
730 my $coderef = shift @expect || confess "no coderef?";
731 confess "not coderef" unless ref $coderef eq 'CODE';
732
733 next if defined $dispatch->{ $pattern };
734
735 $dispatch->{ substr($pattern,3) } = $coderef;
736 warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
737 }
738
739 readchunk;
740 }
741

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26