/[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 25 by dpavlin, Sun Mar 29 01:05:49 2009 UTC cpr-m02.pl revision 83 by dpavlin, Mon Jul 12 10:59:59 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  use IO::Socket::INET;  use IO::Socket::INET;
15    
16  my $meteor_server = '192.168.1.13:4671';  my $debug = 2;
17    
18  my $meteor = IO::Socket::INET->new( $meteor_server )  my $tags_data;
19           || die "can't connect to meteor $meteor_server: $!";  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  sub meteor {                  return unless -e $path;
         my @a = @_;  
         push @a, scalar localtime() if $a[0] =~ m{^info};  
45    
46          warn ">> meteor ",dump( @a );                  my $type = 'text/plain';
47          print $meteor "ADDMESSAGE test ",join('|',@a),"\n";                  $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  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  = "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 52  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 87  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 $tags_data;  my $item_type = {
232  my $visible_tags;          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;
# Line 98  $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 109  $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, $description ) = 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 ), "[$description]\n";
298            $port->write( $send );
299            my $r_len = $port->read(1);
300            warn "<< response len: ", as_hex($r_len), "\n";
301            $r_len = ord($r_len) - 1;
302            my $data = $port->read( $r_len );
303            warn "<< ", as_hex( $data );
304    
305            warn "## ",dump( $port->read(1) );
306    }
307    
308    #cpr( 'FF  52 00', 'detect boud rate' );
309    
310    #cpr( '00  65', 'software version' );
311    
312    cpr( 'FF  65', 'get ? info' );
313    
314    cpr( 'FF  69 00', 'get reader info' );
315    
316    cpr( 'FF B0 01 00', '?' );
317    
318    cpr( 'FF 69', '?' );
319    
320    #cpr( '', '?' );
321    
322    exit;
323  # initial hand-shake with device  # initial hand-shake with device
324    
325  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
326       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
327          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
328          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
329  });  });
330    
331  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?',
332       '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() }  );
333    
334  # start scanning for tags  sub scan_for_tags {
   
 cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",  
          '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 {  
335    
336                          my $tags = substr( $rest, 1 );          my @tags;
337    
338                          my $tl = length( $tags );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
339                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
340                            my $rest = shift || die "no rest?";
341                            my $nr = ord( substr( $rest, 0, 1 ) );
342    
343                          my @tags;                          if ( ! $nr ) {
344                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  _log "no tags in range\n";
345                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  update_visible_tags();
346                          print "$nr tags in range: ", join(',', @tags ) , "\n";                                  $tags_data = {};
347                            } else {
348    
349                          meteor( 'info-in-range', join(' ',@tags));                                  my $tags = substr( $rest, 1 );
350                                    my $tl = length( $tags );
351                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
352    
353                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
354                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
355                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
356    
357                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
358                            }
359                  }                  }
360          }          );
 ) while(1);  
 #) foreach ( 1 .. 100 );  
361    
362            diag "tags: ",dump( @tags );
363            return $tags_data;
364    
365    }
366    
367    # start scanning for tags
368    
369    if ( $http_server ) {
370            http_server;
371    } else {
372            while (1) {
373                    scan_for_tags;
374                    sleep 1;
375            }
376    }
377    
378    die "over and out";
379    
380  sub update_visible_tags {  sub update_visible_tags {
381          my @tags = @_;          my @tags = @_;
# Line 162  sub update_visible_tags { Line 384  sub update_visible_tags {
384          $visible_tags = {};          $visible_tags = {};
385    
386          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
387                    $visible_tags->{$tag}++;
388                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
389                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
390  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
391                          } else {                          } else {
                                 meteor( 'read', $tag );  
392                                  read_tag( $tag );                                  read_tag( $tag );
393                          }                          }
                         $visible_tags->{$tag}++;  
