/[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 93 - (show annotations)
Fri Jul 23 13:21:44 2010 UTC (12 years, 4 months ago) by dpavlin
File MIME type: text/plain
File size: 19628 byte(s)
fix wrongly changed program response

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 my $ok = 0;
522
523 cmd(
524 "d6 00 ff 04 $tag 00 $blocks 00 $hex_data BEEF", "write $tag",
525 "d6 00 0d 04 00 $tag $blocks BEEF", sub { assert(); $ok++ },
526 "d6 00 0d 04 06 ", sub {
527 my $data = shift;
528 warn "no tag ",as_hex( substr($data,0,8) ), " in range for write\n";
529 },
530 ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
531
532 if ( $ok ) {
533
534 my $to = $path;
535 $to .= '.' . time();
536
537 rename $path, $to;
538 print ">> $to\n";
539
540 }
541
542 forget_tag $tag;
543 }
544
545 sub secure_tag_with {
546 my ( $tag, $data ) = @_;
547
548 cmd(
549 "d6 00 0c 09 $tag $data BEEF", "secure $tag -> $data",
550 "d6 00 0c 09 00 $tag BEEF", sub { assert() },
551 "d6 00 0c 09 06 ", sub {
552 my $data = shift;
553 warn "no tag ",as_hex( substr($data,0,8) ), " in range for secure\n";
554 },
555 );
556
557 forget_tag $tag;
558 }
559
560 sub secure_tag {
561 my ($tag) = @_;
562
563 my $path = "$secure_path/$tag";
564 my $data = substr(read_file( $path ),0,2);
565
566 secure_tag_with( $tag, $data );
567
568 my $to = $path;
569 $to .= '.' . time();
570
571 rename $path, $to;
572 print ">> $to\n";
573 }
574
575 exit;
576
577 for ( 1 .. 3 ) {
578
579 # ++-->type 00-0a
580 # 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
581 # 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
582 # 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
583
584 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 $_" );
585 warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
586
587 }
588 warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
589
590 cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
591
592 cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
593 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
594 cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
595 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
596
597 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',
598 'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
599
600 undef $port;
601 print "Port closed\n";
602
603 sub writechunk
604 {
605 my $str=shift;
606 my $count = $port->write($str);
607 my $len = length($str);
608 die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
609 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
610 }
611
612 sub as_hex {
613 my @out;
614 foreach my $str ( @_ ) {
615 my $hex = uc unpack( 'H*', $str );
616 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
617 $hex =~ s/\s+$//;
618 push @out, $hex;
619 }
620 return join(' | ', @out);
621 }
622
623 sub read_bytes {
624 my ( $len, $desc ) = @_;
625 my $data = '';
626 while ( length( $data ) < $len ) {
627 my ( $c, $b ) = $port->read(1);
628 die "no bytes on port: $!" unless defined $b;
629 #warn "## got $c bytes: ", as_hex($b), "\n";
630 $data .= $b;
631 }
632 $desc ||= '?';
633 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
634 return $data;
635 }
636
637 our $assert;
638
639 # my $rest = skip_assert( 3 );
640 sub skip_assert {
641 assert( 0, shift );
642 }
643
644 sub assert {
645 my ( $from, $to ) = @_;
646
647 $from ||= 0;
648 $to = length( $assert->{expect} ) if ! defined $to;
649
650 my $p = substr( $assert->{payload}, $from, $to );
651 my $e = substr( $assert->{expect}, $from, $to );
652 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
653
654 # return the rest
655 return substr( $assert->{payload}, $to );
656 }
657
658 use Digest::CRC;
659
660 sub crcccitt {
661 my $bytes = shift;
662 my $crc = Digest::CRC->new(
663 # midified CCITT to xor with 0xffff instead of 0x0000
664 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
665 ) or die $!;
666 $crc->add( $bytes );
667 pack('n', $crc->digest);
668 }
669
670 # my $checksum = checksum( $bytes );
671 # my $checksum = checksum( $bytes, $original_checksum );
672 sub checksum {
673 my ( $bytes, $checksum ) = @_;
674
675 my $len = ord(substr($bytes,2,1));
676 my $len_real = length($bytes) - 1;
677
678 if ( $len_real != $len ) {
679 print "length wrong: $len_real != $len\n";
680 $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
681 }
682
683 my $xor = crcccitt( substr($bytes,1) ); # skip D6
684 warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
685
686 if ( defined $checksum && $xor ne $checksum ) {
687 warn "checksum error: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n" if $checksum ne "\xBE\xEF";
688 return $bytes . $xor;
689 }
690 return $bytes . $checksum;
691 }
692
693 our $dispatch;
694
695 sub readchunk {
696 # sleep 1; # FIXME remove
697
698 # read header of packet
699 my $header = read_bytes( 2, 'header' );
700 my $length = read_bytes( 1, 'length' );
701 my $len = ord($length);
702 my $data = read_bytes( $len, 'data' );
703
704 my $payload = substr( $data, 0, -2 );
705 my $payload_len = length($data);
706 warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
707
708 my $checksum = substr( $data, -2, 2 );
709 checksum( $header . $length . $payload , $checksum );
710
711 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
712
713 $assert->{len} = $len;
714 $assert->{payload} = $payload;
715
716 my $full = $header . $length . $data; # full
717 # find longest match for incomming data
718 my ($to) = grep {
719 my $match = substr($payload,0,length($_));
720 m/^\Q$match\E/
721 } sort { length($a) <=> length($b) } keys %$dispatch;
722 warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
723
724 if ( defined $to ) {
725 my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
726 warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
727 $dispatch->{ $to }->( $rest );
728 } else {
729 die "NO DISPATCH for ",as_hex( $full ), " in ", dump( $dispatch );
730 }
731
732 return $data;
733 }
734
735 sub str2bytes {
736 my $str = shift || confess "no str?";
737 my $b = $str;
738 $b =~ s/\s+//g;
739 $b =~ s/(..)/\\x$1/g;
740 $b = "\"$b\"";
741 my $bytes = eval $b;
742 die $@ if $@;
743 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
744 return $bytes;
745 }
746
747 sub cmd {
748 my $cmd = shift || confess "no cmd?";
749 my $cmd_desc = shift || confess "no description?";
750 my @expect = @_;
751
752 my $bytes = str2bytes( $cmd );
753
754 # fix checksum if needed
755 $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
756
757 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
758 $assert->{send} = $cmd;
759 writechunk( $bytes );
760
761 while ( @expect ) {
762 my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
763 my $coderef = shift @expect || confess "no coderef?";
764 confess "not coderef" unless ref $coderef eq 'CODE';
765
766 next if defined $dispatch->{ $pattern };
767
768 $dispatch->{ substr($pattern,3) } = $coderef;
769 warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
770 }
771
772 readchunk;
773 }
774

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26