/[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 29 by dpavlin, Mon Apr 6 13:10:40 2009 UTC cpr-m02.pl revision 89 by dpavlin, Fri Jul 16 13:50:52 2010 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10  use File::Slurp;  use File::Slurp;
11    use JSON;
12    use POSIX qw(strftime);
13    use Time::HiRes;
14    
15  use IO::Socket::INET;  use IO::Socket::INET;
16    
17  my $meteor_server = '192.168.1.13:4671';  my $debug = 0;
18  my $meteor_fh;  
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  sub meteor {                  $path = "www/$path";
43          my @a = @_;                  $path .= 'rfid.html' if $path =~ m{/$};
44          push @a, scalar localtime() if $a[0] =~ m{^info};  
45                    return unless -e $path;
46          if ( ! defined $meteor_fh ) {  
47                  warn "# open connection to $meteor_server";                  my $type = 'text/plain';
48                  $meteor_fh = IO::Socket::INET->new(                  $type = 'text/html' if $path =~ m{\.htm};
49                                  PeerAddr => $meteor_server,                  $type = 'application/javascript' if $path =~ m{\.js};
50                                  Timeout => 1,  
51                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                  print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
52                  $meteor_fh = 0; # don't try again                  open(my $html, $path);
53                    while(<$html>) {
54                            print $client $_;
55                    }
56                    close($html);
57    
58                    return $path;
59          }          }
60    
61          warn ">> meteor ",dump( @a );          while (my $client = $server->accept()) {
62          print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;                  $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  my $debug = 0;  
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/';  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?',
# Line 62  GetOptions( Line 193  GetOptions(
193          'parity=s'    => \$parity,          'parity=s'    => \$parity,
194          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
195          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
196          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
197  ) or die $!;  ) or die $!;
198    
199  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 98  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 109  $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 debug: $debug verbose: $verbose\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 120  $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_psst_wait {
291            # Protocol Start Synchronization Time (PSST): 5ms < data timeout 12 ms
292            Time::HiRes::sleep 0.005;
293    }
294    
295    sub cpr {
296            my ( $hex, $description, $coderef ) = @_;
297            my $bytes = str2bytes($hex);
298            my $len = pack( 'c', length( $bytes ) + 3 );
299            my $send = $len . $bytes;
300            my $checksum = cpr_m02_checksum($send);
301            $send .= $checksum;
302    
303            warn ">> ", as_hex( $send ), "\t\t[$description]\n";
304            $port->write( $send );
305    
306            cpr_psst_wait;
307    
308            my $r_len = $port->read(1);
309    
310            while ( ! $r_len ) {
311                    warn "# wait for response length 5ms\n";
312                    cpr_psst_wait;
313                    $r_len = $port->read(1);
314            }
315    
316            my $data_len = ord($r_len) - 1;
317            my $data = $port->read( $data_len );
318            warn "<< ", as_hex( $r_len . $data ),"\n";
319    
320            cpr_psst_wait;
321    
322            $coderef->( $data ) if $coderef;
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    
337    sub cpr_read {
338            my $uid = shift;
339            my $hex_uid = as_hex($uid);
340    
341            cpr( "FF  B0 23  01  $hex_uid 00 04", "Read Multiple Blocks $hex_uid" );
342            cpr( "FF  B0 2B  01  $hex_uid", "Get System Information $hex_uid", sub {
343                    my $data = shift;
344    
345                    warn "# data ",as_hex($data);
346    
347                    my $DSFID    = substr($data,5-2,1);
348                    my $UID      = substr($data,6-2,8);
349                    my $AFI      = substr($data,14-2,1);
350                    my $MEM_SIZE = substr($data,15-2,2);
351                    my $IC_REF   = substr($data,17-2,1);
352    
353                    warn "# split ",as_hex( $DSFID, $UID, $AFI, $MEM_SIZE, $IC_REF );
354    
355            });
356    }
357    
358    
359    my $inventory;
360    
361    while(1) {
362    
363    cpr( 'FF  B0  01 00', 'ISO - Inventory', sub {
364            my $data = shift;
365            if (length($data) < 5 + 2 ) {
366                    warn "# no tags in range\n";
367                    return;
368            }
369            my $data_sets = ord(substr($data,3,1));
370            $data = substr($data,4);
371            foreach ( 1 .. $data_sets ) {
372                    my $tr_type = substr($data,0,1);
373                    die "FIXME only TR-TYPE=3 ISO 15693 supported" unless $tr_type eq "\x03";
374                    my $dsfid   = substr($data,1,1);
375                    my $uid     = substr($data,2,8);
376                    $inventory->{$uid}++;
377                    $data = substr($data,10);
378                    warn "# TAG $_ ",as_hex( $tr_type, $dsfid, $uid ),$/;
379    
380                    cpr_read( $uid );
381            }
382            warn "inventory: ",dump($inventory);
383    });
384    
385    }
386    
387    #cpr( '', '?' );
388    
389    exit;
390  # initial hand-shake with device  # initial hand-shake with device
391    
392  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
393       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
394          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
395          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
396  });  });
397    
398  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?',
399       '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() }  );
400    
401  # start scanning for tags  sub scan_for_tags {
402    
403  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
          'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
                 my $rest = shift || die "no rest?";  
                 my $nr = ord( substr( $rest, 0, 1 ) );  
   
                 if ( ! $nr ) {  
                         print "no tags in range\n";  
                         update_visible_tags();  
                         meteor( 'info-none-in-range' );  
                         $tags_data = {};  
                 } else {  
404    
405                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
406                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
407                            my $rest = shift || die "no rest?";
408                            my $nr = ord( substr( $rest, 0, 1 ) );
409    
410                            if ( ! $nr ) {
411                                    _log "no tags in range\n";
412                                    update_visible_tags();
413                                    $tags_data = {};
414                            } else {
415    
416                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
417                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
418                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
419    
420                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
421                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
422                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
423    
424                          my @tags;                                  update_visible_tags( @tags );
425                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
426                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
427                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
428    
429                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
430            return $tags_data;
431    
432                          update_visible_tags( @tags );  }
                 }  
         }  
 ) while(1);  
 #) foreach ( 1 .. 100 );  
