/[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 67 - (show annotations)
Thu Feb 11 14:59:56 2010 UTC (14 years, 1 month ago) by dpavlin
File MIME type: text/plain
File size: 18670 byte(s)
added /secure REST API

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26