/[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 85 by dpavlin, Mon Jul 12 12:00:39 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  sub meteor {          print "Server $0 ready at $server_url\n";
38          my @a = @_;  
39          push @a, scalar localtime() if $a[0] =~ m{^info};          sub static {
40                    my ($client,$path) = @_;
41          if ( ! defined $meteor_fh ) {  
42                  warn "# open connection to $meteor_server";                  $path = "www/$path";
43                  $meteor_fh = IO::Socket::INET->new(                  $path .= 'rfid.html' if $path =~ m{/$};
44                                  PeerAddr => $meteor_server,  
45                                  Timeout => 1,                  return unless -e $path;
46                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production  
47                  $meteor_fh = 0; # don't try again                  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          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/';  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 {
291            my ( $hex, $description ) = @_;
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            Time::HiRes::sleep 0.050;
315    }
316    
317    # FF = COM-ADDR any
318    
319    cpr( 'FF  52 00',       'Boud Rate Detection' );
320    
321    cpr( 'FF  65',          'Get Software Version' );
322    
323    cpr( 'FF  66 00',       'Get Reader Info - General hard and firware' );
324    
325    cpr( 'FF  69',          'RF Reset' );
326    
327    cpr( 'FF  B0  01 00', 'ISO - Inventory' );
328    
329    #cpr( '', '?' );
330    
331    exit;
332  # initial hand-shake with device  # initial hand-shake with device
333    
334  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
335       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
336          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
337          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
338  });  });
339    
340  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?',
341       '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() }  );
342    
343  # start scanning for tags  sub scan_for_tags {
344    
345  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 {  
346    
347                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
348                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
349                            my $rest = shift || die "no rest?";
350                            my $nr = ord( substr( $rest, 0, 1 ) );
351    
352                            if ( ! $nr ) {
353                                    _log "no tags in range\n";
354                                    update_visible_tags();
355                                    $tags_data = {};
356                            } else {
357    
358                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
359                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
360                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
361    
362                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
363                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
364                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
365    
366                          my @tags;                                  update_visible_tags( @tags );
367                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
368                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
369                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
370    
371                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
372            return $tags_data;
373    
374                          update_visible_tags( @tags );  }
375                  }  
376          }  # start scanning for tags
 ) while(1);  
 #) foreach ( 1 .. 100 );  
377    
378    if ( $http_server ) {
379            http_server;
380    } else {
381            while (1) {
382                    scan_for_tags;
383                    sleep 1;
384            }
385    }
386    
387    die "over and out";
388    
389  sub update_visible_tags {  sub update_visible_tags {
390          my @tags = @_;          my @tags = @_;
# Line 191  sub update_visible_tags { Line 393  sub update_visible_tags {
393          $visible_tags = {};          $visible_tags = {};
394    
395          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
396                    $visible_tags->{$tag}++;
397                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
398                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
399  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
400                          } else {                          } else {
                                 meteor( 'read', $tag );  
401                                  read_tag( $tag );                                  read_tag( $tag );
402                          }                          }
                         $visible_tags->{$tag}++;  
403                  } else {                  } else {
404                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
405                  }                  }
406                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
407    
408                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
409                                  write_tag( $tag );                                  write_tag( $tag );
410                  }                  }
411                  if ( -e "$secure_path/$tag" ) {                  if ( -e "$secure_path/$tag" ) {
                                 meteor( 'secure', $tag );  
412                                  secure_tag( $tag );                                  secure_tag( $tag );
413                  }                  }
414          }          }
415    
416          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
417                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
418                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
419          }          }
420    
421          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 426  my $tag_data_block;
426  sub read_tag_data {  sub read_tag_data {
427          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
428          die "no rest?" unless $rest;          die "no rest?" unless $rest;
429    
430            my $last_block = 0;
431    
432          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
433          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
434          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 237  sub read_tag_data { Line 438  sub read_tag_data {
438                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
439                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
440                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
441                  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;
442                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
443                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
444                  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;
445                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
446                    $last_block = $ord;
447          }          }
448          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
449    
450          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
451          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";
452    
453            return $last_block + 1;
454    }
455    
456    my $saved_in_log;
457    
458    sub decode_tag {
459            my $tag = shift;
460    
461            my $data = $tags_data->{$tag};
462            if ( ! $data ) {
463                    warn "no data for $tag\n";
464                    return;
465            }
466    
467            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
468            my $hash = {
469                    u1 => $u1,
470                    u2 => $u2,
471                    set => ( $set_item & 0xf0 ) >> 4,
472                    total => ( $set_item & 0x0f ),
473    
474                    type => $type,
475                    content => $content,
476    
477                    branch => $br_lib >> 20,
478                    library => $br_lib & 0x000fffff,
479    
480                    custom => $custom,
481            };
482    
483            if ( ! $saved_in_log->{$tag}++ ) {
484                    open(my $log, '>>', 'rfid-log.txt');
485                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
486                    close($log);
487            }
488    
489            return $hash;
490    }
491    
492    sub forget_tag {
493            my $tag = shift;
494            delete $tags_data->{$tag};
495            delete $visible_tags->{$tag};
496  }  }
497    
498  sub read_tag {  sub read_tag {
# Line 256  sub read_tag { Line 502  sub read_tag {
502    
503          print "read_tag $tag\n";          print "read_tag $tag\n";
504    
505          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, @_ );  
                 },  
         );  
