/[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 37 by dpavlin, Mon Jun 1 13:09:41 2009 UTC revision 71 by dpavlin, Thu Feb 11 20:57:51 2010 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10  use File::Slurp;  use File::Slurp;
11    use JSON;
12    use POSIX qw(strftime);
13    
14  use IO::Socket::INET;  use IO::Socket::INET;
15    
16  my $meteor_server = '192.168.1.13:4671';  my $debug = 0;
17  my $meteor_fh;  
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $listen_port = 9000;                  # pick something not in use
23    my $server_url  = "http://localhost:$listen_port";
24    
25    sub http_server {
26    
27            my $server = IO::Socket::INET->new(
28                    Proto     => 'tcp',
29                    LocalPort => $listen_port,
30                    Listen    => SOMAXCONN,
31                    Reuse     => 1
32            );
33                                                                      
34            die "can't setup server" unless $server;
35    
36            print "Server $0 ready at $server_url\n";
37    
38            sub static {
39                    my ($client,$path) = @_;
40    
41                    $path = "www/$path";
42                    $path .= 'rfid.html' if $path =~ m{/$};
43    
44                    return unless -e $path;
45    
46  sub meteor {                  my $type = 'text/plain';
47          my @a = @_;                  $type = 'text/html' if $path =~ m{\.htm};
48          push @a, scalar localtime() if $a[0] =~ m{^info};                  $type = 'application/javascript' if $path =~ m{\.js};
49    
50          if ( ! defined $meteor_fh ) {                  print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                  if ( $meteor_fh =                  open(my $html, $path);
52                                  IO::Socket::INET->new(                  while(<$html>) {
53                                          PeerAddr => $meteor_server,                          print $client $_;
54                                          Timeout => 1,                  }
55                                  )                  close($html);
56                  ) {  
57                          warn "# meteor connected to $meteor_server";                  return $path;
58            }
59    
60            while (my $client = $server->accept()) {
61                    $client->autoflush(1);
62                    my $request = <$client>;
63    
64                    warn "WEB << $request\n" if $debug;
65    
66                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                            my $method = $1;
68                            my $param;
69                            if ( $method =~ s{\?(.+)}{} ) {
70                                    foreach my $p ( split(/[&;]/, $1) ) {
71                                            my ($n,$v) = split(/=/, $p, 2);
72                                            $param->{$n} = $v;
73                                    }
74                                    warn "WEB << param: ",dump( $param ) if $debug;
75                            }
76                            if ( my $path = static( $client,$1 ) ) {
77                                    warn "WEB >> $path" if $debug;
78                            } elsif ( $method =~ m{/scan} ) {
79                                    my $tags = scan_for_tags();
80                                    my $json = { time => time() };
81                                    map {
82                                            my $d = decode_tag($_);
83                                            $d->{sid} = $_;
84                                            $d->{security} = $tags_security->{$_};
85                                            push @{ $json->{tags} },  $d;
86                                    } keys %$tags;
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
88                                            $param->{callback}, "(", to_json($json), ")\r\n";
89                            } elsif ( $method =~ m{/program} ) {
90    
91                                    my $status = 501; # Not implementd
92    
93                                    foreach my $p ( keys %$param ) {
94                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
95                                            my $tag = $1;
96                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
97                                            $content = "\x00" if $param->{$p} eq 'blank';
98                                            $status = 302;
99    
100                                            warn "PROGRAM $tag $content\n";
101                                            write_tag( $tag, $content );
102                                            secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
103                                    }
104    
105                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
106    
107                            } elsif ( $method =~ m{/secure(.js)} ) {
108    
109                                    my $json = $1;
110    
111                                    my $status = 501; # Not implementd
112    
113                                    foreach my $p ( keys %$param ) {
114                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
115                                            my $tag = $1;
116                                            my $data = $param->{$p};
117                                            $status = 302;
118    
119                                            warn "SECURE $tag $data\n";
120                                            secure_tag_with( $tag, $data );
121                                    }
122    
123                                    if ( $json ) {
124                                            print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
125                                                    $param->{callback}, "({ ok: 1 })\r\n";
126                                    } else {
127                                            print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
128                                    }
129    
130                            } else {
131                                    print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
132                            }
133                  } else {                  } else {
134                          warn "can't connect to meteor $meteor_server: $!";                          print $client "HTTP/1.0 500 No method\r\n\r\n";
                         $meteor_fh = 0;  
135                  }                  }
136                    close $client;
137          }          }
138    
139          if ( $meteor_fh ) {          die "server died";
140                  warn ">> meteor ",dump( @a );  }
141                  print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"  
142    
143    my $last_message = {};
144    sub _message {
145            my $type = shift @_;
146            my $text = join(' ',@_);
147            my $last = $last_message->{$type};
148            if ( $text ne $last ) {
149                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
150                    $last_message->{$type} = $text;
151          }          }
152  }  }
153    
154  my $debug = 0;  sub _log { _message('log',@_) };
155    sub diag { _message('diag',@_) };
156    
157  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
158  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 50  my $handshake = "none"; Line 164  my $handshake = "none";
164  my $program_path = './program/';  my $program_path = './program/';
165  my $secure_path = './secure/';  my $secure_path = './secure/';
166    
167    # http server
168    my $http_server = 1;
169    
170    # 3M defaults: 8,4
171    my $max_rfid_block = 16;
172    my $read_blocks = 8;
173    
174  my $response = {  my $response = {
175          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
176          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 70  GetOptions( Line 191  GetOptions(
191          'parity=s'    => \$parity,          'parity=s'    => \$parity,
192          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
193          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
194          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
195  ) or die $!;  ) or die $!;
196    
197  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 106  it under the same terms ans Perl itself. Line 227  it under the same terms ans Perl itself.
227    
228  =cut  =cut
229    
 my $tags_data;  
 my $visible_tags;  
   
230  my $item_type = {  my $item_type = {
231          1 => 'Book',          1 => 'Book',
232          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 134  $databits=$port->databits($databits); Line 252  $databits=$port->databits($databits);
252  $parity=$port->parity($parity);  $parity=$port->parity($parity);
253  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
254    
255  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
256    
257  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
258  $port->lookclear();  $port->lookclear();
# Line 151  cmd( 'D5 00  05   04 00 11 Line 269  cmd( 'D5 00  05   04 00 11
269       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
270          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
271          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
272  });  });
273    
274  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
275       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
276    
277  # start scanning for tags  sub scan_for_tags {
278    
279  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
280           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
281                  my $rest = shift || die "no rest?";          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
282                  my $nr = ord( substr( $rest, 0, 1 ) );                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
283                            my $rest = shift || die "no rest?";
284                  if ( ! $nr ) {                          my $nr = ord( substr( $rest, 0, 1 ) );
285                          print "no tags in range\n";  
286                          update_visible_tags();                          if ( ! $nr ) {
287                          meteor( 'info-none-in-range' );                                  _log "no tags in range\n";
288                          $tags_data = {};                                  update_visible_tags();
289                  } else {                                  $tags_data = {};
290                            } else {
291    
292                                    my $tags = substr( $rest, 1 );
293                                    my $tl = length( $tags );
294                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
295    
296                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
297                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
298                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
299    
300                          my $tags = substr( $rest, 1 );                                  update_visible_tags( @tags );
301                            }
302                    }
303            );
304    
305                          my $tl = length( $tags );          diag "tags: ",dump( @tags );
306                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;          return $tags_data;
307    
308                          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 "$nr tags in range: ", join(',', @tags ) , "\n";  
309    
310                          meteor( 'info-in-range', join(' ',@tags));  # start scanning for tags
311    
312                          update_visible_tags( @tags );  if ( $http_server ) {
313                  }          http_server;
314    } else {
315            while (1) {
316                    scan_for_tags;
317                    sleep 1;
318          }          }
319  ) while(1);  }
 #) foreach ( 1 .. 100 );  
   
