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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26