433    
434    # start scanning for tags
435    
436    if ( $http_server ) {
437            http_server;
438    } else {
439            while (1) {
440                    scan_for_tags;
441                    sleep 1;
442            }
443    }
444    
445    die "over and out";
446    
447  sub update_visible_tags {  sub update_visible_tags {
448          my @tags = @_;          my @tags = @_;
# Line 173  sub update_visible_tags { Line 451  sub update_visible_tags {
451          $visible_tags = {};          $visible_tags = {};
452    
453          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
454                    $visible_tags->{$tag}++;
455                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
456                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
457  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
458                          } else {                          } else {
                                 meteor( 'read', $tag );  
459                                  read_tag( $tag );                                  read_tag( $tag );
460                          }                          }
                         $visible_tags->{$tag}++;  
461                  } else {                  } else {
462                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
463                  }                  }
464                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
465    
466                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
467                                  write_tag( $tag );                                  write_tag( $tag );
468                  }                  }
469                    if ( -e "$secure_path/$tag" ) {
470                                    secure_tag( $tag );
471                    }
472          }          }
473    
474          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
475                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
476                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
477          }          }
478    
479          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
# Line 206  my $tag_data_block; Line 484  my $tag_data_block;
484  sub read_tag_data {  sub read_tag_data {
485          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
486          die "no rest?" unless $rest;          die "no rest?" unless $rest;
487    
488            my $last_block = 0;
489    
490          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
491          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
492          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 215  sub read_tag_data { Line 496  sub read_tag_data {
496                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
497                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
498                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
499                  die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;                  warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
500                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
501                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
502                  warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
503                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
504                    $last_block = $ord;
505          }          }
506          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
507          print "DATA $tag ",dump( $tags_data ), "\n";  
508            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
509            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
510    
511            return $last_block + 1;
512    }
513    
514    my $saved_in_log;
515    
516    sub decode_tag {
517            my $tag = shift;
518    
519            my $data = $tags_data->{$tag};
520            if ( ! $data ) {
521                    warn "no data for $tag\n";
522                    return;
523            }
524    
525            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
526            my $hash = {
527                    u1 => $u1,
528                    u2 => $u2,
529                    set => ( $set_item & 0xf0 ) >> 4,
530                    total => ( $set_item & 0x0f ),
531    
532                    type => $type,
533                    content => $content,
534    
535                    branch => $br_lib >> 20,
536                    library => $br_lib & 0x000fffff,
537    
538                    custom => $custom,
539            };
540    
541            if ( ! $saved_in_log->{$tag}++ ) {
542                    open(my $log, '>>', 'rfid-log.txt');
543                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
544                    close($log);
545            }
546    
547            return $hash;
548    }
549    
550    sub forget_tag {
551            my $tag = shift;
552            delete $tags_data->{$tag};
553            delete $visible_tags->{$tag};
554  }  }
555    
556  sub read_tag {  sub read_tag {
# Line 232  sub read_tag { Line 560  sub read_tag {
560    
561          print "read_tag $tag\n";          print "read_tag $tag\n";
562    
563            my $start_block = 0;
564    
565            while ( $start_block < $max_rfid_block ) {
566    
567                    cmd(
568                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
569                                    "read $tag offset: $start_block blocks: $read_blocks",
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";
571                                    $start_block = read_tag_data( $start_block, @_ );
572                                    warn "# read tag upto $start_block\n";
573                            },
574                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
575                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
576                            },
577                            "D6 00 0D 02 06 $tag", sub {
578                                    my $rest = shift;
579                                    print "ERROR reading $tag ", as_hex($rest), $/;
580                                    forget_tag $tag;
581                                    $start_block = $max_rfid_block; # XXX break out of while
582                            },
583                    );
584    
585            }
586    
587            my $security;
588    
589          cmd(          cmd(
590                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
591                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
592                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
593                            my $from_tag;
594                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
595                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
596                            $security = as_hex( $security );
597                            $tags_security->{$tag} = $security;
598                            warn "# SECURITY $tag = $security\n";
599                  },                  },
600                  "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 {
601                          read_tag_data( 0, @_ );                          my $rest = shift;
602                            warn "ERROR reading security from $rest\n";
603                            forget_tag $tag;
604                  },                  },
605          );          );
606    
607          cmd(          print "TAG $tag ", dump(decode_tag( $tag ));
                 "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
                 "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
                         read_tag_data( 3, @_ );  
                 }  
         );  
   