320    
321    die "over and out";
322    
323  sub update_visible_tags {  sub update_visible_tags {
324          my @tags = @_;          my @tags = @_;
# Line 198  sub update_visible_tags { Line 327  sub update_visible_tags {
327          $visible_tags = {};          $visible_tags = {};
328    
329          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
330                    $visible_tags->{$tag}++;
331                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
332                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
333  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
334                          } else {                          } else {
                                 meteor( 'read', $tag );  
335                                  read_tag( $tag );                                  read_tag( $tag );
336                          }                          }
                         $visible_tags->{$tag}++;  
337                  } else {                  } else {
338                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
339                  }                  }
340                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
341    
342                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
343                                  write_tag( $tag );                                  write_tag( $tag );
344                  }                  }
345                  if ( -e "$secure_path/$tag" ) {                  if ( -e "$secure_path/$tag" ) {
                                 meteor( 'secure', $tag );  
346                                  secure_tag( $tag );                                  secure_tag( $tag );
347                  }                  }
348          }          }
349    
350          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
351                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
352                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
353          }          }
354    
355          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
# Line 235  my $tag_data_block; Line 360  my $tag_data_block;
360  sub read_tag_data {  sub read_tag_data {
361          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
362          die "no rest?" unless $rest;          die "no rest?" unless $rest;
363    
364            my $last_block = 0;
365    
366          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
367          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
368          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 244  sub read_tag_data { Line 372  sub read_tag_data {
372                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
373                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
374                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
375                  die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;                  warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
376                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
377                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
378                  warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
379                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
380                    $last_block = $ord;
381          }          }
382          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
383    
384          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
385          print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";          print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
386    
387            return $last_block + 1;
388    }
389    
390    my $saved_in_log;
391    
392    sub decode_tag {
393            my $tag = shift;
394    
395            my $data = $tags_data->{$tag} || die "no data for $tag";
396    
397            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
398            my $hash = {
399                    u1 => $u1,
400                    u2 => $u2,
401                    set => ( $set_item & 0xf0 ) >> 4,
402                    total => ( $set_item & 0x0f ),
403    
404                    type => $type,
405                    content => $content,
406    
407                    branch => $br_lib >> 20,
408                    library => $br_lib & 0x000fffff,
409    
410                    custom => $custom,
411            };
412    
413            if ( ! $saved_in_log->{$tag}++ ) {
414                    open(my $log, '>>', 'rfid-log.txt');
415                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
416                    close($log);
417            }
418    
419            return $hash;
420    }
421    
422    sub forget_tag {
423            my $tag = shift;
424            delete $tags_data->{$tag};
425            delete $visible_tags->{$tag};
426  }  }
427    
428  sub read_tag {  sub read_tag {
# Line 263  sub read_tag { Line 432  sub read_tag {
432    
433          print "read_tag $tag\n";          print "read_tag $tag\n";
434    
435          cmd(          my $start_block = 0;
                 "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",  
                 "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {  
                         print "FIXME: tag $tag ready?\n";  
                 },  
                 "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";  
                         read_tag_data( 0, @_ );  
                 },  
         );  
