/[RFID]/cpr-m02.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 /cpr-m02.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 91 - (show annotations)
Fri Jul 16 16:34:13 2010 UTC (13 years, 8 months ago) by dpavlin
File MIME type: text/plain
File size: 22578 byte(s)
correct order by bytes from transponder
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 use Time::HiRes;
14
15 use IO::Socket::INET;
16
17 my $debug = 0;
18
19 my $tags_data;
20 my $tags_security;
21 my $visible_tags;
22
23 my $listen_port = 9000; # pick something not in use
24 my $server_url = "http://localhost:$listen_port";
25
26 sub http_server {
27
28 my $server = IO::Socket::INET->new(
29 Proto => 'tcp',
30 LocalPort => $listen_port,
31 Listen => SOMAXCONN,
32 Reuse => 1
33 );
34
35 die "can't setup server: $!" unless $server;
36
37 print "Server $0 ready at $server_url\n";
38
39 sub static {
40 my ($client,$path) = @_;
41
42 $path = "www/$path";
43 $path .= 'rfid.html' if $path =~ m{/$};
44
45 return unless -e $path;
46
47 my $type = 'text/plain';
48 $type = 'text/html' if $path =~ m{\.htm};
49 $type = 'application/javascript' if $path =~ m{\.js};
50
51 print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
52 open(my $html, $path);
53 while(<$html>) {
54 print $client $_;
55 }
56 close($html);
57
58 return $path;
59 }
60
61 while (my $client = $server->accept()) {
62 $client->autoflush(1);
63 my $request = <$client>;
64
65 warn "WEB << $request\n" if $debug;
66
67 if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
68 my $method = $1;
69 my $param;
70 if ( $method =~ s{\?(.+)}{} ) {
71 foreach my $p ( split(/[&;]/, $1) ) {
72 my ($n,$v) = split(/=/, $p, 2);
73 $param->{$n} = $v;
74 }
75 warn "WEB << param: ",dump( $param ) if $debug;
76 }
77 if ( my $path = static( $client,$1 ) ) {
78 warn "WEB >> $path" if $debug;
79 } elsif ( $method =~ m{/scan} ) {
80 my $tags = scan_for_tags();
81 my $json = { time => time() };
82 map {
83 my $d = decode_tag($_);
84 $d->{sid} = $_;
85 $d->{security} = $tags_security->{$_};
86 push @{ $json->{tags} }, $d;
87 } keys %$tags;
88 print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
89 $param->{callback}, "(", to_json($json), ")\r\n";
90 } elsif ( $method =~ m{/program} ) {
91
92 my $status = 501; # Not implementd
93
94 foreach my $p ( keys %$param ) {
95 next unless $p =~ m/^(E[0-9A-F]{15})$/;
96 my $tag = $1;
97 my $content = "\x04\x11\x00\x01" . $param->{$p};
98 $content = "\x00" if $param->{$p} eq 'blank';
99 $status = 302;
100
101 warn "PROGRAM $tag $content\n";
102 write_tag( $tag, $content );
103 secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
104 }
105
106 print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
107
108 } elsif ( $method =~ m{/secure(.js)} ) {
109
110 my $json = $1;
111
112 my $status = 501; # Not implementd
113
114 foreach my $p ( keys %$param ) {
115 next unless $p =~ m/^(E[0-9A-F]{15})$/;
116 my $tag = $1;
117 my $data = $param->{$p};
118 $status = 302;
119
120 warn "SECURE $tag $data\n";
121 secure_tag_with( $tag, $data );
122 }
123
124 if ( $json ) {
125 print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
126 $param->{callback}, "({ ok: 1 })\r\n";
127 } else {
128 print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
129 }
130
131 } else {
132 print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
133 }
134 } else {
135 print $client "HTTP/1.0 500 No method\r\n\r\n";
136 }
137 close $client;
138 }
139
140 die "server died";
141 }
142
143
144 my $last_message = {};
145 sub _message {
146 my $type = shift @_;
147 my $text = join(' ',@_);
148 my $last = $last_message->{$type};
149 if ( $text ne $last ) {
150 warn $type eq 'diag' ? '# ' : '', $text, "\n";
151 $last_message->{$type} = $text;
152 }
153 }
154
155 sub _log { _message('log',@_) };
156 sub diag { _message('diag',@_) };
157
158 my $device = "/dev/ttyUSB0";
159 my $baudrate = "38400";
160 my $databits = "8";
161 my $parity = "even";
162 my $stopbits = "1";
163 my $handshake = "none";
164
165 my $program_path = './program/';
166 my $secure_path = './secure/';
167
168 # http server
169 my $http_server = 1;
170
171 # 3M defaults: 8,4
172 # cards 16, stickers: 8
173 my $max_rfid_block = 8;
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 'http-server!' => \$http_server,
197 ) or die $!;
198
199 my $verbose = $debug > 0 ? $debug-- : 0;
200
201 =head1 NAME
202
203 3m-810 - support for 3M 810 RFID reader
204
205 =head1 SYNOPSIS
206
207 3m-810.pl --device /dev/ttyUSB0
208
209 =head1 DESCRIPTION
210
211 Communicate with 3M 810 RFID reader and document it's protocol
212
213 =head1 SEE ALSO
214
215 L<Device::SerialPort(3)>
216
217 L<perl(1)>
218
219 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
220
221 =head1 AUTHOR
222
223 Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
224
225 =head1 COPYRIGHT AND LICENSE
226
227 This program is free software; you may redistribute it and/or modify
228 it under the same terms ans Perl itself.
229
230 =cut
231
232 my $item_type = {
233 1 => 'Book',
234 6 => 'CD/CD ROM',
235 2 => 'Magazine',
236 13 => 'Book with Audio Tape',
237 9 => 'Book with CD/CD ROM',
238 0 => 'Other',
239
240 5 => 'Video',
241 4 => 'Audio Tape',
242 3 => 'Bound Journal',
243 8 => 'Book with Diskette',
244 7 => 'Diskette',
245 };
246
247 warn "## known item type: ",dump( $item_type ) if $debug;
248
249 my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
250 warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
251 $handshake=$port->handshake($handshake);
252 $baudrate=$port->baudrate($baudrate);
253 $databits=$port->databits($databits);
254 $parity=$port->parity($parity);
255 $stopbits=$port->stopbits($stopbits);
256
257 warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
258
259 # Just in case: reset our timing and buffers
260 $port->lookclear();
261 $port->read_const_time(100);
262 $port->read_char_time(5);
263
264 # Turn on parity checking:
265 #$port->stty_inpck(1);
266 #$port->stty_istrip(1);
267
268 sub cpr_m02_checksum {
269 my $data = shift;
270
271 my $preset = 0xffff;
272 my $polynom = 0x8408;
273
274 my $crc = $preset;
275 foreach my $i ( 0 .. length($data) - 1 ) {
276 $crc ^= ord(substr($data,$i,1));
277 for my $j ( 0 .. 7 ) {
278 if ( $crc & 0x0001 ) {
279 $crc = ( $crc >> 1 ) ^ $polynom;
280 } else {
281 $crc = $crc >> 1;
282 }
283 }
284 # warn sprintf('%d %04x', $i, $crc & 0xffff);
285 }
286
287 return pack('v', $crc);
288 }
289
290 sub cpr_psst_wait {
291 # Protocol Start Synchronization Time (PSST): 5ms < data timeout 12 ms
292 Time::HiRes::sleep 0.005;
293 }
294
295 sub cpr {
296 my ( $hex, $description, $coderef ) = @_;
297 my $bytes = str2bytes($hex);
298 my $len = pack( 'c', length( $bytes ) + 3 );
299 my $send = $len . $bytes;
300 my $checksum = cpr_m02_checksum($send);
301 $send .= $checksum;
302
303 warn ">> ", as_hex( $send ), "\t\t[$description]\n";
304 $port->write( $send );
305
306 cpr_psst_wait;
307
308 my $r_len = $port->read(1);
309
310 while ( ! $r_len ) {
311 warn "# wait for response length 5ms\n";
312 cpr_psst_wait;
313 $r_len = $port->read(1);
314 }
315
316 my $data_len = ord($r_len) - 1;
317 my $data = $port->read( $data_len );
318 warn "<< ", as_hex( $r_len . $data ),"\n";
319
320 cpr_psst_wait;
321
322 $coderef->( $data ) if $coderef;
323
324 }
325
326 # FF = COM-ADDR any
327
328 cpr( 'FF 52 00', 'Boud Rate Detection' );
329
330 cpr( 'FF 65', 'Get Software Version' );
331
332 cpr( 'FF 66 00', 'Get Reader Info - General hard and firware' );
333
334 cpr( 'FF 69', 'RF Reset' );
335
336
337 sub cpr_read {
338 my $uid = shift;
339 my $hex_uid = as_hex($uid);
340
341 my $max_block;
342
343 cpr( "FF B0 2B 01 $hex_uid", "Get System Information $hex_uid", sub {
344 my $data = shift;
345
346 warn "# data ",as_hex($data);
347
348 my $DSFID = substr($data,5-2,1);
349 my $UID = substr($data,6-2,8);
350 my $AFI = substr($data,14-2,1);
351 my $MEM = substr($data,15-2,1);
352 my $SIZE = substr($data,16-2,1);
353 my $IC_REF = substr($data,17-2,1);
354
355 warn "# split ",as_hex( $DSFID, $UID, $AFI, $MEM, $SIZE, $IC_REF );
356
357 $max_block = ord($SIZE);
358 });
359
360 my $transponder_data;
361
362 my $block = 0;
363 while ( $block < $max_block ) {
364 cpr( sprintf("FF B0 23 01 $hex_uid %02x 04", $block), "Read Multiple Blocks $block", sub {
365 my $data = shift;
366
367 my $DB_N = ord substr($data,5-2,1);
368 my $DB_SIZE = ord substr($data,6-2,1);
369
370 $data = substr($data,7-2,-2);
371 warn "# DB N: $DB_N SIZE: $DB_SIZE ", as_hex( $data );
372 foreach ( 1 .. $DB_N ) {
373 my $sec = substr($data,0,1);
374 my $db = substr($data,1,$DB_SIZE);
375 warn "block $_ ",dump( $sec, $db );
376 $transponder_data .= reverse split(//,$db);
377 $data = substr($data, $DB_SIZE + 1);
378 }
379 });
380 $block += 4;
381 }
382
383 warn "DATA $hex_uid ", dump($transponder_data);
384 exit;
385 }
386
387
388 my $inventory;
389
390 while(1) {
391
392 cpr( 'FF B0 01 00', 'ISO - Inventory', sub {
393 my $data = shift;
394 if (length($data) < 5 + 2 ) {
395 warn "# no tags in range\n";
396 return;
397 }
398 my $data_sets = ord(substr($data,3,1));
399 $data = substr($data,4);
400 foreach ( 1 .. $data_sets ) {
401 my $tr_type = substr($data,0,1);
402 die "FIXME only TR-TYPE=3 ISO 15693 supported" unless $tr_type eq "\x03";
403 my $dsfid = substr($data,1,1);
404 my $uid = substr($data,2,8);
405 $inventory->{$uid}++;
406 $data = substr($data,10);
407 warn "# TAG $_ ",as_hex( $tr_type, $dsfid, $uid ),$/;
408
409 cpr_read( $uid );
410 }
411 warn "inventory: ",dump($inventory);
412 });
413
414 }
415
416 #cpr( '', '?' );
417
418 exit;
419 # initial hand-shake with device
420
421 cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
422 'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
423 my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
424 print "hardware version $hw_ver\n";
425 });
426
427 cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?',
428 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } );
429
430 sub scan_for_tags {
431
432 my @tags;
433
434 cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags",
435 'D6 00 0F FE 00 00 05 ', sub { # 01 E00401003123AA26 941A # seen, serial length: 8
436 my $rest = shift || die "no rest?";
437 my $nr = ord( substr( $rest, 0, 1 ) );
438
439 if ( ! $nr ) {
440 _log "no tags in range\n";
441 update_visible_tags();
442 $tags_data = {};
443 } else {
444
445 my $tags = substr( $rest, 1 );
446 my $tl = length( $tags );
447 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
448
449 push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
450 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
451 _log "$nr tags in range: ", join(',', @tags ) , "\n";
452
453 update_visible_tags( @tags );
454 }
455 }
456 );
457
458 diag "tags: ",dump( @tags );
459 return $tags_data;
460
461 }
462
463 # start scanning for tags
464
465 if ( $http_server ) {
466 http_server;
467 } else {
468 while (1) {
469 scan_for_tags;
470 sleep 1;
471 }
472 }
473
474 die "over and out";
475
476 sub update_visible_tags {
477 my @tags = @_;
478
479 my $last_visible_tags = $visible_tags;
480 $visible_tags = {};
481
482 foreach my $tag ( @tags ) {
483 $visible_tags->{$tag}++;
484 if ( ! defined $last_visible_tags->{$tag} ) {
485 if ( defined $tags_data->{$tag} ) {
486 warn "$tag in range\n";
487 } else {
488 read_tag( $tag );
489 }
490 } else {
491 warn "## using cached data for $tag" if $debug;
492 }
493 delete $last_visible_tags->{$tag}; # leave just missing tags
494
495 if ( -e "$program_path/$tag" ) {
496 write_tag( $tag );
497 }
498 if ( -e "$secure_path/$tag" ) {
499 secure_tag( $tag );
500 }
501 }
502
503 foreach my $tag ( keys %$last_visible_tags ) {
504 my $data = delete $tags_data->{$tag};
505 warn "$tag removed ", dump($data), $/;
506 }
507
508 warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
509 }
510
511 my $tag_data_block;
512
513 sub read_tag_data {
514 my ($start_block,$rest) = @_;
515 die "no rest?" unless $rest;
516
517 my $last_block = 0;
518
519 warn "## DATA [$start_block] ", dump( $rest ) if $debug;
520 my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
521 my $blocks = ord(substr($rest,8,1));
522 $rest = substr($rest,9); # leave just data blocks
523 foreach my $nr ( 0 .. $blocks - 1 ) {
524 my $block = substr( $rest, $nr * 6, 6 );
525 warn "## block ",as_hex( $block ) if $debug;
526 my $ord = unpack('v',substr( $block, 0, 2 ));
527 my $expected_ord = $nr + $start_block;
528 warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
529 my $data = substr( $block, 2 );
530 die "data payload should be 4 bytes" if length($data) != 4;
531 warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
532 $tag_data_block->{$tag}->[ $ord ] = $data;
533 $last_block = $ord;
534 }
535 $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
536
537 my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
538 print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
539
540 return $last_block + 1;
541 }
542
543 my $saved_in_log;
544
545 sub decode_tag {
546 my $tag = shift;
547
548 my $data = $tags_data->{$tag};
549 if ( ! $data ) {
550 warn "no data for $tag\n";
551 return;
552 }
553
554 my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
555 my $hash = {
556 u1 => $u1,
557 u2 => $u2,
558 set => ( $set_item & 0xf0 ) >> 4,
559 total => ( $set_item & 0x0f ),
560
561 type => $type,
562 content => $content,
563
564 branch => $br_lib >> 20,
565 library => $br_lib & 0x000fffff,
566
567 custom => $custom,
568 };
569
570 if ( ! $saved_in_log->{$tag}++ ) {
571 open(my $log, '>>', 'rfid-log.txt');
572 print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
573 close($log);
574 }
575
576 return $hash;
577 }
578
579 sub forget_tag {
580 my $tag = shift;
581 delete $tags_data->{$tag};
582 delete $visible_tags->{$tag};
583 }
584
585 sub read_tag {
586 my ( $tag ) = @_;
587
588 confess "no tag?" unless $tag;
589
590 print "read_tag $tag\n";
591
592 my $start_block = 0;
593
594 while ( $start_block < $max_rfid_block ) {
595
596 cmd(
597 sprintf( "D6 00 0D 02 $tag %02x %02x BEEF", $start_block, $read_blocks ),
598 "read $tag offset: $start_block blocks: $read_blocks",
599 "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";
600 $start_block = read_tag_data( $start_block, @_ );
601 warn "# read tag upto $start_block\n";
602 },
603 "D6 00 0F FE 00 00 05 01 $tag BEEF", sub {
604 print "FIXME: tag $tag ready? (expected block read instead)\n";
605 },
606 "D6 00 0D 02 06 $tag", sub {
607 my $rest = shift;
608 print "ERROR reading $tag ", as_hex($rest), $/;
609 forget_tag $tag;
610 $start_block = $max_rfid_block; # XXX break out of while
611 },
612 );
613
614 }
615
616 my $security;
617
618 cmd(
619 "D6 00 0B 0A $tag BEEF", "check security $tag",
620 "D6 00 0D 0A 00", sub {
621 my $rest = shift;
622 my $from_tag;
623 ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
624 die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
625 $security = as_hex( $security );
626 $tags_security->{$tag} = $security;
627 warn "# SECURITY $tag = $security\n";
628 },
629 "D6 00 0C 0A 06", sub {
630 my $rest = shift;
631 warn "ERROR reading security from $rest\n";
632 forget_tag $tag;
633 },
634 );
635
636 print "TAG $tag ", dump(decode_tag( $tag ));
637 }
638
639 sub write_tag {
640 my ($tag,$data) = @_;
641
642 my $path = "$program_path/$tag";
643 $data = read_file( $path ) if -e $path;
644
645 die "no data" unless $data;
646
647 my $hex_data;
648
649 if ( $data =~ s{^hex\s+}{} ) {
650 $hex_data = $data;
651 $hex_data =~ s{\s+}{}g;
652 } else {
653
654 $data .= "\0" x ( 4 - ( length($data) % 4 ) );
655
656 my $max_len = $max_rfid_block * 4;
657
658 if ( length($data) > $max_len ) {
659 $data = substr($data,0,$max_len);
660 warn "strip content to $max_len bytes\n";
661 }
662
663 $hex_data = unpack('H*', $data);
664 }
665
666 my $len = length($hex_data) / 2;
667 # pad to block size
668 $hex_data .= '00' x ( 4 - $len % 4 );
669 my $blocks = sprintf('%02x', length($hex_data) / 4);
670
671 print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
672
673 cmd(
674 "d6 00 ff 04 $tag 00 $blocks 00 $hex_data BEEF", "write $tag",
675 "d6 00 0d 04 00 $tag $blocks BEEF", sub { assert() },
676 ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
677
678 my $to = $path;
679 $to .= '.' . time();
680
681 rename $path, $to;
682 print ">> $to\n";
683
684 forget_tag $tag;
685 }
686
687 sub secure_tag_with {
688 my ( $tag, $data ) = @_;
689
690 cmd(
691 "d6 00 0c 09 $tag $data BEEF", "secure $tag -> $data",
692 "d6 00 0c 09 00 $tag BEEF", sub { assert() },
693 );
694
695 forget_tag $tag;
696 }
697
698 sub secure_tag {
699 my ($tag) = @_;
700
701 my $path = "$secure_path/$tag";
702 my $data = substr(read_file( $path ),0,2);
703
704 secure_tag_with( $tag, $data );
705
706 my $to = $path;
707 $to .= '.' . time();
708
709 rename $path, $to;
710 print ">> $to\n";
711 }
712
713 exit;
714
715 for ( 1 .. 3 ) {
716
717 # ++-->type 00-0a
718 # 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
719 # 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
720 # 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
721
722 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 $_" );
723 warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
724
725 }
726 warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
727
728 cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
729
730 cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
731 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
732 cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
733 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
734
735 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',
736 'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
737
738 undef $port;
739 print "Port closed\n";
740
741 sub writechunk
742 {
743 my $str=shift;
744 my $count = $port->write($str);
745 my $len = length($str);
746 die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
747 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
748 }
749
750 sub as_hex {
751 my @out;
752 foreach my $str ( @_ ) {
753 my $hex = uc unpack( 'H*', $str );
754 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
755 $hex =~ s/\s+$//;
756 push @out, $hex;
757 }
758 return join(' | ', @out);
759 }
760
761 sub read_bytes {
762 my ( $len, $desc ) = @_;
763 my $data = '';
764 while ( length( $data ) < $len ) {
765 my ( $c, $b ) = $port->read(1);
766 die "no bytes on port: $!" unless defined $b;
767 warn "## got $c bytes: ", as_hex($b), "\n";
768 last if $c == 0;
769 $data .= $b;
770 }
771 $desc ||= '?';
772 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
773 return $data;
774 }
775
776 our $assert;
777
778 # my $rest = skip_assert( 3 );
779 sub skip_assert {
780 assert( 0, shift );
781 }
782
783 sub assert {
784 my ( $from, $to ) = @_;
785
786 $from ||= 0;
787 $to = length( $assert->{expect} ) if ! defined $to;
788
789 my $p = substr( $assert->{payload}, $from, $to );
790 my $e = substr( $assert->{expect}, $from, $to );
791 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
792
793 # return the rest
794 return substr( $assert->{payload}, $to );
795 }
796
797 use Digest::CRC;
798
799 sub crcccitt {
800 my $bytes = shift;
801 my $crc = Digest::CRC->new(
802 # midified CCITT to xor with 0xffff instead of 0x0000
803 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
804 ) or die $!;
805 $crc->add( $bytes );
806 pack('n', $crc->digest);
807 }
808
809 # my $checksum = checksum( $bytes );
810 # my $checksum = checksum( $bytes, $original_checksum );
811 sub checksum {
812 my ( $bytes, $checksum ) = @_;
813
814 my $len = ord(substr($bytes,2,1));
815 my $len_real = length($bytes) - 1;
816
817 if ( $len_real != $len ) {
818 print "length wrong: $len_real != $len\n";
819 $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
820 }
821
822 my $xor = crcccitt( substr($bytes,1) ); # skip D6
823 warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
824
825 if ( defined $checksum && $xor ne $checksum ) {
826 warn "checksum error: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n" if $checksum ne "\xBE\xEF";
827 return $bytes . $xor;
828 }
829 return $bytes . $checksum;
830 }
831
832 our $dispatch;
833
834 sub readchunk {
835 # sleep 1; # FIXME remove
836
837 # read header of packet
838 my $header = read_bytes( 2, 'header' );
839 my $length = read_bytes( 1, 'length' );
840 my $len = ord($length);
841 my $data = read_bytes( $len, 'data' );
842
843 my $payload = substr( $data, 0, -2 );
844 my $payload_len = length($data);
845 warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
846
847 my $checksum = substr( $data, -2, 2 );
848 checksum( $header . $length . $payload , $checksum );
849
850 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
851
852 $assert->{len} = $len;
853 $assert->{payload} = $payload;
854
855 my $full = $header . $length . $data; # full
856 # find longest match for incomming data
857 my ($to) = grep {
858 my $match = substr($payload,0,length($_));
859 m/^\Q$match\E/
860 } sort { length($a) <=> length($b) } keys %$dispatch;
861 warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
862
863 if ( defined $to ) {
864 my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
865 warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
866 $dispatch->{ $to }->( $rest );
867 } else {
868 die "NO DISPATCH for ",as_hex( $full ),"\n";
869 }
870
871 return $data;
872 }
873
874 sub str2bytes {
875 my $str = shift || confess "no str?";
876 my $b = $str;
877 $b =~ s/\s+//g;
878 $b =~ s/(..)/\\x$1/g;
879 $b = "\"$b\"";
880 my $bytes = eval $b;
881 die $@ if $@;
882 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
883 return $bytes;
884 }
885
886 sub cmd {
887 my $cmd = shift || confess "no cmd?";
888 my $cmd_desc = shift || confess "no description?";
889 my @expect = @_;
890
891 my $bytes = str2bytes( $cmd );
892
893 # fix checksum if needed
894 $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
895
896 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
897 $assert->{send} = $cmd;
898 writechunk( $bytes );
899
900 while ( @expect ) {
901 my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
902 my $coderef = shift @expect || confess "no coderef?";
903 confess "not coderef" unless ref $coderef eq 'CODE';
904
905 next if defined $dispatch->{ $pattern };
906
907 $dispatch->{ substr($pattern,3) } = $coderef;
908 warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
909 }
910
911 readchunk;
912 }
913

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26