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

Annotation of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (hide annotations)
Fri Jul 23 13:21:44 2010 UTC (12 years, 6 months ago) by dpavlin
File MIME type: text/plain
File size: 19628 byte(s)
fix wrongly changed program response

1 dpavlin 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 dpavlin 2 use Carp qw/confess/;
9 dpavlin 19 use Getopt::Long;
10 dpavlin 29 use File::Slurp;
11 dpavlin 44 use JSON;
12 dpavlin 59 use POSIX qw(strftime);
13 dpavlin 1
14 dpavlin 23 use IO::Socket::INET;
15    
16 dpavlin 50 my $debug = 0;
17    
18 dpavlin 54 my $tags_data;
19     my $tags_security;
20     my $visible_tags;
21    
22 dpavlin 43 my $listen_port = 9000; # pick something not in use
23 dpavlin 59 my $server_url = "http://localhost:$listen_port";
24    
25 dpavlin 43 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 dpavlin 80 die "can't setup server: $!" unless $server;
35 dpavlin 43
36 dpavlin 59 print "Server $0 ready at $server_url\n";
37 dpavlin 43
38     sub static {
39     my ($client,$path) = @_;
40    
41     $path = "www/$path";
42 dpavlin 56 $path .= 'rfid.html' if $path =~ m{/$};
43 dpavlin 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 dpavlin 50 warn "WEB << $request\n" if $debug;
65 dpavlin 43
66     if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67     my $method = $1;
68 dpavlin 46 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 dpavlin 50 warn "WEB << param: ",dump( $param ) if $debug;
75 dpavlin 46 }
76 dpavlin 43 if ( my $path = static( $client,$1 ) ) {
77 dpavlin 50 warn "WEB >> $path" if $debug;
78 dpavlin 43 } elsif ( $method =~ m{/scan} ) {
79     my $tags = scan_for_tags();
80 dpavlin 52 my $json = { time => time() };
81 dpavlin 44 map {
82     my $d = decode_tag($_);
83     $d->{sid} = $_;
84 dpavlin 54 $d->{security} = $tags_security->{$_};
85 dpavlin 44 push @{ $json->{tags} }, $d;
86     } keys %$tags;
87 dpavlin 71 print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
88 dpavlin 46 $param->{callback}, "(", to_json($json), ")\r\n";
89 dpavlin 59 } elsif ( $method =~ m{/program} ) {
90    
91     my $status = 501; # Not implementd
92    
93     foreach my $p ( keys %$param ) {
94 dpavlin 66 next unless $p =~ m/^(E[0-9A-F]{15})$/;
95 dpavlin 59 my $tag = $1;
96 dpavlin 61 my $content = "\x04\x11\x00\x01" . $param->{$p};
97 dpavlin 63 $content = "\x00" if $param->{$p} eq 'blank';
98 dpavlin 59 $status = 302;
99    
100     warn "PROGRAM $tag $content\n";
101     write_tag( $tag, $content );
102 dpavlin 68 secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
103 dpavlin 59 }
104    
105     print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
106    
107 dpavlin 71 } elsif ( $method =~ m{/secure(.js)} ) {
108 dpavlin 67
109 dpavlin 71 my $json = $1;
110    
111 dpavlin 67 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 dpavlin 71 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 dpavlin 67
130 dpavlin 43 } else {
131 dpavlin 71 print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
132 dpavlin 43 }
133     } else {
134 dpavlin 71 print $client "HTTP/1.0 500 No method\r\n\r\n";
135 dpavlin 43 }
136     close $client;
137     }
138    
139     die "server died";
140     }
141    
142 dpavlin 48
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 dpavlin 19 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 dpavlin 29 my $program_path = './program/';
165 dpavlin 34 my $secure_path = './secure/';
166 dpavlin 29
167 dpavlin 43 # http server
168     my $http_server = 1;
169    
170 dpavlin 41 # 3M defaults: 8,4
171 dpavlin 75 # cards 16, stickers: 8
172     my $max_rfid_block = 8;
173 dpavlin 41 my $read_blocks = 8;
174    
175 dpavlin 1 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 dpavlin 19 GetOptions(
188 dpavlin 22 'd|debug+' => \$debug,
189 dpavlin 19 'device=s' => \$device,
190     'baudrate=i' => \$baudrate,
191     'databits=i' => \$databits,
192     'parity=s' => \$parity,
193     'stopbits=i' => \$stopbits,
194     'handshake=s' => \$handshake,
195 dpavlin 45 'http-server!' => \$http_server,
196 dpavlin 19 ) or die $!;
197    
198 dpavlin 22 my $verbose = $debug > 0 ? $debug-- : 0;
199    
200 dpavlin 1 =head1 NAME
201    
202     3m-810 - support for 3M 810 RFID reader
203    
204     =head1 SYNOPSIS
205    
206 dpavlin 19 3m-810.pl --device /dev/ttyUSB0
207 dpavlin 1
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 dpavlin 15 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
219    
220 dpavlin 1 =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 dpavlin 31 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 dpavlin 19 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 dpavlin 1 $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 dpavlin 48 warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
257 dpavlin 1
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 dpavlin 4 # initial hand-shake with device
268    
269 dpavlin 20 cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
270     'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
271 dpavlin 23 my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
272     print "hardware version $hw_ver\n";
273 dpavlin 2 });
274 dpavlin 1
275 dpavlin 20 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 dpavlin 1
278 dpavlin 43 sub scan_for_tags {
279 dpavlin 1
280 dpavlin 43 my @tags;
281 dpavlin 20
282 dpavlin 48 cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags",
283 dpavlin 43 '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 dpavlin 20
287 dpavlin 43 if ( ! $nr ) {
288 dpavlin 48 _log "no tags in range\n";
289 dpavlin 43 update_visible_tags();
290     $tags_data = {};
291     } else {
292 dpavlin 1
293 dpavlin 43 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 dpavlin 16
297 dpavlin 43 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 dpavlin 48 _log "$nr tags in range: ", join(',', @tags ) , "\n";
300 dpavlin 25
301 dpavlin 43 update_visible_tags( @tags );
302     }
303 dpavlin 5 }
304 dpavlin 43 );
305 dpavlin 5
306 dpavlin 48 diag "tags: ",dump( @tags );
307 dpavlin 43 return $tags_data;
308 dpavlin 22
309 dpavlin 43 }
310 dpavlin 22
311 dpavlin 43 # start scanning for tags
312    
313     if ( $http_server ) {
314     http_server;
315     } else {
316 dpavlin 58 while (1) {
317     scan_for_tags;
318     sleep 1;
319     }
320 dpavlin 43 }
321    
322     die "over and out";
323    
324 dpavlin 22 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 dpavlin 51 $visible_tags->{$tag}++;
332 dpavlin 22 if ( ! defined $last_visible_tags->{$tag} ) {
333 dpavlin 25 if ( defined $tags_data->{$tag} ) {
334 dpavlin 64 warn "$tag in range\n";
335 dpavlin 25 } else {
336     read_tag( $tag );
337     }
338 dpavlin 22 } else {
339     warn "## using cached data for $tag" if $debug;
340     }
341     delete $last_visible_tags->{$tag}; # leave just missing tags
342 dpavlin 29
343     if ( -e "$program_path/$tag" ) {
344     write_tag( $tag );
345     }
346 dpavlin 34 if ( -e "$secure_path/$tag" ) {
347     secure_tag( $tag );
348     }
349 dpavlin 22 }
350    
351     foreach my $tag ( keys %$last_visible_tags ) {
352 dpavlin 23 my $data = delete $tags_data->{$tag};
353 dpavlin 64 warn "$tag removed ", dump($data), $/;
354 dpavlin 22 }
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 dpavlin 28 my $tag_data_block;
360 dpavlin 22
361 dpavlin 28 sub read_tag_data {
362     my ($start_block,$rest) = @_;
363     die "no rest?" unless $rest;
364 dpavlin 41
365     my $last_block = 0;
366    
367 dpavlin 28 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 dpavlin 41 warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
377 dpavlin 28 my $data = substr( $block, 2 );
378     die "data payload should be 4 bytes" if length($data) != 4;
379 dpavlin 40 warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
380 dpavlin 28 $tag_data_block->{$tag}->[ $ord ] = $data;
381 dpavlin 41 $last_block = $ord;
382 dpavlin 28 }
383     $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
384 dpavlin 31
385     my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
386 dpavlin 42 print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
387 dpavlin 41
388 dpavlin 42 return $last_block + 1;
389 dpavlin 28 }
390    
391 dpavlin 59 my $saved_in_log;
392    
393 dpavlin 43 sub decode_tag {
394     my $tag = shift;
395    
396 dpavlin 78 my $data = $tags_data->{$tag};
397     if ( ! $data ) {
398     warn "no data for $tag\n";
399     return;
400     }
401 dpavlin 43
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 dpavlin 59 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 dpavlin 43 return $hash;
425     }
426    
427 dpavlin 67 sub forget_tag {
428     my $tag = shift;
429     delete $tags_data->{$tag};
430     delete $visible_tags->{$tag};
431     }
432    
433 dpavlin 16 sub read_tag {
434     my ( $tag ) = @_;
435 dpavlin 1
436 dpavlin 22 confess "no tag?" unless $tag;
437    
438 dpavlin 16 print "read_tag $tag\n";
439 dpavlin 1
440 dpavlin 41 my $start_block = 0;
441 dpavlin 28
442 dpavlin 41 while ( $start_block < $max_rfid_block ) {
443 dpavlin 1
444 dpavlin 41 cmd(
445 dpavlin 65 sprintf( "D6 00 0D 02 $tag %02x %02x BEEF", $start_block, $read_blocks ),
446 dpavlin 41 "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 dpavlin 65 "D6 00 0F FE 00 00 05 01 $tag BEEF", sub {
452 dpavlin 41 print "FIXME: tag $tag ready? (expected block read instead)\n";
453     },
454 dpavlin 78 "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 dpavlin 41 );
461    
462     }
463    
464 dpavlin 33 my $security;
465    
466     cmd(
467 dpavlin 65 "D6 00 0B 0A $tag BEEF", "check security $tag",
468 dpavlin 33 "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 dpavlin 54 $tags_security->{$tag} = $security;
475 dpavlin 33 warn "# SECURITY $tag = $security\n";
476 dpavlin 78 },
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 dpavlin 33 );
483    
484 dpavlin 43 print "TAG $tag ", dump(decode_tag( $tag ));
485 dpavlin 16 }
486    
487 dpavlin 29 sub write_tag {
488 dpavlin 59 my ($tag,$data) = @_;
489 dpavlin 29
490     my $path = "$program_path/$tag";
491 dpavlin 59 $data = read_file( $path ) if -e $path;
492 dpavlin 29
493 dpavlin 59 die "no data" unless $data;
494    
495 dpavlin 38 my $hex_data;
496 dpavlin 29
497 dpavlin 38 if ( $data =~ s{^hex\s+}{} ) {
498     $hex_data = $data;
499     $hex_data =~ s{\s+}{}g;
500     } else {
501 dpavlin 29
502 dpavlin 38 $data .= "\0" x ( 4 - ( length($data) % 4 ) );
503 dpavlin 30
504 dpavlin 41 my $max_len = $max_rfid_block * 4;
505 dpavlin 30
506 dpavlin 38 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 dpavlin 40 # pad to block size
516     $hex_data .= '00' x ( 4 - $len % 4 );
517     my $blocks = sprintf('%02x', length($hex_data) / 4);
518 dpavlin 38
519     print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
520    
521 dpavlin 92 my $ok = 0;
522    
523 dpavlin 29 cmd(
524 dpavlin 65 "d6 00 ff 04 $tag 00 $blocks 00 $hex_data BEEF", "write $tag",
525 dpavlin 93 "d6 00 0d 04 00 $tag $blocks BEEF", sub { assert(); $ok++ },
526 dpavlin 92 "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 dpavlin 40 ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
531 dpavlin 29
532 dpavlin 92 if ( $ok ) {
533 dpavlin 29
534 dpavlin 92 my $to = $path;
535     $to .= '.' . time();
536 dpavlin 29
537 dpavlin 92 rename $path, $to;
538     print ">> $to\n";
539    
540     }
541    
542 dpavlin 67 forget_tag $tag;
543 dpavlin 29 }
544    
545 dpavlin 67 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 dpavlin 92 "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 dpavlin 67 );
556    
557     forget_tag $tag;
558     }
559    
560 dpavlin 34 sub secure_tag {
561     my ($tag) = @_;
562    
563     my $path = "$secure_path/$tag";
564     my $data = substr(read_file( $path ),0,2);
565    
566 dpavlin 67 secure_tag_with( $tag, $data );
567 dpavlin 34
568     my $to = $path;
569     $to .= '.' . time();
570    
571     rename $path, $to;
572     print ">> $to\n";
573     }
574    
575 dpavlin 19 exit;
576    
577 dpavlin 1 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 dpavlin 38 my $len = length($str);
608     die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
609 dpavlin 19 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
610 dpavlin 1 }
611    
612     sub as_hex {
613     my @out;
614     foreach my $str ( @_ ) {
615 dpavlin 78 my $hex = uc unpack( 'H*', $str );
616 dpavlin 2 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
617 dpavlin 8 $hex =~ s/\s+$//;
618 dpavlin 1 push @out, $hex;
619     }
620 dpavlin 8 return join(' | ', @out);
621 dpavlin 1 }
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 dpavlin 28 die "no bytes on port: $!" unless defined $b;
629 dpavlin 1 #warn "## got $c bytes: ", as_hex($b), "\n";
630     $data .= $b;
631     }
632     $desc ||= '?';
633 dpavlin 4 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
634 dpavlin 1 return $data;
635     }
636    
637 dpavlin 5 our $assert;
638 dpavlin 2
639 dpavlin 5 # my $rest = skip_assert( 3 );
640     sub skip_assert {
641     assert( 0, shift );
642     }
643    
644 dpavlin 2 sub assert {
645     my ( $from, $to ) = @_;
646    
647 dpavlin 5 $from ||= 0;
648 dpavlin 4 $to = length( $assert->{expect} ) if ! defined $to;
649    
650 dpavlin 2 my $p = substr( $assert->{payload}, $from, $to );
651     my $e = substr( $assert->{expect}, $from, $to );
652 dpavlin 3 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
653 dpavlin 5
654     # return the rest
655     return substr( $assert->{payload}, $to );
656 dpavlin 2 }
657    
658 dpavlin 15 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 dpavlin 8 # my $checksum = checksum( $bytes );
671     # my $checksum = checksum( $bytes, $original_checksum );
672     sub checksum {
673     my ( $bytes, $checksum ) = @_;
674    
675 dpavlin 16 my $len = ord(substr($bytes,2,1));
676 dpavlin 17 my $len_real = length($bytes) - 1;
677 dpavlin 16
678 dpavlin 17 if ( $len_real != $len ) {
679     print "length wrong: $len_real != $len\n";
680 dpavlin 38 $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
681 dpavlin 17 }
682    
683 dpavlin 38 my $xor = crcccitt( substr($bytes,1) ); # skip D6
684     warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
685    
686 dpavlin 8 if ( defined $checksum && $xor ne $checksum ) {
687 dpavlin 65 warn "checksum error: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n" if $checksum ne "\xBE\xEF";
688 dpavlin 16 return $bytes . $xor;
689 dpavlin 8 }
690 dpavlin 16 return $bytes . $checksum;
691 dpavlin 8 }
692    
693 dpavlin 20 our $dispatch;
694    
695 dpavlin 1 sub readchunk {
696 dpavlin 43 # sleep 1; # FIXME remove
697 dpavlin 2
698 dpavlin 1 # read header of packet
699     my $header = read_bytes( 2, 'header' );
700 dpavlin 2 my $length = read_bytes( 1, 'length' );
701     my $len = ord($length);
702 dpavlin 1 my $data = read_bytes( $len, 'data' );
703    
704 dpavlin 2 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 dpavlin 8
708 dpavlin 2 my $checksum = substr( $data, -2, 2 );
709 dpavlin 20 checksum( $header . $length . $payload , $checksum );
710 dpavlin 1
711 dpavlin 22 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
712 dpavlin 2
713     $assert->{len} = $len;
714     $assert->{payload} = $payload;
715    
716 dpavlin 20 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 dpavlin 2
724 dpavlin 42 if ( defined $to ) {
725     my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
726 dpavlin 20 warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
727     $dispatch->{ $to }->( $rest );
728     } else {
729 dpavlin 92 die "NO DISPATCH for ",as_hex( $full ), " in ", dump( $dispatch );
730 dpavlin 20 }
731    
732 dpavlin 2 return $data;
733 dpavlin 1 }
734    
735 dpavlin 2 sub str2bytes {
736     my $str = shift || confess "no str?";
737 dpavlin 5 my $b = $str;
738 dpavlin 17 $b =~ s/\s+//g;
739     $b =~ s/(..)/\\x$1/g;
740     $b = "\"$b\"";
741 dpavlin 5 my $bytes = eval $b;
742 dpavlin 2 die $@ if $@;
743 dpavlin 5 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
744 dpavlin 2 return $bytes;
745     }
746    
747     sub cmd {
748 dpavlin 20 my $cmd = shift || confess "no cmd?";
749     my $cmd_desc = shift || confess "no description?";
750     my @expect = @_;
751    
752 dpavlin 2 my $bytes = str2bytes( $cmd );
753    
754 dpavlin 16 # fix checksum if needed
755     $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
756    
757 dpavlin 22 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
758 dpavlin 2 $assert->{send} = $cmd;
759     writechunk( $bytes );
760    
761 dpavlin 20 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 dpavlin 2 }
771 dpavlin 20
772     readchunk;
773 dpavlin 2 }
774    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26