/[RFID]/cpr-m02.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 /cpr-m02.pl

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

3m-810.pl revision 22 by dpavlin, Sat Oct 4 11:55:30 2008 UTC cpr-m02.pl revision 82 by dpavlin, Fri Jul 9 23:10:05 2010 UTC
# Line 7  use warnings; Line 7  use warnings;
7  use Data::Dump qw/dump/;  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;
11    use JSON;
12    use POSIX qw(strftime);
13    
14  my $debug = 0;  use IO::Socket::INET;
15    
16    my $debug = 2;
17    
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            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 {
134                            print $client "HTTP/1.0 500 No method\r\n\r\n";
135                    }
136                    close $client;
137            }
138    
139            die "server died";
140    }
141    
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    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  = "38400";
159  my $databits  = "8";  my $databits  = "8";
160  my $parity        = "none";  my $parity        = "even";
161  my $stopbits  = "1";  my $stopbits  = "1";
162  my $handshake = "none";  my $handshake = "none";
163    
164    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?',
177          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 37  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            'http-server!' => \$http_server,
196  ) or die $!;  ) or die $!;
197    
198  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 72  it under the same terms ans Perl itself. Line 228  it under the same terms ans Perl itself.
228    
229  =cut  =cut
230    
231    my $item_type = {
232            1 => 'Book',
233            6 => 'CD/CD ROM',
234            2 => 'Magazine',
235            13 => 'Book with Audio Tape',
236            9 => 'Book with CD/CD ROM',
237            0 => 'Other',
238    
239            5 => 'Video',
240            4 => 'Audio Tape',
241            3 => 'Bound Journal',
242            8 => 'Book with Diskette',
243            7 => 'Diskette',
244    };
245    
246    warn "## known item type: ",dump( $item_type ) if $debug;
247    
248  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
249  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
250  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 80  $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 91  $port->read_char_time(5); Line 264  $port->read_char_time(5);
264  #$port->stty_inpck(1);  #$port->stty_inpck(1);
265  #$port->stty_istrip(1);  #$port->stty_istrip(1);
266    
267    sub cpr_m02_checksum {
268            my $data = shift;
269    
270            my $preset = 0xffff;
271            my $polynom = 0x8408;
272    
273            my $crc = $preset;
274            foreach my $i ( 0 .. length($data) - 1 ) {
275                    $crc ^= ord(substr($data,$i,1));
276                    for my $j ( 0 .. 7 ) {
277                            if ( $crc & 0x0001 ) {
278                                    $crc = ( $crc >> 1 ) ^ $polynom;
279                            } else {
280                                    $crc = $crc >> 1;
281                            }
282                    }
283                    warn sprintf('%d %04x', $i, $crc & 0xffff);
284            }
285    
286            return pack('v', $crc);
287    }
288    
289    sub cpr {
290            my $hex = shift;
291            my $bytes = str2bytes($hex);
292            my $len = pack( 'c', length( $bytes ) + 3 );
293            my $send = $len . $bytes;
294            my $checksum = cpr_m02_checksum($send);
295            $send .= $checksum;
296    
297            warn ">> ", as_hex( $send );
298            writechunk( $send );
299            my $r_len = read_bytes( 1, 'response length' );
300            $r_len = ord($r_len) - 1;
301            my $data = read_bytes( $r_len, 'data' );
302            warn "<< ", as_hex( $data );
303    }
304    
305    cpr( '00  52 00' );
306    
307    exit;
308  # initial hand-shake with device  # initial hand-shake with device
309    
310  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
311       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
312          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
313            print "hardware version $hw_ver\n";
314  });  });
315    
316  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?',
317       '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() }  );
318    
319  # start scanning for tags  sub scan_for_tags {
320    
321  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();  
                 } else {  
322    
323                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
324                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
325                            my $rest = shift || die "no rest?";
326                            my $nr = ord( substr( $rest, 0, 1 ) );
327    
328                          my $tl = length( $tags );                          if ( ! $nr ) {
329                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  _log "no tags in range\n";
330                                    update_visible_tags();
331                                    $tags_data = {};
332                            } else {
333    
334                                    my $tags = substr( $rest, 1 );
335                                    my $tl = length( $tags );
336                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
337    
338                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
339                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
340                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
341    
342                          my @tags;                                  update_visible_tags( @tags );
343                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
344                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
345                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
346    
347                          update_visible_tags( @tags );          diag "tags: ",dump( @tags );
348            return $tags_data;
349    
350                  }  }
         }  
 ) foreach ( 1 .. 100 );  
351    
352    # start scanning for tags
353    
354    if ( $http_server ) {
355            http_server;
356    } else {
357            while (1) {
358                    scan_for_tags;
359                    sleep 1;
360            }
361    }
362    
363  my $tags_data;  die "over and out";
 my $visible_tags;  
