/[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 78 - (show annotations)
Mon Feb 15 14:10:08 2010 UTC (14 years, 1 month ago) by dpavlin
File MIME type: text/plain
File size: 19301 byte(s)
handle errors when reading tags

especially helpful for stickers which are less reliable when reading then cards

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26