/[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 21 by dpavlin, Fri Oct 3 21:47:24 2008 UTC cpr-m02.pl revision 86 by dpavlin, Fri Jul 16 09:31:56 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    use Time::HiRes;
14    
15    use IO::Socket::INET;
16    
17  my $debug = 0;  my $debug = 0;
18    
19    my $tags_data;
20    my $tags_security;
21    my $visible_tags;
22    
23    my $listen_port = 9000;                  # pick something not in use
24    my $server_url  = "http://localhost:$listen_port";
25    
26    sub http_server {
27    
28            my $server = IO::Socket::INET->new(
29                    Proto     => 'tcp',
30                    LocalPort => $listen_port,
31                    Listen    => SOMAXCONN,
32                    Reuse     => 1
33            );
34                                                                      
35            die "can't setup server: $!" unless $server;
36    
37            print "Server $0 ready at $server_url\n";
38    
39            sub static {
40                    my ($client,$path) = @_;
41    
42                    $path = "www/$path";
43                    $path .= 'rfid.html' if $path =~ m{/$};
44    
45                    return unless -e $path;
46    
47                    my $type = 'text/plain';
48                    $type = 'text/html' if $path =~ m{\.htm};
49                    $type = 'application/javascript' if $path =~ m{\.js};
50    
51                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
52                    open(my $html, $path);
53                    while(<$html>) {
54                            print $client $_;
55                    }
56                    close($html);
57    
58                    return $path;
59            }
60    
61            while (my $client = $server->accept()) {
62                    $client->autoflush(1);
63                    my $request = <$client>;
64    
65                    warn "WEB << $request\n" if $debug;
66    
67                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
68                            my $method = $1;
69                            my $param;
70                            if ( $method =~ s{\?(.+)}{} ) {
71                                    foreach my $p ( split(/[&;]/, $1) ) {
72                                            my ($n,$v) = split(/=/, $p, 2);
73                                            $param->{$n} = $v;
74                                    }
75                                    warn "WEB << param: ",dump( $param ) if $debug;
76                            }
77                            if ( my $path = static( $client,$1 ) ) {
78                                    warn "WEB >> $path" if $debug;
79                            } elsif ( $method =~ m{/scan} ) {
80                                    my $tags = scan_for_tags();
81                                    my $json = { time => time() };
82                                    map {
83                                            my $d = decode_tag($_);
84                                            $d->{sid} = $_;
85                                            $d->{security} = $tags_security->{$_};
86                                            push @{ $json->{tags} },  $d;
87                                    } keys %$tags;
88                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
89                                            $param->{callback}, "(", to_json($json), ")\r\n";
90                            } elsif ( $method =~ m{/program} ) {
91    
92                                    my $status = 501; # Not implementd
93    
94                                    foreach my $p ( keys %$param ) {
95                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
96                                            my $tag = $1;
97                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
98                                            $content = "\x00" if $param->{$p} eq 'blank';
99                                            $status = 302;
100    
101                                            warn "PROGRAM $tag $content\n";
102                                            write_tag( $tag, $content );
103                                            secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
104                                    }
105    
106                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
107    
108                            } elsif ( $method =~ m{/secure(.js)} ) {
109    
110                                    my $json = $1;
111    
112                                    my $status = 501; # Not implementd
113    
114                                    foreach my $p ( keys %$param ) {
115                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
116                                            my $tag = $1;
117                                            my $data = $param->{$p};
118                                            $status = 302;
119    
120                                            warn "SECURE $tag $data\n";
121                                            secure_tag_with( $tag, $data );
122                                    }
123    
124                                    if ( $json ) {
125                                            print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
126                                                    $param->{callback}, "({ ok: 1 })\r\n";
127                                    } else {
128                                            print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
129                                    }
130    
131                            } else {
132                                    print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
133                            }
134                    } else {
135                            print $client "HTTP/1.0 500 No method\r\n\r\n";
136                    }
137                    close $client;
138            }
139    
140            die "server died";
141    }
142    
143    
144    my $last_message = {};
145    sub _message {
146            my $type = shift @_;
147            my $text = join(' ',@_);
148            my $last = $last_message->{$type};
149            if ( $text ne $last ) {
150                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
151                    $last_message->{$type} = $text;
152            }
153    }
154    
155    sub _log { _message('log',@_) };
156    sub diag { _message('diag',@_) };
157    
158  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
159  my $baudrate  = "19200";  my $baudrate  = "38400";
160  my $databits  = "8";  my $databits  = "8";
161  my $parity        = "none";  my $parity        = "even";
162  my $stopbits  = "1";  my $stopbits  = "1";
163  my $handshake = "none";  my $handshake = "none";
164    
165    my $program_path = './program/';
166    my $secure_path = './secure/';
167    
168    # http server
169    my $http_server = 1;
170    
171    # 3M defaults: 8,4
172    # cards 16, stickers: 8
173    my $max_rfid_block = 8;
174    my $read_blocks = 8;
175    
176  my $response = {  my $response = {
177          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
178          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 30  my $response = { Line 186  my $response = {
186  };  };
187    
188  GetOptions(  GetOptions(
189          'd|debug+'      => \$debug,          'd|debug+'    => \$debug,
190          'device=s'    => \$device,          'device=s'    => \$device,
191          'baudrate=i'  => \$baudrate,          'baudrate=i'  => \$baudrate,
192          'databits=i'  => \$databits,          'databits=i'  => \$databits,
193          'parity=s'    => \$parity,          'parity=s'    => \$parity,
194          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
195          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
196            'http-server!' => \$http_server,
197  ) or die $!;  ) or die $!;
198    
199    my $verbose = $debug > 0 ? $debug-- : 0;
200    
201  =head1 NAME  =head1 NAME
202    
203  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
# Line 70  it under the same terms ans Perl itself. Line 229  it under the same terms ans Perl itself.
229    
230  =cut  =cut
231    
232  my $tags_data;  my $item_type = {
233  my $visible_tags;          1 => 'Book',
234            6 => 'CD/CD ROM',
235            2 => 'Magazine',
236            13 => 'Book with Audio Tape',
237            9 => 'Book with CD/CD ROM',
238            0 => 'Other',
239    
240            5 => 'Video',
241            4 => 'Audio Tape',
242            3 => 'Bound Journal',
243            8 => 'Book with Diskette',
244            7 => 'Diskette',
245    };
246    
247    warn "## known item type: ",dump( $item_type ) if $debug;
248    
249  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";
250  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
# Line 81  $databits=$port->databits($databits); Line 254  $databits=$port->databits($databits);
254  $parity=$port->parity($parity);  $parity=$port->parity($parity);
255  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
256    
257  print "## using $device $baudrate $databits $parity $stopbits\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
258    
259  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
260  $port->lookclear();  $port->lookclear();
# Line 92  $port->read_char_time(5); Line 265  $port->read_char_time(5);
265  #$port->stty_inpck(1);  #$port->stty_inpck(1);
266  #$port->stty_istrip(1);  #$port->stty_istrip(1);
267    
268    sub cpr_m02_checksum {
269            my $data = shift;
270    
271            my $preset = 0xffff;
272            my $polynom = 0x8408;
273    
274            my $crc = $preset;
275            foreach my $i ( 0 .. length($data) - 1 ) {
276                    $crc ^= ord(substr($data,$i,1));
277                    for my $j ( 0 .. 7 ) {
278                            if ( $crc & 0x0001 ) {
279                                    $crc = ( $crc >> 1 ) ^ $polynom;
280                            } else {
281                                    $crc = $crc >> 1;
282                            }
283                    }
284    #               warn sprintf('%d %04x', $i, $crc & 0xffff);
285            }
286    
287            return pack('v', $crc);
288    }
289    
290    sub cpr {
291            my ( $hex, $description, $coderef ) = @_;
292            my $bytes = str2bytes($hex);
293            my $len = pack( 'c', length( $bytes ) + 3 );
294            my $send = $len . $bytes;
295            my $checksum = cpr_m02_checksum($send);
296            $send .= $checksum;
297    
298            warn ">> ", as_hex( $send ), "\t\t[$description]\n";
299            $port->write( $send );
300    
301            my $r_len = $port->read(1);
302    
303            while ( ! $r_len ) {
304                    warn "# wait for response length 0.050\n";
305                    Time::HiRes::sleep 0.050;
306                    $r_len = $port->read(1);
307            }
308    
309            warn "<< response len: ", as_hex($r_len), "\n";
310            $r_len = ord($r_len) - 1;
311            my $data = $port->read( $r_len );
312            warn "<< ", as_hex( $data );
313            
314            my $t = Time::HiRes::time;
315    
316            $coderef->( $data ) if $coderef;
317    
318            my $dt = Time::HiRes::time - $t;
319            if ( $dt < 0.050 ) {
320                    my $s = 0.050 - $dt;
321                    warn "# sleep for more $s\n";
322                    Time::HiRes::sleep $s;
323            }
324    }
325    
326    # FF = COM-ADDR any
327    
328    cpr( 'FF  52 00',       'Boud Rate Detection' );
329    
330    cpr( 'FF  65',          'Get Software Version' );
331    
332    cpr( 'FF  66 00',       'Get Reader Info - General hard and firware' );
333    
334    cpr( 'FF  69',          'RF Reset' );
335    
336    my $inventory;
337    
338    while(1) {
339    
340    cpr( 'FF  B0  01 00', 'ISO - Inventory', sub {
341            my $data = shift;
342            my $data_sets = ord(substr($data,3,1));
343            $data = substr($data,4);
344            foreach ( 1 .. $data_sets ) {
345                    my $tr_type = substr($data,0,1);
346                    my $dsfid   = substr($data,1,1);
347                    my $uid     = substr($data,2,8);
348                    $inventory->{$uid}++;
349                    $data = substr($data,10);
350                    warn "# TAG $_ ",as_hex( $tr_type, $dsfid, $uid ),$/;
351            }
352            warn "inventory: ",dump($inventory);
353    });
354    
355    }
356    
357    #cpr( '', '?' );
358    
359    exit;
360  # initial hand-shake with device  # initial hand-shake with device
361    
362  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
363       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
364          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
365            print "hardware version $hw_ver\n";
366  });  });
367    
368  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?',
369       '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() }  );
370    
371  # start scanning for tags  sub scan_for_tags {
372    
373  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
      'D6 00  07   FE  00 00  05     00  C97B', sub {  
                 assert();  
                 print "no tag in range\n";  
   
         },  
          '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 ) );  