394                  } else {                  } else {
395                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
396                  }                  }
397                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
398    
399                    if ( -e "$program_path/$tag" ) {
400                                    write_tag( $tag );
401                    }
402                    if ( -e "$secure_path/$tag" ) {
403                                    secure_tag( $tag );
404                    }
405          }          }
406    
407          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
408                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
409                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
410          }          }
411    
412          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;
413  }  }
414    
415    my $tag_data_block;
416    
417    sub read_tag_data {
418            my ($start_block,$rest) = @_;
419            die "no rest?" unless $rest;
420    
421            my $last_block = 0;
422    
423            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
424            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
425            my $blocks = ord(substr($rest,8,1));
426            $rest = substr($rest,9); # leave just data blocks
427            foreach my $nr ( 0 .. $blocks - 1 ) {
428                    my $block = substr( $rest, $nr * 6, 6 );
429                    warn "## block ",as_hex( $block ) if $debug;
430                    my $ord   = unpack('v',substr( $block, 0, 2 ));
431                    my $expected_ord = $nr + $start_block;
432                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
433                    my $data  = substr( $block, 2 );
434                    die "data payload should be 4 bytes" if length($data) != 4;
435                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
436                    $tag_data_block->{$tag}->[ $ord ] = $data;
437                    $last_block = $ord;
438            }
439            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
440    
441            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
442            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
443    
444            return $last_block + 1;
445    }
446    
447    my $saved_in_log;
448    
449    sub decode_tag {
450            my $tag = shift;
451    
452            my $data = $tags_data->{$tag};
453            if ( ! $data ) {
454                    warn "no data for $tag\n";
455                    return;
456            }
457    
458            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
459            my $hash = {
460                    u1 => $u1,
461                    u2 => $u2,
462                    set => ( $set_item & 0xf0 ) >> 4,
463                    total => ( $set_item & 0x0f ),
464    
465                    type => $type,
466                    content => $content,
467    
468                    branch => $br_lib >> 20,
469                    library => $br_lib & 0x000fffff,
470    
471                    custom => $custom,
472            };
473    
474            if ( ! $saved_in_log->{$tag}++ ) {
475                    open(my $log, '>>', 'rfid-log.txt');
476                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
477                    close($log);
478            }
479    
480            return $hash;
481    }
482    
483    sub forget_tag {
484            my $tag = shift;
485            delete $tags_data->{$tag};
486            delete $visible_tags->{$tag};
487    }
488    
489  sub read_tag {  sub read_tag {
490          my ( $tag ) = @_;          my ( $tag ) = @_;
# Line 193  sub read_tag { Line 493  sub read_tag {
493    
494          print "read_tag $tag\n";          print "read_tag $tag\n";
495    
496            my $start_block = 0;
497    
498            while ( $start_block < $max_rfid_block ) {
499    
500                    cmd(
501                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
502                                    "read $tag offset: $start_block blocks: $read_blocks",
503                            "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";
504                                    $start_block = read_tag_data( $start_block, @_ );
505                                    warn "# read tag upto $start_block\n";
506                            },
507                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
508                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
509                            },
510                            "D6 00 0D 02 06 $tag", sub {
511                                    my $rest = shift;
512                                    print "ERROR reading $tag ", as_hex($rest), $/;
513                                    forget_tag $tag;
514                                    $start_block = $max_rfid_block; # XXX break out of while
515                            },
516                    );
517    
518            }
519    
520            my $security;
521    
522          cmd(          cmd(
523                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag BEEF", "check security $tag",
524                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
525                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
526                            my $from_tag;
527                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
528                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
529                            $security = as_hex( $security );
530                            $tags_security->{$tag} = $security;
531                            warn "# SECURITY $tag = $security\n";
532                  },                  },
533                  "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 {
534                          my $rest = shift || die "no rest?";                          my $rest = shift;
535                          warn "## DATA ", dump( $rest ) if $debug;                          warn "ERROR reading security from $rest\n";
536                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          forget_tag $tag;
537                          my $blocks = ord(substr($rest,8,1));                  },
538                          $rest = substr($rest,9); # leave just data blocks          );
539                          my @data;  
540                          foreach my $nr ( 0 .. $blocks - 1 ) {          print "TAG $tag ", dump(decode_tag( $tag ));
541                                  my $block = substr( $rest, $nr * 6, 6 );  }
542                                  warn "## block ",as_hex( $block ) if $debug;  
543                                  my $ord   = unpack('v',substr( $block, 0, 2 ));  sub write_tag {
544                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;          my ($tag,$data) = @_;
545                                  my $data  = substr( $block, 2 );  
546                                  die "data payload should be 4 bytes" if length($data) != 4;          my $path = "$program_path/$tag";
547                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;          $data = read_file( $path ) if -e $path;
548                                  $data[ $ord ] = $data;  
549                          }          die "no data" unless $data;
550                          $tags_data->{ $tag } = join('', @data);  
551                          print "DATA $tag ",dump( $tags_data ), "\n";          my $hex_data;
552    
553            if ( $data =~ s{^hex\s+}{} ) {
554                    $hex_data = $data;
555                    $hex_data =~ s{\s+}{}g;
556            } else {
557    
558                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
559    
560                    my $max_len = $max_rfid_block * 4;
561    
562                    if ( length($data) > $max_len ) {
563                            $data = substr($data,0,$max_len);
564                            warn "strip content to $max_len bytes\n";
565                  }                  }
566    
567                    $hex_data = unpack('H*', $data);
568            }
569    
570            my $len = length($hex_data) / 2;
571            # pad to block size
572            $hex_data .= '00' x ( 4 - $len % 4 );
573            my $blocks = sprintf('%02x', length($hex_data) / 4);
574    
575            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
576    
577            cmd(
578                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
579                    "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
580            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
581    
582            my $to = $path;
583            $to .= '.' . time();
584    
585            rename $path, $to;
586            print ">> $to\n";
587    
588            forget_tag $tag;
589    }
590    
591    sub secure_tag_with {
592            my ( $tag, $data ) = @_;
593    
594            cmd(
595                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
596                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
597          );          );
598    
599          #        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";  
600  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
601    
602    sub secure_tag {
603            my ($tag) = @_;
604    
605            my $path = "$secure_path/$tag";
606            my $data = substr(read_file( $path ),0,2);
607    
608            secure_tag_with( $tag, $data );
609    
610            my $to = $path;
611            $to .= '.' . time();
612    
613            rename $path, $to;
614            print ">> $to\n";
615  }  }
616    
617  exit;  exit;
# Line 264  sub writechunk Line 646  sub writechunk
646  {  {
647          my $str=shift;          my $str=shift;
648          my $count = $port->write($str);          my $count = $port->write($str);
649            my $len = length($str);
650            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
651          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
652  }  }
653    
654  sub as_hex {  sub as_hex {
655          my @out;          my @out;
656          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
657                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
658                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
659                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
660                  push @out, $hex;                  push @out, $hex;
# Line 283  sub read_bytes { Line 667  sub read_bytes {
667          my $data = '';          my $data = '';
668          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
669                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
670                  #warn "## got $c bytes: ", as_hex($b), "\n";                  die "no bytes on port: $!" unless defined $b;
671                    warn "## got $c bytes: ", as_hex($b), "\n";
672                    last if $c == 0;
673                  $data .= $b;                  $data .= $b;
674          }          }
675          $desc ||= '?';          $desc ||= '?';
# Line 329  sub crcccitt { Line 715  sub crcccitt {
715  sub checksum {  sub checksum {
716          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
717    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
718          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
719          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
720    
721          if ( $len_real != $len ) {          if ( $len_real != $len ) {
722                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
723                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
724          }          }
725    
726            my $xor = crcccitt( substr($bytes,1) ); # skip D6
727            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
728    
729          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
730                  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";
731                  return $bytes . $xor;                  return $bytes . $xor;
732          }          }
733          return $bytes . $checksum;          return $bytes . $checksum;
# Line 350  sub checksum { Line 736  sub checksum {
736  our $dispatch;  our $dispatch;
737    
738  sub readchunk {  sub readchunk {
739          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
740    
741          # read header of packet          # read header of packet
742          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 379  sub readchunk { Line 765  sub readchunk {
765          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
766    
767          if ( defined $to ) {          if ( defined $to ) {
768                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
769                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
770                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
771          } else {          } else {
772                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
773          }          }
774    
775          return $data;          return $data;
Legend:
Removed from v.25  
changed lines
  Added in v.83
  ViewVC Help
Powered by ViewVC 1.1.26