/[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 17 by dpavlin, Fri Oct 3 08:53:57 2008 UTC revision 61 by dpavlin, Tue Feb 9 13:55:18 2010 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    use POSIX qw(strftime);
13    
14    use IO::Socket::INET;
15    
16  my $debug = 0;  my $debug = 0;
17    
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $meteor_server; # = '192.168.1.13:4671';
23    my $meteor_fh;
24    
25    sub meteor {
26            my @a = @_;
27            push @a, scalar localtime() if $a[0] =~ m{^info};
28    
29            if ( ! defined $meteor_fh ) {
30                    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            }
42    
43            if ( $meteor_fh ) {
44                    warn ">> meteor ",dump( @a );
45                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
46            }
47    }
48    
49    my $listen_port = 9000;                  # pick something not in use
50    my $server_url  = "http://localhost:$listen_port";
51    
52    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            print "Server $0 ready at $server_url\n";
64    
65            sub static {
66                    my ($client,$path) = @_;
67    
68                    $path = "www/$path";
69                    $path .= 'rfid.html' if $path =~ m{/$};
70    
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                    warn "WEB << $request\n" if $debug;
92    
93                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
94                            my $method = $1;
95                            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                                    warn "WEB << param: ",dump( $param ) if $debug;
102                            }
103                            if ( my $path = static( $client,$1 ) ) {
104                                    warn "WEB >> $path" if $debug;
105                            } elsif ( $method =~ m{/scan} ) {
106                                    my $tags = scan_for_tags();
107                                    my $json = { time => time() };
108                                    map {
109                                            my $d = decode_tag($_);
110                                            $d->{sid} = $_;
111                                            $d->{security} = $tags_security->{$_};
112                                            push @{ $json->{tags} },  $d;
113                                    } keys %$tags;
114                                    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                            } 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 = "\x04\x11\x00\x01" . $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                            } 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    
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    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    my $program_path = './program/';
167    my $secure_path = './secure/';
168    
169    # http server
170    my $http_server = 1;
171    
172    # 3M defaults: 8,4
173    my $max_rfid_block = 16;
174    my $read_blocks = 8;
175    
176  my $response = {  my $response = {
177          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
178          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 185  my $response = {
185          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
186  };  };
187    
188    GetOptions(
189            'd|debug+'    => \$debug,
190            'device=s'    => \$device,
191            'baudrate=i'  => \$baudrate,
192            'databits=i'  => \$databits,
193            'parity=s'    => \$parity,
194            'stopbits=i'  => \$stopbits,
195            'handshake=s' => \$handshake,
196            'meteor=s'    => \$meteor_server,
197            'http-server!' => \$http_server,
198    ) or die $!;
199    
200    my $verbose = $debug > 0 ? $debug-- : 0;
201    
202  =head1 NAME  =head1 NAME
203    
204  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
205    
206  =head1 SYNOPSIS  =head1 SYNOPSIS
207    
208  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
209    
210  =head1 DESCRIPTION  =head1 DESCRIPTION
211    
# Line 52  it under the same terms ans Perl itself. Line 230  it under the same terms ans Perl itself.
230    
231  =cut  =cut
232    
233  # your serial port.  my $item_type = {
234  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;          1 => 'Book',
235  $device    ||= "/dev/ttyUSB0";          6 => 'CD/CD ROM',
236  $baudrate  ||= "19200";          2 => 'Magazine',
237  $databits  ||= "8";          13 => 'Book with Audio Tape',
238  $parity    ||= "none";          9 => 'Book with CD/CD ROM',
239  $stopbits  ||= "1";          0 => 'Other',
240  $handshake ||= "none";  
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  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  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  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
253  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
254  $databits=$port->databits($databits);  $databits=$port->databits($databits);
255  $parity=$port->parity($parity);  $parity=$port->parity($parity);
256  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
257    
258  print "## using $device $baudrate $databits $parity $stopbits\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
259    
260  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
261  $port->lookclear();  $port->lookclear();
# Line 81  $port->read_char_time(5); Line 268  $port->read_char_time(5);
268    
269  # initial hand-shake with device  # initial hand-shake with device
270    
271  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
272       '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 {
273          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
274            print "hardware version $hw_ver\n";
275            meteor( 'info', "Found reader hardware $hw_ver" );
276  });  });
277    
278  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?',
279       '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() }  );
280    
281  # start scanning for tags  sub scan_for_tags {
282    
283  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",          my @tags;
284       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {  
285  dispatch(          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
286           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
                 sub {  
287                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
288                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
                         my $tags = substr( $rest, 1 );  
289    
290                          my $tl = length( $tags );                          if ( ! $nr ) {
291                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  _log "no tags in range\n";
292                                    update_visible_tags();
293                                    meteor( 'info-none-in-range' );
294                                    $tags_data = {};
295                            } else {
296    
297                                    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    
301                                    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                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
304    
305                                    meteor( 'info-in-range', join(' ',@tags));
306    
307                                    update_visible_tags( @tags );
308                            }
309                    }
310            );
311    
312            diag "tags: ",dump( @tags );
313            return $tags_data;
314    
315    }
316    
317                          my @tags;  # start scanning for 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";  
318    
319                          # XXX read first tag  if ( $http_server ) {
320                          read_tag( @tags );          http_server;
321    } else {
322            while (1) {
323                    scan_for_tags;
324                    sleep 1;
325            }
326    }
327    
328    die "over and out";
329    
330    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                    $visible_tags->{$tag}++;
338                    if ( ! defined $last_visible_tags->{$tag} ) {
339                            if ( defined $tags_data->{$tag} ) {
340    #                               meteor( 'in-range', $tag );
341                            } else {
342                                    meteor( 'read', $tag );
343                                    read_tag( $tag );
344                            }
345                    } else {
346                            warn "## using cached data for $tag" if $debug;
347                    }
348                    delete $last_visible_tags->{$tag}; # leave just missing tags
349    
350                    if ( -e "$program_path/$tag" ) {
351                                    meteor( 'write', $tag );
352                                    write_tag( $tag );
353                  }                  }
354  ) }                  if ( -e "$secure_path/$tag" ) {
355                                    meteor( 'secure', $tag );
356                                    secure_tag( $tag );
357                    }
358            }
359    
360            foreach my $tag ( keys %$last_visible_tags ) {
361                    my $data = delete $tags_data->{$tag};
362                    print "removed tag $tag with data ",dump( $data ),"\n";
363                    meteor( 'removed', $tag );
364            }
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    my $tag_data_block;
370    
371    sub read_tag_data {
372            my ($start_block,$rest) = @_;
373            die "no rest?" unless $rest;
374    
375            my $last_block = 0;
376    
377            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                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
387                    my $data  = substr( $block, 2 );
388                    die "data payload should be 4 bytes" if length($data) != 4;
389                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
390                    $tag_data_block->{$tag}->[ $ord ] = $data;
391                    $last_block = $ord;
392            }
393            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
394    
395            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
396            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
397    
398            return $last_block + 1;
399    }
400    
401    my $saved_in_log;
402    
403    sub decode_tag {
404            my $tag = shift;
405    
406  ) foreach ( 1 .. 100 );          my $data = $tags_data->{$tag} || die "no data for $tag";
407    
408  my $read_cached;          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            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            return $hash;
431    }
432    
433  sub read_tag {  sub read_tag {
434          my ( $tag ) = @_;          my ( $tag ) = @_;
435    
436            confess "no tag?" unless $tag;
437    
438          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
439    
440          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          my $start_block = 0;
441    
442            while ( $start_block < $max_rfid_block ) {
443    
444                    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            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                            $tags_security->{$tag} = $security;
469                            warn "# SECURITY $tag = $security\n";
470                    }
471            );
472    
473            print "TAG $tag ", dump(decode_tag( $tag ));
474    }
475    
476    sub write_tag {
477            my ($tag,$data) = @_;
478    
479            my $path = "$program_path/$tag";
480            $data = read_file( $path ) if -e $path;
481    
482            die "no data" unless $data;
483    
484            my $hex_data;
485    
486            if ( $data =~ s{^hex\s+}{} ) {
487                    $hex_data = $data;
488                    $hex_data =~ s{\s+}{}g;
489            } else {
490    
491                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
492    
493                    my $max_len = $max_rfid_block * 4;
494    
495                    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            # pad to block size
505            $hex_data .= '00' x ( 4 - $len % 4 );
506            my $blocks = sprintf('%02x', length($hex_data) / 4);
507    
508            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
509    
510            cmd(
511                    "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            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
514    
515            my $to = $path;
516            $to .= '.' . time();
517    
518          #        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          rename $path, $to;
519          warn "?? D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";          print ">> $to\n";
 if (0) {  
         cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
520    
521          #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00            delete $tags_data->{$tag};      # force re-read of tag
         #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
         warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";  
522  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
523    
524    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    exit;
543    
544  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
545    
546  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  sub writechunk Line 571  sub writechunk
571  {  {
572          my $str=shift;          my $str=shift;
573          my $count = $port->write($str);          my $count = $port->write($str);
574          print "#> ", as_hex( $str ), "\t[$count]\n";          my $len = length($str);
575            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
576            print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
577  }  }
578    
579  sub as_hex {  sub as_hex {
# Line 188  sub read_bytes { Line 592  sub read_bytes {
592          my $data = '';          my $data = '';
593          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
594                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
595                    die "no bytes on port: $!" unless defined $b;
596                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
597                  $data .= $b;                  $data .= $b;
598          }          }
# Line 217  sub assert { Line 622  sub assert {
622          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
623  }  }
624    
 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;  
         }  
 }  
   