374    
375                  if ( ! $nr ) {          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
376                          print "no tags in range\n";                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
377                  } else {                          my $rest = shift || die "no rest?";
378                            my $nr = ord( substr( $rest, 0, 1 ) );
379    
380                          my $tags = substr( $rest, 1 );                          if ( ! $nr ) {
381                                    _log "no tags in range\n";
382                                    update_visible_tags();
383                                    $tags_data = {};
384                            } else {
385    
386                                    my $tags = substr( $rest, 1 );
387                                    my $tl = length( $tags );
388                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
389    
390                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
391                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
392                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
393    
394                          my $tl = length( $tags );                                  update_visible_tags( @tags );
395                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                          }
396                    }
397            );
398    
399            diag "tags: ",dump( @tags );
400            return $tags_data;
401    
402    }
403    
404    # start scanning for tags
405    
406    if ( $http_server ) {
407            http_server;
408    } else {
409            while (1) {
410                    scan_for_tags;
411                    sleep 1;
412            }
413    }
414    
415                          my @tags;  die "over and out";
                         push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );  
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "seen $nr tags: ", join(',', @tags ) , "\n";  
416    
417                          my $removed_tags = $visible_tags;  sub update_visible_tags {
418                          $visible_tags = {};          my @tags = @_;
419    
420                          foreach my $tag ( @tags ) {          my $last_visible_tags = $visible_tags;
421                                  next if $visible_tags->{$tag}++;          $visible_tags = {};
422    
423            foreach my $tag ( @tags ) {
424                    $visible_tags->{$tag}++;
425                    if ( ! defined $last_visible_tags->{$tag} ) {
426                            if ( defined $tags_data->{$tag} ) {
427                                    warn "$tag in range\n";
428                            } else {
429                                  read_tag( $tag );                                  read_tag( $tag );
                                 if ( delete $removed_tags->{$tag} ) {  
                                         print "removed tag $tag\n";  
                                 }  
430                          }                          }
431                    } else {
432                            warn "## using cached data for $tag" if $debug;
433                    }
434                    delete $last_visible_tags->{$tag}; # leave just missing tags
435    
436                    if ( -e "$program_path/$tag" ) {
437                                    write_tag( $tag );
438                    }
439                    if ( -e "$secure_path/$tag" ) {
440                                    secure_tag( $tag );
441                  }                  }
442          }          }
443  ) foreach ( 1 .. 100 );  
444            foreach my $tag ( keys %$last_visible_tags ) {
445                    my $data = delete $tags_data->{$tag};
446                    warn "$tag removed ", dump($data), $/;
447            }
448    
449            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
450    }
451    
452    my $tag_data_block;
453    
454    sub read_tag_data {
455            my ($start_block,$rest) = @_;
456            die "no rest?" unless $rest;
457    
458            my $last_block = 0;
459    
460            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
461            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
462            my $blocks = ord(substr($rest,8,1));
463            $rest = substr($rest,9); # leave just data blocks
464            foreach my $nr ( 0 .. $blocks - 1 ) {
465                    my $block = substr( $rest, $nr * 6, 6 );
466                    warn "## block ",as_hex( $block ) if $debug;
467                    my $ord   = unpack('v',substr( $block, 0, 2 ));
468                    my $expected_ord = $nr + $start_block;
469                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
470                    my $data  = substr( $block, 2 );
471                    die "data payload should be 4 bytes" if length($data) != 4;
472                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
473                    $tag_data_block->{$tag}->[ $ord ] = $data;
474                    $last_block = $ord;
475            }
476            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
477    
478            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
479            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
480    
481            return $last_block + 1;
482    }
483    
484    my $saved_in_log;
485    
486    sub decode_tag {
487            my $tag = shift;
488    
489            my $data = $tags_data->{$tag};
490            if ( ! $data ) {
491                    warn "no data for $tag\n";
492                    return;
493            }
494    
495            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
496            my $hash = {
497                    u1 => $u1,
498                    u2 => $u2,
499                    set => ( $set_item & 0xf0 ) >> 4,
500                    total => ( $set_item & 0x0f ),
501    
502                    type => $type,
503                    content => $content,
504    
505                    branch => $br_lib >> 20,
506                    library => $br_lib & 0x000fffff,
507    
508                    custom => $custom,
509            };
510    
511            if ( ! $saved_in_log->{$tag}++ ) {
512                    open(my $log, '>>', 'rfid-log.txt');
513                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
514                    close($log);
515            }
516    
517            return $hash;
518    }
519    
520    sub forget_tag {
521            my $tag = shift;
522            delete $tags_data->{$tag};
523            delete $visible_tags->{$tag};
524    }
525    
526  sub read_tag {  sub read_tag {
527          my ( $tag ) = @_;          my ( $tag ) = @_;
528    
529            confess "no tag?" unless $tag;
530    
531          print "read_tag $tag\n";          print "read_tag $tag\n";
532    
533            my $start_block = 0;
534    
535            while ( $start_block < $max_rfid_block ) {
536    
537                    cmd(
538                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
539                                    "read $tag offset: $start_block blocks: $read_blocks",
540                            "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";
541                                    $start_block = read_tag_data( $start_block, @_ );
542                                    warn "# read tag upto $start_block\n";
543                            },
544                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
545                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
546                            },
547                            "D6 00 0D 02 06 $tag", sub {
548                                    my $rest = shift;
549                                    print "ERROR reading $tag ", as_hex($rest), $/;
550                                    forget_tag $tag;
551                                    $start_block = $max_rfid_block; # XXX break out of while
552                            },
553                    );
554    
555            }
556    
557            my $security;
558    
559          cmd(          cmd(
560                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag BEEF", "check security $tag",
561                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
562                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
563                            my $from_tag;
564                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
565                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
566                            $security = as_hex( $security );
567                            $tags_security->{$tag} = $security;
568                            warn "# SECURITY $tag = $security\n";
569                  },                  },
570                  "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 {
571                          my $rest = shift || die "no rest?";                          my $rest = shift;
572                          warn "## DATA ", dump( $rest ) if $debug;                          warn "ERROR reading security from $rest\n";
573                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          forget_tag $tag;
574                          my $blocks = ord(substr($rest,8,1));                  },
575                          $rest = substr($rest,9); # leave just data blocks          );
576                          my @data;  
577                          foreach my $nr ( 0 .. $blocks - 1 ) {          print "TAG $tag ", dump(decode_tag( $tag ));
578                                  my $block = substr( $rest, $nr * 6, 6 );  }
579                                  warn "## block ",as_hex( $block ) if $debug;  
580                                  my $ord   = unpack('v',substr( $block, 0, 2 ));  sub write_tag {
581                                  die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;          my ($tag,$data) = @_;
582                                  my $data  = substr( $block, 2 );  
583                                  die "data payload should be 4 bytes" if length($data) != 4;          my $path = "$program_path/$tag";
584                                  warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;          $data = read_file( $path ) if -e $path;
585                                  $data[ $ord ] = $data;  
586                          }          die "no data" unless $data;
587                          $tags_data->{ $tag } = join('', @data);  
588                          print "DATA $tag ",dump( $tags_data ), "\n";          my $hex_data;
589    
590            if ( $data =~ s{^hex\s+}{} ) {
591                    $hex_data = $data;
592                    $hex_data =~ s{\s+}{}g;
593            } else {
594    
595                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
596    
597                    my $max_len = $max_rfid_block * 4;
598    
599                    if ( length($data) > $max_len ) {
600                            $data = substr($data,0,$max_len);
601                            warn "strip content to $max_len bytes\n";
602                  }                  }
603    
604                    $hex_data = unpack('H*', $data);
605            }
606    
607            my $len = length($hex_data) / 2;
608            # pad to block size
609            $hex_data .= '00' x ( 4 - $len % 4 );
610            my $blocks = sprintf('%02x', length($hex_data) / 4);
611    
612            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
613    
614            cmd(
615                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
616                    "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
617            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
618    
619            my $to = $path;
620            $to .= '.' . time();
621    
622            rename $path, $to;
623            print ">> $to\n";
624    
625            forget_tag $tag;
626    }
627    
628    sub secure_tag_with {
629            my ( $tag, $data ) = @_;
630    
631            cmd(
632                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
633                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
634          );          );
635    
636          #        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";  
637  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
638    
639    sub secure_tag {
640            my ($tag) = @_;
641    
642            my $path = "$secure_path/$tag";
643            my $data = substr(read_file( $path ),0,2);
644    
645            secure_tag_with( $tag, $data );
646    
647            my $to = $path;
648            $to .= '.' . time();
649    
650            rename $path, $to;
651            print ">> $to\n";
652  }  }
653    
654  exit;  exit;
# Line 219  sub writechunk Line 683  sub writechunk
683  {  {
684          my $str=shift;          my $str=shift;
685          my $count = $port->write($str);          my $count = $port->write($str);
686            my $len = length($str);
687            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
688          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
689  }  }
690    
691  sub as_hex {  sub as_hex {
692          my @out;          my @out;
693          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
694                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
695                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
696                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
697                  push @out, $hex;                  push @out, $hex;
# Line 238  sub read_bytes { Line 704  sub read_bytes {
704          my $data = '';          my $data = '';
705          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
706                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
707                  #warn "## got $c bytes: ", as_hex($b), "\n";                  die "no bytes on port: $!" unless defined $b;
708                    warn "## got $c bytes: ", as_hex($b), "\n";
709                    last if $c == 0;
710                  $data .= $b;                  $data .= $b;
711          }          }
712          $desc ||= '?';          $desc ||= '?';
# Line 284  sub crcccitt { Line 752  sub crcccitt {
752  sub checksum {  sub checksum {
753          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
754    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
755          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
756          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
757    
758          if ( $len_real != $len ) {          if ( $len_real != $len ) {
759                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
760                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
761          }          }
762    
763            my $xor = crcccitt( substr($bytes,1) ); # skip D6
764            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
765    
766          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
767                  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";
768                  return $bytes . $xor;                  return $bytes . $xor;
769          }          }
770          return $bytes . $checksum;          return $bytes . $checksum;
# Line 305  sub checksum { Line 773  sub checksum {
773  our $dispatch;  our $dispatch;
774    
775  sub readchunk {  sub readchunk {
776          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
777    
778          # read header of packet          # read header of packet
779          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 320  sub readchunk { Line 788  sub readchunk {
788          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
789          checksum( $header . $length . $payload , $checksum );          checksum( $header . $length . $payload , $checksum );
790    
791          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
792    
793          $assert->{len}      = $len;          $assert->{len}      = $len;
794          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
# Line 334  sub readchunk { Line 802  sub readchunk {
802          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
803    
804          if ( defined $to ) {          if ( defined $to ) {
805                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
806                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
807                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
808          } else {          } else {
809                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
810          }          }
811    
812          return $data;          return $data;
# Line 366  sub cmd { Line 834  sub cmd {
834          # fix checksum if needed          # fix checksum if needed
835          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
836    
837          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
838          $assert->{send} = $cmd;          $assert->{send} = $cmd;
839          writechunk( $bytes );          writechunk( $bytes );
840    
Legend:
Removed from v.21  
changed lines
  Added in v.86
  ViewVC Help
Powered by ViewVC 1.1.26