/[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 48 - (hide annotations)
Tue Jun 23 14:59:53 2009 UTC (14 years, 9 months ago) by dpavlin
File MIME type: text/plain
File size: 17967 byte(s)
log just changed message to decrease output which now
prints out with nureadable speed

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26