/[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 33 by dpavlin, Wed Apr 8 14:48:22 2009 UTC revision 78 by dpavlin, Mon Feb 15 14:10:08 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                    my $type = 'text/plain';
47                    $type = 'text/html' if $path =~ m{\.htm};
48                    $type = 'application/javascript' if $path =~ m{\.js};
49    
50                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                    open(my $html, $path);
52                    while(<$html>) {
53                            print $client $_;
54                    }
55                    close($html);
56    
57                    return $path;
58            }
59    
60  sub meteor {          while (my $client = $server->accept()) {
61          my @a = @_;                  $client->autoflush(1);
62          push @a, scalar localtime() if $a[0] =~ m{^info};                  my $request = <$client>;
63    
64          if ( ! defined $meteor_fh ) {                  warn "WEB << $request\n" if $debug;
65                  warn "# open connection to $meteor_server";  
66                  $meteor_fh = IO::Socket::INET->new(                  if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                                  PeerAddr => $meteor_server,                          my $method = $1;
68                                  Timeout => 1,                          my $param;
69                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                          if ( $method =~ s{\?(.+)}{} ) {
70                  $meteor_fh = 0; # don't try again                                  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 {
134                            print $client "HTTP/1.0 500 No method\r\n\r\n";
135                    }
136                    close $client;
137          }          }
138    
139          warn ">> meteor ",dump( @a );          die "server died";
         print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;  
140  }  }
141    
142  my $debug = 0;  
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    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 41  my $stopbits  = "1"; Line 162  my $stopbits  = "1";
162  my $handshake = "none";  my $handshake = "none";
163    
164  my $program_path = './program/';  my $program_path = './program/';
165    my $secure_path = './secure/';
166    
167    # http server
168    my $http_server = 1;
169    
170    # 3M defaults: 8,4
171    # cards 16, stickers: 8
172    my $max_rfid_block = 8;
173    my $read_blocks = 8;
174    
175  my $response = {  my $response = {
176          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 62  GetOptions( Line 192  GetOptions(
192          'parity=s'    => \$parity,          'parity=s'    => \$parity,
193          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
194          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
195          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
196  ) or die $!;  ) or die $!;
197    
198  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 98  it under the same terms ans Perl itself. Line 228  it under the same terms ans Perl itself.
228    
229  =cut  =cut
230    
 my $tags_data;  
 my $visible_tags;  
   
231  my $item_type = {  my $item_type = {
232          1 => 'Book',          1 => 'Book',
233          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 126  $databits=$port->databits($databits); Line 253  $databits=$port->databits($databits);
253  $parity=$port->parity($parity);  $parity=$port->parity($parity);
254  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
255    
256  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
257    
258  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
259  $port->lookclear();  $port->lookclear();
# Line 143  cmd( 'D5 00  05   04 00 11 Line 270  cmd( 'D5 00  05   04 00 11
270       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
271          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
272          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
273  });  });
274    
275  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?',
276       '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() }  );
277    
278  # start scanning for tags  sub scan_for_tags {
279    
280  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
          'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
                 my $rest = shift || die "no rest?";  
                 my $nr = ord( substr( $rest, 0, 1 ) );  
   
                 if ( ! $nr ) {  
                         print "no tags in range\n";  
                         update_visible_tags();  
                         meteor( 'info-none-in-range' );  
                         $tags_data = {};  
                 } else {  
281    
282                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
283                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
284                            my $rest = shift || die "no rest?";
285                            my $nr = ord( substr( $rest, 0, 1 ) );
286    
287                            if ( ! $nr ) {
288                                    _log "no tags in range\n";
289                                    update_visible_tags();
290                                    $tags_data = {};
291                            } else {
292    
293                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
294                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
295                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
296    
297                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
298                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
299                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
300    
301                          my @tags;                                  update_visible_tags( @tags );
302                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
303                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
304                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
305    
306                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
307            return $tags_data;
308    
309                          update_visible_tags( @tags );  }
                 }  
         }  
 ) while(1);  
 #) foreach ( 1 .. 100 );  