625  use Digest::CRC;  use Digest::CRC;
626    
627  sub crcccitt {  sub crcccitt {
# Line 252  sub crcccitt { Line 639  sub crcccitt {
639  sub checksum {  sub checksum {
640          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
641    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
642          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
643          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
644    
645          if ( $len_real != $len ) {          if ( $len_real != $len ) {
646                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
647                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
648          }          }
649    
650            my $xor = crcccitt( substr($bytes,1) ); # skip D6
651            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
652    
653          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
654                  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";
655                  return $bytes . $xor;                  return $bytes . $xor;
# Line 270  sub checksum { Line 657  sub checksum {
657          return $bytes . $checksum;          return $bytes . $checksum;
658  }  }
659    
660  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
661    
662          sleep 1;        # FIXME remove  sub readchunk {
663    #       sleep 1;        # FIXME remove
664    
665          # read header of packet          # read header of packet
666          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 286  sub readchunk { Line 673  sub readchunk {
673          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
674    
675          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
676          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
677    
678          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;
679    
680          $assert->{len}      = $len;          $assert->{len}      = $len;
681          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
682    
683          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          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    
691            if ( defined $to ) {
692                    my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
693                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
694                    $dispatch->{ $to }->( $rest );
695            } else {
696                    print "NO DISPATCH for ",as_hex( $full ),"\n";
697            }
698    
699          return $data;          return $data;
700  }  }
# Line 311  sub str2bytes { Line 712  sub str2bytes {
712  }  }
713    
714  sub cmd {  sub cmd {
715          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
716            my $cmd_desc = shift || confess "no description?";
717            my @expect = @_;
718    
719          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
720    
721          # fix checksum if needed          # fix checksum if needed
722          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
723    
724          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
725          $assert->{send} = $cmd;          $assert->{send} = $cmd;
726          writechunk( $bytes );          writechunk( $bytes );
727    
728          if ( $expect ) {          while ( @expect ) {
729                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
730                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
731                  readchunk( $coderef );                  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          }          }
738    
739            readchunk;
740  }  }
741    
Legend:
Removed from v.17  
changed lines
  Added in v.61
  ViewVC Help
Powered by ViewVC 1.1.26