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

Diff of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.2  
changed lines
  Added in v.58

  ViewVC Help
Powered by ViewVC 1.1.26