/[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 18 by dpavlin, Fri Oct 3 12:31:58 2008 UTC revision 48 by dpavlin, Tue Jun 23 14:59:53 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 $meteor_server = '192.168.1.13:4671';
16    my $meteor_fh;
17    
18    sub meteor {
19            my @a = @_;
20            push @a, scalar localtime() if $a[0] =~ m{^info};
21    
22            if ( ! defined $meteor_fh ) {
23                    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            }
35    
36            if ( $meteor_fh ) {
37                    warn ">> meteor ",dump( @a );
38                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
39            }
40    }
41    
42    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                            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                            if ( my $path = static( $client,$1 ) ) {
94                                    warn ">> $path";
95                            } elsif ( $method =~ m{/scan} ) {
96                                    my $tags = scan_for_tags();
97                                    my $json = {};
98                                    map {
99                                            my $d = decode_tag($_);
100                                            $d->{sid} = $_;
101                                            push @{ $json->{tags} },  $d;
102                                    } keys %$tags;
103                                    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                            } 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    
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  my $debug = 0;  my $debug = 0;
133    
134    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    my $program_path = './program/';
142    my $secure_path = './secure/';
143    
144    # http server
145    my $http_server = 1;
146    
147    # 3M defaults: 8,4
148    my $max_rfid_block = 16;
149    my $read_blocks = 8;
150    
151  my $response = {  my $response = {
152          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
153          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 160  my $response = {
160          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
161  };  };
162    
163    GetOptions(
164            'd|debug+'    => \$debug,
165            'device=s'    => \$device,
166            'baudrate=i'  => \$baudrate,
167            'databits=i'  => \$databits,
168            'parity=s'    => \$parity,
169            'stopbits=i'  => \$stopbits,
170            'handshake=s' => \$handshake,
171            'meteor=s'    => \$meteor_server,
172            'http-server!' => \$http_server,
173    ) or die $!;
174    
175    my $verbose = $debug > 0 ? $debug-- : 0;
176    
177  =head1 NAME  =head1 NAME
178    
179  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
180    
181  =head1 SYNOPSIS  =head1 SYNOPSIS
182    
183  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
184    
185  =head1 DESCRIPTION  =head1 DESCRIPTION
186    
# Line 52  it under the same terms ans Perl itself. Line 205  it under the same terms ans Perl itself.
205    
206  =cut  =cut
207    
208  # your serial port.  my $tags_data;
209  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
210  $device    ||= "/dev/ttyUSB0";  
211  $baudrate  ||= "19200";  my $item_type = {
212  $databits  ||= "8";          1 => 'Book',
213  $parity    ||= "none";          6 => 'CD/CD ROM',
214  $stopbits  ||= "1";          2 => 'Magazine',
215  $handshake ||= "none";          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  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  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  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
231  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
232  $databits=$port->databits($databits);  $databits=$port->databits($databits);
233  $parity=$port->parity($parity);  $parity=$port->parity($parity);
234  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
235    
236  print "## using $device $baudrate $databits $parity $stopbits\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
237    
238  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
239  $port->lookclear();  $port->lookclear();
# Line 81  $port->read_char_time(5); Line 246  $port->read_char_time(5);
246    
247  # initial hand-shake with device  # initial hand-shake with device
248    
249  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
250       'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
251          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
252            print "hardware version $hw_ver\n";
253            meteor( 'info', "Found reader hardware $hw_ver" );
254  });  });
255    
256  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?',
257       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
258    
259  # start scanning for tags  sub scan_for_tags {
260    
261            my @tags;
262    
263  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
264       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
 dispatch(  
          'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8  
                 sub {  
265                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
266                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
                         my $tags = substr( $rest, 1 );  
267    
268                          my $tl = length( $tags );                          if ( ! $nr ) {
269                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  _log "no tags in range\n";
270                                    update_visible_tags();
271                                    meteor( 'info-none-in-range' );
272                                    $tags_data = {};
273                            } else {
274    
275                                    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    
279                                    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                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
282    
283                                    meteor( 'info-in-range', join(' ',@tags));
284    
285                                    update_visible_tags( @tags );
286                            }
287                    }
288            );
289    
290            diag "tags: ",dump( @tags );
291            return $tags_data;
292    
293                          my @tags;  }
                         push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );  
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
294    
295                          # XXX read first tag  # start scanning for tags
                         read_tag( @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    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                            if ( defined $tags_data->{$tag} ) {
314    #                               meteor( 'in-range', $tag );
315                            } else {
316                                    meteor( 'read', $tag );
317                                    read_tag( $tag );
318                            }
319                            $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    
325                    if ( -e "$program_path/$tag" ) {
326                                    meteor( 'write', $tag );
327                                    write_tag( $tag );
328                    }
329                    if ( -e "$secure_path/$tag" ) {
330                                    meteor( 'secure', $tag );
331                                    secure_tag( $tag );
332                    }
333            }
334    
335            foreach my $tag ( keys %$last_visible_tags ) {
336                    my $data = delete $tags_data->{$tag};
337                    print "removed tag $tag with data ",dump( $data ),"\n";
338                    meteor( 'removed', $tag );
339            }
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    my $tag_data_block;
345    
346    sub read_tag_data {
347            my ($start_block,$rest) = @_;
348            die "no rest?" unless $rest;
349    
350            my $last_block = 0;
351    
352            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                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
362                    my $data  = substr( $block, 2 );
363                    die "data payload should be 4 bytes" if length($data) != 4;
364                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
365                    $tag_data_block->{$tag}->[ $ord ] = $data;
366                    $last_block = $ord;
367            }
368            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
369    
370            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
371            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
372    
373            return $last_block + 1;
374    }
375    
376    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  ) foreach ( 1 .. 100 );                  branch => $br_lib >> 20,
392                    library => $br_lib & 0x000fffff,
393    
394  my $read_cached;                  custom => $custom,
395            };
396    
397            return $hash;
398    }
399    
400  sub read_tag {  sub read_tag {
401          my ( $tag ) = @_;          my ( $tag ) = @_;
402    
403            confess "no tag?" unless $tag;
404    
405          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
406    
407          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',          my $start_block = 0;
408                          "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {  
409  dispatch(       "D6 00  1F  02 00   $tag   ", sub { # 03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";          while ( $start_block < $max_rfid_block ) {
410                          my $rest = shift || die "no rest?";  
411                          warn "## DATA ", dump( $rest ) if $debug;                  cmd(
412                          my $blocks = ord(substr($rest,0,1));                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
413                          my @data;                                  "read $tag offset: $start_block blocks: $read_blocks",
414                          foreach my $nr ( 0 .. $blocks - 1 ) {                          "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                                  my $block = substr( $rest, 1 + $nr * 6, 6 );                                  $start_block = read_tag_data( $start_block, @_ );
416                                  warn "## block ",as_hex( $block ) if $debug;                                  warn "# read tag upto $start_block\n";
417                                  my $ord   = unpack('v',substr( $block, 0, 2 ));                          },
418                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;                          "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
419                                  my $data  = substr( $block, 2 );                                  print "FIXME: tag $tag ready? (expected block read instead)\n";
420                                  die "data payload should be 4 bytes" if length($data) != 4;                          },
421                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  );
422                                  $data[ $ord ] = $data;  
423                          }          }
424                          $read_cached->{ $tag } = join('', @data);  
425                          print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";          my $security;
426                  })  
427          });          cmd(
428                    "D6 00 0B 0A $tag 1234", "check security $tag",
429          #        D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4                  "D6 00 0D 0A 00", sub {
430  if (0) {                          my $rest = shift;
431          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );                          my $from_tag;
432                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
433          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
434          #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA                          $security = as_hex( $security );
435          warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";                          warn "# SECURITY $tag = $security\n";
436                    }
437            );
438    
439            print "TAG $tag ", dump(decode_tag( $tag ));
440    }
441    
442    sub write_tag {
443            my ($tag) = @_;
444    
445            my $path = "$program_path/$tag";
446    
447            my $data = read_file( $path );
448            my $hex_data;
449    
450            if ( $data =~ s{^hex\s+}{} ) {
451                    $hex_data = $data;
452                    $hex_data =~ s{\s+}{}g;
453            } else {
454    
455                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
456    
457                    my $max_len = $max_rfid_block * 4;
458    
459                    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            # pad to block size
469            $hex_data .= '00' x ( 4 - $len % 4 );
470            my $blocks = sprintf('%02x', length($hex_data) / 4);
471    
472            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
473    
474            cmd(
475                    "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            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
478    
479            my $to = $path;
480            $to .= '.' . time();
481    
482            rename $path, $to;
483            print ">> $to\n";
484    
485            delete $tags_data->{$tag};      # force re-read of tag
486  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
487    
488    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    exit;
507    
508  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
509    
510  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 188  sub writechunk Line 535  sub writechunk
535  {  {
536          my $str=shift;          my $str=shift;
537          my $count = $port->write($str);          my $count = $port->write($str);
538          print "#> ", as_hex( $str ), "\t[$count]" if $debug;          my $len = length($str);
539            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
540            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
541  }  }
542    
543  sub as_hex {  sub as_hex {
# Line 207  sub read_bytes { Line 556  sub read_bytes {
556          my $data = '';          my $data = '';
557          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
558                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
559                    die "no bytes on port: $!" unless defined $b;
560                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
561                  $data .= $b;                  $data .= $b;
562          }          }
# Line 236  sub assert { Line 586  sub assert {
586          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
587  }  }
588    
 our $dispatch;  
 sub dispatch {  
         my ( $pattern, $coderef ) = @_;  
         my $patt = substr( str2bytes($pattern), 3 ); # just payload  
         my $l = length($patt);  
         my $p = substr( $assert->{payload}, 0, $l );  
         warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;  
   
         if ( $assert->{payload} eq $assert->{expect} ) {  
                 warn "## no dispatch, payload expected" if $debug;  
         } elsif ( $p eq $patt ) {  
                 # if matched call with rest of payload  
                 $coderef->( substr( $assert->{payload}, $l ) );  
         } else {  
                 warn "## dispatch ignored" if $debug;  
         }  
 }  
   
589  use Digest::CRC;  use Digest::CRC;
590    
591  sub crcccitt {  sub crcccitt {
# Line 271  sub crcccitt { Line 603  sub crcccitt {
603  sub checksum {  sub checksum {
604          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
605    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
606          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
607          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
608    
609          if ( $len_real != $len ) {          if ( $len_real != $len ) {
610                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
611                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
612          }          }
613    
614            my $xor = crcccitt( substr($bytes,1) ); # skip D6
615            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
616    
617          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
618                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
619                  return $bytes . $xor;                  return $bytes . $xor;
# Line 289  sub checksum { Line 621  sub checksum {
621          return $bytes . $checksum;          return $bytes . $checksum;
622  }  }
623    
624  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
625    
626          sleep 1;        # FIXME remove  sub readchunk {
627    #       sleep 1;        # FIXME remove
628    
629          # read header of packet          # read header of packet
630          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 305  sub readchunk { Line 637  sub readchunk {
637          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
638    
639          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
640          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
641    
642          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
643    
644          $assert->{len}      = $len;          $assert->{len}      = $len;
645          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
646    
647          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          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    
655            if ( defined $to ) {
656                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
657                    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          return $data;          return $data;
664  }  }
# Line 330  sub str2bytes { Line 676  sub str2bytes {
676  }  }
677    
678  sub cmd {  sub cmd {
679          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
680            my $cmd_desc = shift || confess "no description?";
681            my @expect = @_;
682    
683          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
684    
685          # fix checksum if needed          # fix checksum if needed
686          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
687    
688          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
689          $assert->{send} = $cmd;          $assert->{send} = $cmd;
690          writechunk( $bytes );          writechunk( $bytes );
691    
692          if ( $expect ) {          while ( @expect ) {
693                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
694                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
695                  readchunk( $coderef );                  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          }          }
702    
703            readchunk;
704  }  }
705    
Legend:
Removed from v.18  
changed lines
  Added in v.48
  ViewVC Help
Powered by ViewVC 1.1.26