/[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 34 by dpavlin, Wed Apr 8 15:03:49 2009 UTC cpr-m02.pl revision 87 by dpavlin, Fri Jul 16 13:05:24 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                    $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  sub meteor {                          } else {
132          my @a = @_;                                  print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
133          push @a, scalar localtime() if $a[0] =~ m{^info};                          }
134                    } else {
135          if ( ! defined $meteor_fh ) {                          print $client "HTTP/1.0 500 No method\r\n\r\n";
136                  warn "# open connection to $meteor_server";                  }
137                  $meteor_fh = IO::Socket::INET->new(                  close $client;
                                 PeerAddr => $meteor_server,  
                                 Timeout => 1,  
                 ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production  
                 $meteor_fh = 0; # don't try again  
138          }          }
139    
140          warn ">> meteor ",dump( @a );          die "server died";
         print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;  
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/';  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 63  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 99  it under the same terms ans Perl itself. Line 229  it under the same terms ans Perl itself.
229    
230  =cut  =cut
231    
 my $tags_data;  
 my $visible_tags;  
   
232  my $item_type = {  my $item_type = {
233          1 => 'Book',          1 => 'Book',
234          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 127  $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 138  $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" );
343    }
344    
345    
346    my $inventory;
347    
348    while(1) {
349    
350    cpr( 'FF  B0  01 00', 'ISO - Inventory', sub {
351            my $data = shift;
352            my $data_sets = ord(substr($data,3,1));
353            $data = substr($data,4);
354            foreach ( 1 .. $data_sets ) {
355                    my $tr_type = substr($data,0,1);
356                    die "FIXME only TR-TYPE=3 ISO 15693 supported" unless $tr_type eq "\x03";
357                    my $dsfid   = substr($data,1,1);
358                    my $uid     = substr($data,2,8);
359                    $inventory->{$uid}++;
360                    $data = substr($data,10);
361                    warn "# TAG $_ ",as_hex( $tr_type, $dsfid, $uid ),$/;
362    
363                    cpr_read( $uid );
364            }
365            warn "inventory: ",dump($inventory);
366    });
367    
368    }
369    
370    #cpr( '', '?' );
371    
372    exit;
373  # initial hand-shake with device  # initial hand-shake with device
374    
375  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
376       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
377          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
378          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
379  });  });
380    
381  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?',
382       '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() }  );
383    
384  # start scanning for tags  sub scan_for_tags {
385    
386  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
387           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
388                  my $rest = shift || die "no rest?";          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
389                  my $nr = ord( substr( $rest, 0, 1 ) );                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
390                            my $rest = shift || die "no rest?";
391                  if ( ! $nr ) {                          my $nr = ord( substr( $rest, 0, 1 ) );
392                          print "no tags in range\n";  
393                          update_visible_tags();                          if ( ! $nr ) {
394                          meteor( 'info-none-in-range' );                                  _log "no tags in range\n";
395                          $tags_data = {};                                  update_visible_tags();
396                  } else {                                  $tags_data = {};
397                            } else {
398    
399                                    my $tags = substr( $rest, 1 );
400                                    my $tl = length( $tags );
401                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
402    
403                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
404                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
405                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
406    
407                          my $tags = substr( $rest, 1 );                                  update_visible_tags( @tags );
408                            }
409                    }
410            );
411    
412                          my $tl = length( $tags );          diag "tags: ",dump( @tags );
413                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;          return $tags_data;
414    
415                          my @tags;  }
                         push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );  
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
416    
417                          meteor( 'info-in-range', join(' ',@tags));  # start scanning for tags
418    
419                          update_visible_tags( @tags );  if ( $http_server ) {
420                  }          http_server;
421    } else {
422            while (1) {
423                    scan_for_tags;
424                    sleep 1;
425          }          }
426  ) while(1);  }
 #) foreach ( 1 .. 100 );  
   
427    
428    die "over and out";
429    
430  sub update_visible_tags {  sub update_visible_tags {
431          my @tags = @_;          my @tags = @_;
# Line 191  sub update_visible_tags { Line 434  sub update_visible_tags {
434          $visible_tags = {};          $visible_tags = {};
435    
436          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
437                    $visible_tags->{$tag}++;
438                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
439                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
440  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
441                          } else {                          } else {
                                 meteor( 'read', $tag );  
442                                  read_tag( $tag );                                  read_tag( $tag );
443                          }                          }
                         $visible_tags->{$tag}++;  