310    
311    # start scanning for tags
312    
313    if ( $http_server ) {
314            http_server;
315    } else {
316            while (1) {
317                    scan_for_tags;
318                    sleep 1;
319            }
320    }
321    
322    die "over and out";
323    
324  sub update_visible_tags {  sub update_visible_tags {
325          my @tags = @_;          my @tags = @_;
# Line 190  sub update_visible_tags { Line 328  sub update_visible_tags {
328          $visible_tags = {};          $visible_tags = {};
329    
330          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
331                    $visible_tags->{$tag}++;
332                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
333                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
334  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
335                          } else {                          } else {
                                 meteor( 'read', $tag );  
336                                  read_tag( $tag );                                  read_tag( $tag );
337                          }                          }
                         $visible_tags->{$tag}++;  
338                  } else {                  } else {
339                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
340                  }                  }
341                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
342    
343                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
344                                  write_tag( $tag );                                  write_tag( $tag );
345                  }                  }
346                    if ( -e "$secure_path/$tag" ) {
347                                    secure_tag( $tag );
348                    }
349          }          }
350    
351          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
352                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
353                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
354          }          }
355    
356          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 223  my $tag_data_block; Line 361  my $tag_data_block;
361  sub read_tag_data {  sub read_tag_data {
362          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
363          die "no rest?" unless $rest;          die "no rest?" unless $rest;
364    
365            my $last_block = 0;
366    
367          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
368          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
369          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 232  sub read_tag_data { Line 373  sub read_tag_data {
373                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
374                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
375                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
376                  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;
377                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
378                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
379                  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;
380                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
381                    $last_block = $ord;
382          }          }
383          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
384    
385          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
386          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";
387    
388            return $last_block + 1;
389    }
390    
391    my $saved_in_log;
392    
393    sub decode_tag {
394            my $tag = shift;
395    
396            my $data = $tags_data->{$tag};
397            if ( ! $data ) {
398                    warn "no data for $tag\n";
399                    return;
400            }
401    
402            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
403            my $hash = {
404                    u1 => $u1,
405                    u2 => $u2,
406                    set => ( $set_item & 0xf0 ) >> 4,
407                    total => ( $set_item & 0x0f ),
408    
409                    type => $type,
410                    content => $content,
411    
412                    branch => $br_lib >> 20,
413                    library => $br_lib & 0x000fffff,
414    
415                    custom => $custom,
416            };
417    
418            if ( ! $saved_in_log->{$tag}++ ) {
419                    open(my $log, '>>', 'rfid-log.txt');
420                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
421                    close($log);
422            }
423    
424            return $hash;
425    }
426    
427    sub forget_tag {
428            my $tag = shift;
429            delete $tags_data->{$tag};
430            delete $visible_tags->{$tag};
431  }  }
432    
433  sub read_tag {  sub read_tag {
# Line 251  sub read_tag { Line 437  sub read_tag {
437    
438          print "read_tag $tag\n";          print "read_tag $tag\n";
439    
440          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, @_ );  
                 },  
         );  
441    
442          cmd(          while ( $start_block < $max_rfid_block ) {
443                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
444                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
445                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $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    BEEF", sub {
452                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
453                            },
454                            "D6 00 0D 02 06 $tag", sub {
455                                    my $rest = shift;
456                                    print "ERROR reading $tag ", as_hex($rest), $/;
457                                    forget_tag $tag;
458                                    $start_block = $max_rfid_block; # XXX break out of while
459                            },
460                    );
461    
462            }
463    
464          my $security;          my $security;
465    
466          cmd(          cmd(
467                  "D6 00 0B 0A $tag 1234", "check security $tag",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
468                  "D6 00 0D 0A 00", sub {                  "D6 00 0D 0A 00", sub {
469                          my $rest = shift;                          my $rest = shift;
470                          my $from_tag;                          my $from_tag;
471                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
472                          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 );
473                          $security = as_hex( $security );                          $security = as_hex( $security );
474                            $tags_security->{$tag} = $security;
475                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
476                  }                  },
477                    "D6 00 0C 0A 06", sub {
478                            my $rest = shift;
479                            warn "ERROR reading security from $rest\n";
480                            forget_tag $tag;
481                    },
482          );          );
483    
484          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' branch: $branch library: $library custom: $custom security: $security\n";  
   