608  }  }
609    
610  sub write_tag {  sub write_tag {
611          my ($tag) = @_;          my ($tag,$data) = @_;
612    
613          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
614            $data = read_file( $path ) if -e $path;
615    
616          my $data = read_file( $path );          die "no data" unless $data;
617    
618          print "write_tag $tag = $data\n";          my $hex_data;
619    
620            if ( $data =~ s{^hex\s+}{} ) {
621                    $hex_data = $data;
622                    $hex_data =~ s{\s+}{}g;
623            } else {
624    
625                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
626    
627                    my $max_len = $max_rfid_block * 4;
628    
629                    if ( length($data) > $max_len ) {
630                            $data = substr($data,0,$max_len);
631                            warn "strip content to $max_len bytes\n";
632                    }
633    
634                    $hex_data = unpack('H*', $data);
635            }
636    
637            my $len = length($hex_data) / 2;
638            # pad to block size
639            $hex_data .= '00' x ( 4 - $len % 4 );
640            my $blocks = sprintf('%02x', length($hex_data) / 4);
641    
642            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
643    
644          cmd(          cmd(
645                  "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
646                  "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
647          ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
648    
649          my $to = $path;          my $to = $path;
650          $to .= '.' . time();          $to .= '.' . time();
# Line 271  sub write_tag { Line 652  sub write_tag {
652          rename $path, $to;          rename $path, $to;
653          print ">> $to\n";          print ">> $to\n";
654    
655            forget_tag $tag;
656    }
657    
658    sub secure_tag_with {
659            my ( $tag, $data ) = @_;
660    
661            cmd(
662                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
663                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
664            );
665    
666            forget_tag $tag;
667    }
668    
669    sub secure_tag {
670            my ($tag) = @_;
671    
672            my $path = "$secure_path/$tag";
673            my $data = substr(read_file( $path ),0,2);
674    
675            secure_tag_with( $tag, $data );
676    
677            my $to = $path;
678            $to .= '.' . time();
679    
680            rename $path, $to;
681            print ">> $to\n";
682  }  }
683    
684  exit;  exit;
# Line 305  sub writechunk Line 713  sub writechunk
713  {  {
714          my $str=shift;          my $str=shift;
715          my $count = $port->write($str);          my $count = $port->write($str);
716            my $len = length($str);
717            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
718          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
719  }  }
720    
721  sub as_hex {  sub as_hex {
722          my @out;          my @out;
723          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
724                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
725                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
726                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
727                  push @out, $hex;                  push @out, $hex;
# Line 325  sub read_bytes { Line 735  sub read_bytes {
735          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
736                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
737                  die "no bytes on port: $!" unless defined $b;                  die "no bytes on port: $!" unless defined $b;
738                  #warn "## got $c bytes: ", as_hex($b), "\n";                  warn "## got $c bytes: ", as_hex($b), "\n";
739                    last if $c == 0;
740                  $data .= $b;                  $data .= $b;
741          }          }
742          $desc ||= '?';          $desc ||= '?';
# Line 371  sub crcccitt { Line 782  sub crcccitt {
782  sub checksum {  sub checksum {
783          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
784    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
785          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
786          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
787    
788          if ( $len_real != $len ) {          if ( $len_real != $len ) {
789                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
790                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
791          }          }
792    
793            my $xor = crcccitt( substr($bytes,1) ); # skip D6
794            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
795    
796          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
797                  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";
798                  return $bytes . $xor;                  return $bytes . $xor;
799          }          }
800          return $bytes . $checksum;          return $bytes . $checksum;
# Line 392  sub checksum { Line 803  sub checksum {
803  our $dispatch;  our $dispatch;
804    
805  sub readchunk {  sub readchunk {
806          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
807    
808          # read header of packet          # read header of packet
809          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 421  sub readchunk { Line 832  sub readchunk {
832          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
833    
834          if ( defined $to ) {          if ( defined $to ) {
835                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
836                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
837                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
838          } else {          } else {
839                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
840          }          }
841    
842          return $data;          return $data;
Legend:
Removed from v.29  
changed lines
  Added in v.89
  ViewVC Help
Powered by ViewVC 1.1.26