444                  } else {                  } else {
445                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
446                  }                  }
447                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
448    
449                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
450                                  write_tag( $tag );                                  write_tag( $tag );
451                  }                  }
452                  if ( -e "$secure_path/$tag" ) {                  if ( -e "$secure_path/$tag" ) {
                                 meteor( 'secure', $tag );  
453                                  secure_tag( $tag );                                  secure_tag( $tag );
454                  }                  }
455          }          }
456    
457          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
458                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
459                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
460          }          }
461    
462          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 228  my $tag_data_block; Line 467  my $tag_data_block;
467  sub read_tag_data {  sub read_tag_data {
468          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
469          die "no rest?" unless $rest;          die "no rest?" unless $rest;
470    
471            my $last_block = 0;
472    
473          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
474          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
475          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 237  sub read_tag_data { Line 479  sub read_tag_data {
479                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
480                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
481                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
482                  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;
483                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
484                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
485                  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;
486                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
487                    $last_block = $ord;
488          }          }
489          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
490    
491          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
492          print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";          print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
493    
494            return $last_block + 1;
495    }
496    
497    my $saved_in_log;
498    
499    sub decode_tag {
500            my $tag = shift;
501    
502            my $data = $tags_data->{$tag};
503            if ( ! $data ) {
504                    warn "no data for $tag\n";
505                    return;
506            }
507    
508            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
509            my $hash = {
510                    u1 => $u1,
511                    u2 => $u2,
512                    set => ( $set_item & 0xf0 ) >> 4,
513                    total => ( $set_item & 0x0f ),
514    
515                    type => $type,
516                    content => $content,
517    
518                    branch => $br_lib >> 20,
519                    library => $br_lib & 0x000fffff,
520    
521                    custom => $custom,
522            };
523    
524            if ( ! $saved_in_log->{$tag}++ ) {
525                    open(my $log, '>>', 'rfid-log.txt');
526                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
527                    close($log);
528            }
529    
530            return $hash;
531    }
532    
533    sub forget_tag {
534            my $tag = shift;
535            delete $tags_data->{$tag};
536            delete $visible_tags->{$tag};
537  }  }
538    
539  sub read_tag {  sub read_tag {
# Line 256  sub read_tag { Line 543  sub read_tag {
543    
544          print "read_tag $tag\n";          print "read_tag $tag\n";
545    
546          cmd(          my $start_block = 0;
                 "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",  
                 "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {  
                         print "FIXME: tag $tag ready?\n";  
                 },  
                 "D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";  
                         read_tag_data( 0, @_ );  
                 },  
         );  
547    
548          cmd(          while ( $start_block < $max_rfid_block ) {
549                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
550                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
551                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
552                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
553          );                          "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";
554                                    $start_block = read_tag_data( $start_block, @_ );
555                                    warn "# read tag upto $start_block\n";
556                            },
557                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
558                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
559                            },
560                            "D6 00 0D 02 06 $tag", sub {
561                                    my $rest = shift;
562                                    print "ERROR reading $tag ", as_hex($rest), $/;
563                                    forget_tag $tag;
564                                    $start_block = $max_rfid_block; # XXX break out of while
565                            },
566                    );
567    
568            }
569    
570          my $security;          my $security;
571    
572          cmd(          cmd(
573                  "D6 00 0B 0A $tag 1234", "check security $tag",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
574                  "D6 00 0D 0A 00", sub {                  "D6 00 0D 0A 00", sub {
575                          my $rest = shift;                          my $rest = shift;
576                          my $from_tag;                          my $from_tag;
577                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
578                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
579                          $security = as_hex( $security );                          $security = as_hex( $security );
580                            $tags_security->{$tag} = $security;
581                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
582                  }                  },
583                    "D6 00 0C 0A 06", sub {
584                            my $rest = shift;
585                            warn "ERROR reading security from $rest\n";
586                            forget_tag $tag;
587                    },
588          );          );
589    
590          my $data = $tags_data->{$tag} || die "no data for $tag";          print "TAG $tag ", dump(decode_tag( $tag ));
         my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);  
         my $set   = ( $set_item & 0xf0 ) >> 4;  
         my $total = ( $set_item & 0x0f );  
         my $branch  = $br_lib >> 20;  
         my $library = $br_lib & 0x000fffff;  
         print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n";  
   