364    
365  sub update_visible_tags {  sub update_visible_tags {
366          my @tags = @_;          my @tags = @_;
# Line 141  sub update_visible_tags { Line 369  sub update_visible_tags {
369          $visible_tags = {};          $visible_tags = {};
370    
371          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
372                    $visible_tags->{$tag}++;
373                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
374                          read_tag( $tag );                          if ( defined $tags_data->{$tag} ) {
375                          $visible_tags->{$tag}++;                                  warn "$tag in range\n";
376                            } else {
377                                    read_tag( $tag );
378                            }
379                  } else {                  } else {
380                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
381                  }                  }
382                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
383    
384                    if ( -e "$program_path/$tag" ) {
385                                    write_tag( $tag );
386                    }
387                    if ( -e "$secure_path/$tag" ) {
388                                    secure_tag( $tag );
389                    }
390          }          }
391    
392          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
393                  print "removed tag $tag with data ",dump( delete $tags_data->{$tag} ),"\n";                  my $data = delete $tags_data->{$tag};
394                    warn "$tag removed ", dump($data), $/;
395          }          }
396    
397          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;
398  }  }
399    
400    my $tag_data_block;
401    
402    sub read_tag_data {
403            my ($start_block,$rest) = @_;
404            die "no rest?" unless $rest;
405    
406            my $last_block = 0;
407    
408            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
409            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
410            my $blocks = ord(substr($rest,8,1));
411            $rest = substr($rest,9); # leave just data blocks
412            foreach my $nr ( 0 .. $blocks - 1 ) {
413                    my $block = substr( $rest, $nr * 6, 6 );
414                    warn "## block ",as_hex( $block ) if $debug;
415                    my $ord   = unpack('v',substr( $block, 0, 2 ));
416                    my $expected_ord = $nr + $start_block;
417                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
418                    my $data  = substr( $block, 2 );
419                    die "data payload should be 4 bytes" if length($data) != 4;
420                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
421                    $tag_data_block->{$tag}->[ $ord ] = $data;
422                    $last_block = $ord;
423            }
424            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
425    
426            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
427            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
428    
429            return $last_block + 1;
430    }
431    
432    my $saved_in_log;
433    
434    sub decode_tag {
435            my $tag = shift;
436    
437            my $data = $tags_data->{$tag};
438            if ( ! $data ) {
439                    warn "no data for $tag\n";
440                    return;
441            }
442    
443            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
444            my $hash = {
445                    u1 => $u1,
446                    u2 => $u2,
447                    set => ( $set_item & 0xf0 ) >> 4,
448                    total => ( $set_item & 0x0f ),
449    
450                    type => $type,
451                    content => $content,
452    
453                    branch => $br_lib >> 20,
454                    library => $br_lib & 0x000fffff,
455    
456                    custom => $custom,
457            };
458    
459            if ( ! $saved_in_log->{$tag}++ ) {
460                    open(my $log, '>>', 'rfid-log.txt');
461                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
462                    close($log);
463            }
464    
465            return $hash;
466    }
467    
468    sub forget_tag {
469            my $tag = shift;
470            delete $tags_data->{$tag};
471            delete $visible_tags->{$tag};
472    }
473    
474  sub read_tag {  sub read_tag {
475          my ( $tag ) = @_;          my ( $tag ) = @_;
476    
477          confess "no tag?" unless $tag;          confess "no tag?" unless $tag;
478    
         return if defined $tags_data->{$tag};  
   
479          print "read_tag $tag\n";          print "read_tag $tag\n";
480    
481            my $start_block = 0;
482    
483            while ( $start_block < $max_rfid_block ) {
484    
485                    cmd(
486                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
487                                    "read $tag offset: $start_block blocks: $read_blocks",
488                            "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";
489                                    $start_block = read_tag_data( $start_block, @_ );
490                                    warn "# read tag upto $start_block\n";
491                            },
492                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
493                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
494                            },
495                            "D6 00 0D 02 06 $tag", sub {
496                                    my $rest = shift;
497                                    print "ERROR reading $tag ", as_hex($rest), $/;
498                                    forget_tag $tag;
499                                    $start_block = $max_rfid_block; # XXX break out of while
500                            },
501                    );
502    
503            }
504    
505            my $security;
506    
507          cmd(          cmd(
508                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag BEEF", "check security $tag",
509                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
510                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
511                            my $from_tag;
512                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
513                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
514                            $security = as_hex( $security );
515                            $tags_security->{$tag} = $security;
516                            warn "# SECURITY $tag = $security\n";
517                  },                  },
518                  "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";                  "D6 00 0C 0A 06", sub {
519                          my $rest = shift || die "no rest?";                          my $rest = shift;
520                          warn "## DATA ", dump( $rest ) if $debug;                          warn "ERROR reading security from $rest\n";
521                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          forget_tag $tag;
522                          my $blocks = ord(substr($rest,8,1));                  },
523                          $rest = substr($rest,9); # leave just data blocks          );
524                          my @data;  
525                          foreach my $nr ( 0 .. $blocks - 1 ) {          print "TAG $tag ", dump(decode_tag( $tag ));
526                                  my $block = substr( $rest, $nr * 6, 6 );  }
527                                  warn "## block ",as_hex( $block ) if $debug;  
528                                  my $ord   = unpack('v',substr( $block, 0, 2 ));  sub write_tag {
529                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;          my ($tag,$data) = @_;
530                                  my $data  = substr( $block, 2 );  
531                                  die "data payload should be 4 bytes" if length($data) != 4;          my $path = "$program_path/$tag";
532                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;          $data = read_file( $path ) if -e $path;
533                                  $data[ $ord ] = $data;  
534                          }          die "no data" unless $data;
535                          $tags_data->{ $tag } = join('', @data);  
536                          print "DATA $tag ",dump( $tags_data ), "\n";          my $hex_data;
537    
538            if ( $data =~ s{^hex\s+}{} ) {
539                    $hex_data = $data;
540                    $hex_data =~ s{\s+}{}g;
541            } else {
542    
543                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
544    
545                    my $max_len = $max_rfid_block * 4;
546    
547                    if ( length($data) > $max_len ) {
548                            $data = substr($data,0,$max_len);
549                            warn "strip content to $max_len bytes\n";
550                  }                  }
551    
552                    $hex_data = unpack('H*', $data);
553            }
554    
555            my $len = length($hex_data) / 2;
556            # pad to block size
557            $hex_data .= '00' x ( 4 - $len % 4 );
558            my $blocks = sprintf('%02x', length($hex_data) / 4);
559    
560            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
561    
562            cmd(
563                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
564                    "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
565            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
566    
567            my $to = $path;
568            $to .= '.' . time();
569    
570            rename $path, $to;
571            print ">> $to\n";
572    
573            forget_tag $tag;
574    }
575    
576    sub secure_tag_with {
577            my ( $tag, $data ) = @_;
578    
579            cmd(
580                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
581                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
582          );          );
583    
584          #        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          forget_tag $tag;
 if (0) {  
         cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
   
         #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
         #                           $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";  
585  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
586    
587    sub secure_tag {
588            my ($tag) = @_;
589    
590            my $path = "$secure_path/$tag";
591            my $data = substr(read_file( $path ),0,2);
592    
593            secure_tag_with( $tag, $data );
594    
595            my $to = $path;
596            $to .= '.' . time();
597    
598            rename $path, $to;
599            print ">> $to\n";
600  }  }
601    
602  exit;  exit;
# Line 238  sub writechunk Line 631  sub writechunk
631  {  {
632          my $str=shift;          my $str=shift;
633          my $count = $port->write($str);          my $count = $port->write($str);
634            my $len = length($str);
635            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
636          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
637  }  }
638    
639  sub as_hex {  sub as_hex {
640          my @out;          my @out;
641          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
642                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
643                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
644                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
645                  push @out, $hex;                  push @out, $hex;
# Line 257  sub read_bytes { Line 652  sub read_bytes {
652          my $data = '';          my $data = '';
653          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
654                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
655                  #warn "## got $c bytes: ", as_hex($b), "\n";                  die "no bytes on port: $!" unless defined $b;
656                    warn "## got $c bytes: ", as_hex($b), "\n";
657                  $data .= $b;                  $data .= $b;
658          }          }
659          $desc ||= '?';          $desc ||= '?';
# Line 303  sub crcccitt { Line 699  sub crcccitt {
699  sub checksum {  sub checksum {
700          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
701    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
702          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
703          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
704    
705          if ( $len_real != $len ) {          if ( $len_real != $len ) {
706                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
707                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
708          }          }
709    
710            my $xor = crcccitt( substr($bytes,1) ); # skip D6
711            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
712    
713          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
714                  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";
715                  return $bytes . $xor;                  return $bytes . $xor;
716          }          }
717          return $bytes . $checksum;          return $bytes . $checksum;
# Line 324  sub checksum { Line 720  sub checksum {
720  our $dispatch;  our $dispatch;
721    
722  sub readchunk {  sub readchunk {
723          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
724    
725          # read header of packet          # read header of packet
726          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 353  sub readchunk { Line 749  sub readchunk {
749          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
750    
751          if ( defined $to ) {          if ( defined $to ) {
752                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
753                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
754                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
755          } else {          } else {
756                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
757          }          }
758    
759          return $data;          return $data;
Legend:
Removed from v.22  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.26