436    
437          cmd(          while ( $start_block < $max_rfid_block ) {
438                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
439                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
440                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
441                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
442          );                          "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";
443                                    $start_block = read_tag_data( $start_block, @_ );
444                                    warn "# read tag upto $start_block\n";
445                            },
446                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
447                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
448                            },
449                    );
450    
451            }
452    
453          my $security;          my $security;
454    
455          cmd(          cmd(
456                  "D6 00 0B 0A $tag 1234", "check security $tag",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
457                  "D6 00 0D 0A 00", sub {                  "D6 00 0D 0A 00", sub {
458                          my $rest = shift;                          my $rest = shift;
459                          my $from_tag;                          my $from_tag;
460                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
461                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
462                          $security = as_hex( $security );                          $security = as_hex( $security );
463                            $tags_security->{$tag} = $security;
464                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
465                  }                  }
466          );          );
467    
468          my $data = $tags_data->{$tag} || die "no data for $tag";          print "TAG $tag ", dump(decode_tag( $tag ));
         my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);  
         my $set   = ( $set_item & 0xf0 ) >> 4;  
         my $total = ( $set_item & 0x0f );  
         my $branch  = $br_lib >> 20;  
         my $library = $br_lib & 0x000fffff;  
         print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' library: $library branch: $branch custom: $custom security: $security\n";  
   