506    
507          cmd(          while ( $start_block < $max_rfid_block ) {
508                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
509                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
510                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
511                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
512          );                          "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";
513                                    $start_block = read_tag_data( $start_block, @_ );
514                                    warn "# read tag upto $start_block\n";
515                            },
516                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
517                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
518                            },
519                            "D6 00 0D 02 06 $tag", sub {
520                                    my $rest = shift;
521                                    print "ERROR reading $tag ", as_hex($rest), $/;
522                                    forget_tag $tag;
523                                    $start_block = $max_rfid_block; # XXX break out of while
524                            },
525                    );
526    
527            }
528    
529          my $security;          my $security;
530    
531          cmd(          cmd(
532                  "D6 00 0B 0A $tag 1234", "check security $tag",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
533                  "D6 00 0D 0A 00", sub {                  "D6 00 0D 0A 00", sub {
534                          my $rest = shift;                          my $rest = shift;
535                          my $from_tag;                          my $from_tag;
536                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
537                          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 );
538                          $security = as_hex( $security );                          $security = as_hex( $security );
539                            $tags_security->{$tag} = $security;
540                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
541                  }                  },
542                    "D6 00 0C 0A 06", sub {
543                            my $rest = shift;
544                            warn "ERROR reading security from $rest\n";
545                            forget_tag $tag;
546                    },
547          );          );
548    
549          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";  
   
550  }  }
551    
552  sub write_tag {  sub write_tag {
553          my ($tag) = @_;          my ($tag,$data) = @_;
554    
555          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
556            $data = read_file( $path ) if -e $path;
557    
558          my $data = read_file( $path );          die "no data" unless $data;
559    
560            my $hex_data;
561    
562            if ( $data =~ s{^hex\s+}{} ) {
563                    $hex_data = $data;
564                    $hex_data =~ s{\s+}{}g;
565            } else {
566    
567                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
568    
569                    my $max_len = $max_rfid_block * 4;
570    
571                    if ( length($data) > $max_len ) {
572                            $data = substr($data,0,$max_len);
573                            warn "strip content to $max_len bytes\n";
574                    }
575    
576          $data = substr($data,0,16);                  $hex_data = unpack('H*', $data);
577            }
578    
579          my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) );          my $len = length($hex_data) / 2;
580            # pad to block size
581            $hex_data .= '00' x ( 4 - $len % 4 );
582            my $blocks = sprintf('%02x', length($hex_data) / 4);
583    
584          print "write_tag $tag = $data ",dump( $hex_data );          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
585    
586          cmd(          cmd(
587                  "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",
588                  "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
589          ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
590    
591          my $to = $path;          my $to = $path;
592          $to .= '.' . time();          $to .= '.' . time();
# Line 321  sub write_tag { Line 594  sub write_tag {
594          rename $path, $to;          rename $path, $to;
595          print ">> $to\n";          print ">> $to\n";
596    
597          delete $tags_data->{$tag};      # force re-read of tag          forget_tag $tag;
598    }
599    
600    sub secure_tag_with {
601            my ( $tag, $data ) = @_;
602    
603            cmd(
604                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
605                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
606            );
607    
608            forget_tag $tag;
609  }  }
610    
611  sub secure_tag {  sub secure_tag {
# Line 330  sub secure_tag { Line 614  sub secure_tag {
614          my $path = "$secure_path/$tag";          my $path = "$secure_path/$tag";
615          my $data = substr(read_file( $path ),0,2);          my $data = substr(read_file( $path ),0,2);
616    
617          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() },  
         );  
618    
619          my $to = $path;          my $to = $path;
620          $to .= '.' . time();          $to .= '.' . time();
# Line 374  sub writechunk Line 655  sub writechunk
655  {  {
656          my $str=shift;          my $str=shift;
657          my $count = $port->write($str);          my $count = $port->write($str);
658            my $len = length($str);
659            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
660          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
661  }  }
662    
663  sub as_hex {  sub as_hex {
664          my @out;          my @out;
665          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
666                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
667                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
668                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
669                  push @out, $hex;                  push @out, $hex;
# Line 394  sub read_bytes { Line 677  sub read_bytes {
677          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
678                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
679                  die "no bytes on port: $!" unless defined $b;                  die "no bytes on port: $!" unless defined $b;
680                  #warn "## got $c bytes: ", as_hex($b), "\n";                  warn "## got $c bytes: ", as_hex($b), "\n";
681                    last if $c == 0;
682                  $data .= $b;                  $data .= $b;
683          }          }
684          $desc ||= '?';          $desc ||= '?';
# Line 440  sub crcccitt { Line 724  sub crcccitt {
724  sub checksum {  sub checksum {
725          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
726    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
727          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
728          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
729    
730          if ( $len_real != $len ) {          if ( $len_real != $len ) {
731                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
732                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
733          }          }
734    
735            my $xor = crcccitt( substr($bytes,1) ); # skip D6
736            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
737    
738          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
739                  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";
740                  return $bytes . $xor;                  return $bytes . $xor;
741          }          }
742          return $bytes . $checksum;          return $bytes . $checksum;
# Line 461  sub checksum { Line 745  sub checksum {
745  our $dispatch;  our $dispatch;
746    
747  sub readchunk {  sub readchunk {
748          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
749    
750          # read header of packet          # read header of packet
751          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 490  sub readchunk { Line 774  sub readchunk {
774          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
775    
776          if ( defined $to ) {          if ( defined $to ) {
777                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
778                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
779                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
780          } else {          } else {
781                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
782          }          }
783    
784          return $data;          return $data;
Legend:
Removed from v.34  
changed lines
  Added in v.85
  ViewVC Help
Powered by ViewVC 1.1.26