485  }  }
486    
487  sub write_tag {  sub write_tag {
488          my ($tag) = @_;          my ($tag,$data) = @_;
489    
490          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
491            $data = read_file( $path ) if -e $path;
492    
493            die "no data" unless $data;
494    
495            my $hex_data;
496    
497            if ( $data =~ s{^hex\s+}{} ) {
498                    $hex_data = $data;
499                    $hex_data =~ s{\s+}{}g;
500            } else {
501    
502          my $data = read_file( $path );                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );
503    
504          $data = substr($data,0,16);                  my $max_len = $max_rfid_block * 4;
505    
506          my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );                  if ( length($data) > $max_len ) {
507                            $data = substr($data,0,$max_len);
508                            warn "strip content to $max_len bytes\n";
509                    }
510    
511                    $hex_data = unpack('H*', $data);
512            }
513    
514            my $len = length($hex_data) / 2;
515            # pad to block size
516            $hex_data .= '00' x ( 4 - $len % 4 );
517            my $blocks = sprintf('%02x', length($hex_data) / 4);
518    
519          print "write_tag $tag = $data ",dump( $hex_data );          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
520    
521          cmd(          cmd(
522                  "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",
523                  "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
524          ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
525    
526          my $to = $path;          my $to = $path;
527          $to .= '.' . time();          $to .= '.' . time();
# Line 316  sub write_tag { Line 529  sub write_tag {
529          rename $path, $to;          rename $path, $to;
530          print ">> $to\n";          print ">> $to\n";
531    
532          delete $tags_data->{$tag};      # force re-read of tag          forget_tag $tag;
533    }
534    
535    sub secure_tag_with {
536            my ( $tag, $data ) = @_;
537    
538            cmd(
539                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
540                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
541            );
542    
543            forget_tag $tag;
544    }
545    
546    sub secure_tag {
547            my ($tag) = @_;
548    
549            my $path = "$secure_path/$tag";
550            my $data = substr(read_file( $path ),0,2);
551    
552            secure_tag_with( $tag, $data );
553    
554            my $to = $path;
555            $to .= '.' . time();
556    
557            rename $path, $to;
558            print ">> $to\n";
559  }  }
560    
561  exit;  exit;
# Line 351  sub writechunk Line 590  sub writechunk
590  {  {
591          my $str=shift;          my $str=shift;
592          my $count = $port->write($str);          my $count = $port->write($str);
593            my $len = length($str);
594            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
595          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
596  }  }
597    
598  sub as_hex {  sub as_hex {
599          my @out;          my @out;
600          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
601                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
602                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
603                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
604                  push @out, $hex;                  push @out, $hex;
# Line 417  sub crcccitt { Line 658  sub crcccitt {
658  sub checksum {  sub checksum {
659          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
660    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
661          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
662          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
663    
664          if ( $len_real != $len ) {          if ( $len_real != $len ) {
665                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
666                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
667          }          }
668    
669            my $xor = crcccitt( substr($bytes,1) ); # skip D6
670            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
671    
672          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
673                  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";
674                  return $bytes . $xor;                  return $bytes . $xor;
675          }          }
676          return $bytes . $checksum;          return $bytes . $checksum;
# Line 438  sub checksum { Line 679  sub checksum {
679  our $dispatch;  our $dispatch;
680    
681  sub readchunk {  sub readchunk {
682          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
683    
684          # read header of packet          # read header of packet
685          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 467  sub readchunk { Line 708  sub readchunk {
708          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
709    
710          if ( defined $to ) {          if ( defined $to ) {
711                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
712                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
713                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
714          } else {          } else {
715                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
716          }          }
717    
718          return $data;          return $data;
Legend:
Removed from v.33  
changed lines
  Added in v.78
  ViewVC Help
Powered by ViewVC 1.1.26