591  }  }
592    
593  sub write_tag {  sub write_tag {
594          my ($tag) = @_;          my ($tag,$data) = @_;
595    
596          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
597            $data = read_file( $path ) if -e $path;
598    
599          my $data = read_file( $path );          die "no data" unless $data;
600    
601          $data = substr($data,0,16);          my $hex_data;
602    
603          my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) );          if ( $data =~ s{^hex\s+}{} ) {
604                    $hex_data = $data;
605                    $hex_data =~ s{\s+}{}g;
606            } else {
607    
608          print "write_tag $tag = $data ",dump( $hex_data );                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );
609    
610                    my $max_len = $max_rfid_block * 4;
611    
612                    if ( length($data) > $max_len ) {
613                            $data = substr($data,0,$max_len);
614                            warn "strip content to $max_len bytes\n";
615                    }
616    
617                    $hex_data = unpack('H*', $data);
618            }
619    
620            my $len = length($hex_data) / 2;
621            # pad to block size
622            $hex_data .= '00' x ( 4 - $len % 4 );
623            my $blocks = sprintf('%02x', length($hex_data) / 4);
624    
625            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
626    
627          cmd(          cmd(
628                  "d6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  fd3b", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
629                  "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
630          ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
631    
632          my $to = $path;          my $to = $path;
633          $to .= '.' . time();          $to .= '.' . time();
# Line 321  sub write_tag { Line 635  sub write_tag {
635          rename $path, $to;          rename $path, $to;
636          print ">> $to\n";          print ">> $to\n";
637    
638          delete $tags_data->{$tag};      # force re-read of tag          forget_tag $tag;
639    }
640    
641    sub secure_tag_with {
642            my ( $tag, $data ) = @_;
643    
644            cmd(
645                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
646                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
647            );
648    
649            forget_tag $tag;
650  }  }
651    
652  sub secure_tag {  sub secure_tag {
# Line 330  sub secure_tag { Line 655  sub secure_tag {
655          my $path = "$secure_path/$tag";          my $path = "$secure_path/$tag";
656          my $data = substr(read_file( $path ),0,2);          my $data = substr(read_file( $path ),0,2);
657    
658          cmd(          secure_tag_with( $tag, $data );
                 "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",  
                 "d6 00  0c  09 00  $tag  1234", sub { assert() },  
         );  
659    
660          my $to = $path;          my $to = $path;
661          $to .= '.' . time();          $to .= '.' . time();
# Line 374  sub writechunk Line 696  sub writechunk
696  {  {
697          my $str=shift;          my $str=shift;
698          my $count = $port->write($str);          my $count = $port->write($str);
699            my $len = length($str);
700            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
701          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
702  }  }
703    
704  sub as_hex {  sub as_hex {
705          my @out;          my @out;
706          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
707                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
708                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
709                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
710                  push @out, $hex;                  push @out, $hex;
# Line 394  sub read_bytes { Line 718  sub read_bytes {
718          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
719                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
720                  die "no bytes on port: $!" unless defined $b;                  die "no bytes on port: $!" unless defined $b;
721                  #warn "## got $c bytes: ", as_hex($b), "\n";                  warn "## got $c bytes: ", as_hex($b), "\n";
722                    last if $c == 0;
723                  $data .= $b;                  $data .= $b;
724          }          }
725          $desc ||= '?';          $desc ||= '?';
# Line 440  sub crcccitt { Line 765  sub crcccitt {
765  sub checksum {  sub checksum {
766          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
767    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
768          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
769          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
770    
771          if ( $len_real != $len ) {          if ( $len_real != $len ) {
772                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
773                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
774          }          }
775    
776            my $xor = crcccitt( substr($bytes,1) ); # skip D6
777            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
778    
779          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
780                  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";
781                  return $bytes . $xor;                  return $bytes . $xor;
782          }          }
783          return $bytes . $checksum;          return $bytes . $checksum;
# Line 461  sub checksum { Line 786  sub checksum {
786  our $dispatch;  our $dispatch;
787    
788  sub readchunk {  sub readchunk {
789          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
790    
791          # read header of packet          # read header of packet
792          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 490  sub readchunk { Line 815  sub readchunk {
815          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
816    
817          if ( defined $to ) {          if ( defined $to ) {
818                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
819                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
820                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
821          } else {          } else {
822                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
823          }          }
824    
825          return $data;          return $data;
Legend:
Removed from v.34  
changed lines
  Added in v.87
  ViewVC Help
Powered by ViewVC 1.1.26