469  }  }
470    
471  sub write_tag {  sub write_tag {
472          my ($tag) = @_;          my ($tag,$data) = @_;
473    
474          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
475            $data = read_file( $path ) if -e $path;
476    
477            die "no data" unless $data;
478    
479            my $hex_data;
480    
481            if ( $data =~ s{^hex\s+}{} ) {
482                    $hex_data = $data;
483                    $hex_data =~ s{\s+}{}g;
484            } else {
485    
486                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
487    
488          my $data = read_file( $path );                  my $max_len = $max_rfid_block * 4;
489    
490          $data = substr($data,0,16);                  if ( length($data) > $max_len ) {
491                            $data = substr($data,0,$max_len);
492                            warn "strip content to $max_len bytes\n";
493                    }
494    
495                    $hex_data = unpack('H*', $data);
496            }
497    
498          my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );          my $len = length($hex_data) / 2;
499            # pad to block size
500            $hex_data .= '00' x ( 4 - $len % 4 );
501            my $blocks = sprintf('%02x', length($hex_data) / 4);
502    
503          print "write_tag $tag = ",dump( $data ), " == $hex_data\n";          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
504    
505          cmd(          cmd(
506                  "d6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  fd3b", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
507                  "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
508          ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
509    
510          my $to = $path;          my $to = $path;
511          $to .= '.' . time();          $to .= '.' . time();
# Line 328  sub write_tag { Line 513  sub write_tag {
513          rename $path, $to;          rename $path, $to;
514          print ">> $to\n";          print ">> $to\n";
515    
516          delete $tags_data->{$tag};      # force re-read of tag          forget_tag $tag;
517    }
518    
519    sub secure_tag_with {
520            my ( $tag, $data ) = @_;
521    
522            cmd(
523                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
524                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
525            );
526    
527            forget_tag $tag;
528  }  }
529    
530  sub secure_tag {  sub secure_tag {
# Line 337  sub secure_tag { Line 533  sub secure_tag {
533          my $path = "$secure_path/$tag";          my $path = "$secure_path/$tag";
534          my $data = substr(read_file( $path ),0,2);          my $data = substr(read_file( $path ),0,2);
535    
536          cmd(          secure_tag_with( $tag, $data );
                 "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",  
                 "d6 00  0c  09 00  $tag  1234", sub { assert() },  
         );  
537    
538          my $to = $path;          my $to = $path;
539          $to .= '.' . time();          $to .= '.' . time();
# Line 381  sub writechunk Line 574  sub writechunk
574  {  {
575          my $str=shift;          my $str=shift;
576          my $count = $port->write($str);          my $count = $port->write($str);
577            my $len = length($str);
578            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
579          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
580  }  }
581    
# Line 447  sub crcccitt { Line 642  sub crcccitt {
642  sub checksum {  sub checksum {
643          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
644    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
645          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
646          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
647    
648          if ( $len_real != $len ) {          if ( $len_real != $len ) {
649                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
650                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
651          }          }
652    
653            my $xor = crcccitt( substr($bytes,1) ); # skip D6
654            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
655    
656          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
657                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  warn "checksum error: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n" if $checksum ne "\xBE\xEF";
658                  return $bytes . $xor;                  return $bytes . $xor;
659          }          }
660          return $bytes . $checksum;          return $bytes . $checksum;
# Line 468  sub checksum { Line 663  sub checksum {
663  our $dispatch;  our $dispatch;
664    
665  sub readchunk {  sub readchunk {
666          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
667    
668          # read header of packet          # read header of packet
669          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 497  sub readchunk { Line 692  sub readchunk {
692          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
693    
694          if ( defined $to ) {          if ( defined $to ) {
695                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
696                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
697                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
698          } else {          } else {
699                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
700          }          }
701    
702          return $data;          return $data;
Legend:
Removed from v.37  
changed lines
  Added in v.71
  ViewVC Help
Powered by ViewVC 1.1.26