/[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 82 by dpavlin, Fri Jul 9 23:10:05 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    
14  use IO::Socket::INET;  use IO::Socket::INET;
15    
16  my $meteor_server = '192.168.1.13:4671';  my $debug = 2;
 my $meteor_fh;  
17    
18  sub meteor {  my $tags_data;
19          my @a = @_;  my $tags_security;
20          push @a, scalar localtime() if $a[0] =~ m{^info};  my $visible_tags;
21    
22    my $listen_port = 9000;                  # pick something not in use
23    my $server_url  = "http://localhost:$listen_port";
24    
25    sub http_server {
26    
27            my $server = IO::Socket::INET->new(
28                    Proto     => 'tcp',
29                    LocalPort => $listen_port,
30                    Listen    => SOMAXCONN,
31                    Reuse     => 1
32            );
33                                                                      
34            die "can't setup server: $!" unless $server;
35    
36            print "Server $0 ready at $server_url\n";
37    
38            sub static {
39                    my ($client,$path) = @_;
40    
41                    $path = "www/$path";
42                    $path .= 'rfid.html' if $path =~ m{/$};
43    
44                    return unless -e $path;
45    
46                    my $type = 'text/plain';
47                    $type = 'text/html' if $path =~ m{\.htm};
48                    $type = 'application/javascript' if $path =~ m{\.js};
49    
50                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                    open(my $html, $path);
52                    while(<$html>) {
53                            print $client $_;
54                    }
55                    close($html);
56    
57                    return $path;
58            }
59    
60            while (my $client = $server->accept()) {
61                    $client->autoflush(1);
62                    my $request = <$client>;
63    
64                    warn "WEB << $request\n" if $debug;
65    
66                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                            my $method = $1;
68                            my $param;
69                            if ( $method =~ s{\?(.+)}{} ) {
70                                    foreach my $p ( split(/[&;]/, $1) ) {
71                                            my ($n,$v) = split(/=/, $p, 2);
72                                            $param->{$n} = $v;
73                                    }
74                                    warn "WEB << param: ",dump( $param ) if $debug;
75                            }
76                            if ( my $path = static( $client,$1 ) ) {
77                                    warn "WEB >> $path" if $debug;
78                            } elsif ( $method =~ m{/scan} ) {
79                                    my $tags = scan_for_tags();
80                                    my $json = { time => time() };
81                                    map {
82                                            my $d = decode_tag($_);
83                                            $d->{sid} = $_;
84                                            $d->{security} = $tags_security->{$_};
85                                            push @{ $json->{tags} },  $d;
86                                    } keys %$tags;
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
88                                            $param->{callback}, "(", to_json($json), ")\r\n";
89                            } elsif ( $method =~ m{/program} ) {
90    
91                                    my $status = 501; # Not implementd
92    
93                                    foreach my $p ( keys %$param ) {
94                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
95                                            my $tag = $1;
96                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
97                                            $content = "\x00" if $param->{$p} eq 'blank';
98                                            $status = 302;
99    
100                                            warn "PROGRAM $tag $content\n";
101                                            write_tag( $tag, $content );
102                                            secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
103                                    }
104    
105                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
106    
107                            } elsif ( $method =~ m{/secure(.js)} ) {
108    
109                                    my $json = $1;
110    
111                                    my $status = 501; # Not implementd
112    
113                                    foreach my $p ( keys %$param ) {
114                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
115                                            my $tag = $1;
116                                            my $data = $param->{$p};
117                                            $status = 302;
118    
119                                            warn "SECURE $tag $data\n";
120                                            secure_tag_with( $tag, $data );
121                                    }
122    
123                                    if ( $json ) {
124                                            print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
125                                                    $param->{callback}, "({ ok: 1 })\r\n";
126                                    } else {
127                                            print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
128                                    }
129    
130          if ( ! defined $meteor_fh ) {                          } else {
131                  warn "# open connection to $meteor_server";                                  print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
132                  $meteor_fh = IO::Socket::INET->new(                          }
133                                  PeerAddr => $meteor_server,                  } else {
134                                  Timeout => 1,                          print $client "HTTP/1.0 500 No method\r\n\r\n";
135                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                  }
136                  $meteor_fh = 0; # don't try again                  close $client;
137          }          }
138    
139          warn ">> meteor ",dump( @a );          die "server died";
         print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;  
140  }  }
141    
142  my $debug = 0;  
143    my $last_message = {};
144    sub _message {
145            my $type = shift @_;
146            my $text = join(' ',@_);
147            my $last = $last_message->{$type};
148            if ( $text ne $last ) {
149                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
150                    $last_message->{$type} = $text;
151            }
152    }
153    
154    sub _log { _message('log',@_) };
155    sub diag { _message('diag',@_) };
156    
157  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
158  my $baudrate  = "19200";  my $baudrate  = "38400";
159  my $databits  = "8";  my $databits  = "8";
160  my $parity        = "none";  my $parity        = "even";
161  my $stopbits  = "1";  my $stopbits  = "1";
162  my $handshake = "none";  my $handshake = "none";
163    
164  my $program_path = './program/';  my $program_path = './program/';
165  my $secure_path = './secure/';  my $secure_path = './secure/';
166    
167    # http server
168    my $http_server = 1;
169    
170    # 3M defaults: 8,4
171    # cards 16, stickers: 8
172    my $max_rfid_block = 8;
173    my $read_blocks = 8;
174    
175  my $response = {  my $response = {
176          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
177          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 63  GetOptions( Line 192  GetOptions(
192          'parity=s'    => \$parity,          'parity=s'    => \$parity,
193          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
194          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
195          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
196  ) or die $!;  ) or die $!;
197    
198  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 99  it under the same terms ans Perl itself. Line 228  it under the same terms ans Perl itself.
228    
229  =cut  =cut
230    
 my $tags_data;  
 my $visible_tags;  
   
231  my $item_type = {  my $item_type = {
232          1 => 'Book',          1 => 'Book',
233          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 127  $databits=$port->databits($databits); Line 253  $databits=$port->databits($databits);
253  $parity=$port->parity($parity);  $parity=$port->parity($parity);
254  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
255    
256  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
257    
258  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
259  $port->lookclear();  $port->lookclear();
# Line 138  $port->read_char_time(5); Line 264  $port->read_char_time(5);
264  #$port->stty_inpck(1);  #$port->stty_inpck(1);
265  #$port->stty_istrip(1);  #$port->stty_istrip(1);
266    
267    sub cpr_m02_checksum {
268            my $data = shift;
269    
270            my $preset = 0xffff;
271            my $polynom = 0x8408;
272    
273            my $crc = $preset;
274            foreach my $i ( 0 .. length($data) - 1 ) {
275                    $crc ^= ord(substr($data,$i,1));
276                    for my $j ( 0 .. 7 ) {
277                            if ( $crc & 0x0001 ) {
278                                    $crc = ( $crc >> 1 ) ^ $polynom;
279                            } else {
280                                    $crc = $crc >> 1;
281                            }
282                    }
283                    warn sprintf('%d %04x', $i, $crc & 0xffff);
284            }
285    
286            return pack('v', $crc);
287    }
288    
289    sub cpr {
290            my $hex = shift;
291            my $bytes = str2bytes($hex);
292            my $len = pack( 'c', length( $bytes ) + 3 );
293            my $send = $len . $bytes;
294            my $checksum = cpr_m02_checksum($send);
295            $send .= $checksum;
296    
297            warn ">> ", as_hex( $send );
298            writechunk( $send );
299            my $r_len = read_bytes( 1, 'response length' );
300            $r_len = ord($r_len) - 1;
301            my $data = read_bytes( $r_len, 'data' );
302            warn "<< ", as_hex( $data );
303    }
304    
305    cpr( '00  52 00' );
306    
307    exit;
308  # initial hand-shake with device  # initial hand-shake with device
309    
310  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
311       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
312          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
313          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
314  });  });
315    
316  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?',
317       '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() }  );
318    
319  # start scanning for tags  sub scan_for_tags {
320    
321  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 {  
322    
323                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
324                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
325                            my $rest = shift || die "no rest?";
326                            my $nr = ord( substr( $rest, 0, 1 ) );
327    
328                            if ( ! $nr ) {
329                                    _log "no tags in range\n";
330                                    update_visible_tags();
331                                    $tags_data = {};
332                            } else {
333    
334                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
335                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
336                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
337    
338                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
339                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
340                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
341    
342                          my @tags;                                  update_visible_tags( @tags );
343                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
344                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
345                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
346    
347                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
348            return $tags_data;
349    
350                          update_visible_tags( @tags );  }
                 }  
         }  
 ) while(1);  
 #) foreach ( 1 .. 100 );  
351    
352    # start scanning for tags
353    
354    if ( $http_server ) {
355            http_server;
356    } else {
357            while (1) {
358                    scan_for_tags;
359                    sleep 1;
360            }
361    }
362    
363    die "over and out";
364    
365  sub update_visible_tags {  sub update_visible_tags {
366          my @tags = @_;          my @tags = @_;
# Line 191  sub update_visible_tags { Line 369  sub update_visible_tags {
369          $visible_tags = {};          $visible_tags = {};
370    
371          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
372                    $visible_tags->{$tag}++;
373                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
374                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
375  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
376                          } else {                          } else {
                                 meteor( 'read', $tag );  
377                                  read_tag( $tag );                                  read_tag( $tag );
378                          }                          }
                         $visible_tags->{$tag}++;  
379                  } else {                  } else {
380                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
381                  }                  }
382                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
383    
384                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
385                                  write_tag( $tag );                                  write_tag( $tag );
386                  }                  }
387                  if ( -e "$secure_path/$tag" ) {                  if ( -e "$secure_path/$tag" ) {
                                 meteor( 'secure', $tag );  
388                                  secure_tag( $tag );                                  secure_tag( $tag );
389                  }                  }
390          }          }
391    
392          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
393                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
394                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
395          }          }
396    
397          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 402  my $tag_data_block;
402  sub read_tag_data {  sub read_tag_data {
403          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
404          die "no rest?" unless $rest;          die "no rest?" unless $rest;
405    
406            my $last_block = 0;
407    
408          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
409          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
410          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 237  sub read_tag_data { Line 414  sub read_tag_data {
414                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
415                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
416                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
417                  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;
418                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
419                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
420                  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;
421                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
422                    $last_block = $ord;
423          }          }
424          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
425    
426          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
427          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";
428    
429            return $last_block + 1;
430    }
431    
432    my $saved_in_log;
433    
434    sub decode_tag {
435            my $tag = shift;
436    
437            my $data = $tags_data->{$tag};
438            if ( ! $data ) {
439                    warn "no data for $tag\n";
440                    return;
441            }
442    
443            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
444            my $hash = {
445                    u1 => $u1,
446                    u2 => $u2,
447                    set => ( $set_item & 0xf0 ) >> 4,
448                    total => ( $set_item & 0x0f ),
449    
450                    type => $type,
451                    content => $content,
452    
453                    branch => $br_lib >> 20,
454                    library => $br_lib & 0x000fffff,
455    
456                    custom => $custom,
457            };
458    
459            if ( ! $saved_in_log->{$tag}++ ) {
460                    open(my $log, '>>', 'rfid-log.txt');
461                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
462                    close($log);
463            }
464    
465            return $hash;
466    }
467    
468    sub forget_tag {
469            my $tag = shift;
470            delete $tags_data->{$tag};
471            delete $visible_tags->{$tag};
472  }  }
473    
474  sub read_tag {  sub read_tag {
# Line 256  sub read_tag { Line 478  sub read_tag {
478    
479          print "read_tag $tag\n";          print "read_tag $tag\n";
480    
481          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, @_ );  
                 },  
         );  
482    
483          cmd(          while ( $start_block < $max_rfid_block ) {
484                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
485                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
486                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
487                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
488          );                          "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";
489                                    $start_block = read_tag_data( $start_block, @_ );
490                                    warn "# read tag upto $start_block\n";
491                            },
492                            "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
493                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
494                            },
495                            "D6 00 0D 02 06 $tag", sub {
496                                    my $rest = shift;
497                                    print "ERROR reading $tag ", as_hex($rest), $/;
498                                    forget_tag $tag;
499                                    $start_block = $max_rfid_block; # XXX break out of while
500                            },
501                    );
502    
503            }
504    
505          my $security;          my $security;
506    
507          cmd(          cmd(
508                  "D6 00 0B 0A $tag 1234", "check security $tag",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
509                  "D6 00 0D 0A 00", sub {                  "D6 00 0D 0A 00", sub {
510                          my $rest = shift;                          my $rest = shift;
511                          my $from_tag;                          my $from_tag;
512                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
513                          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 );
514                          $security = as_hex( $security );                          $security = as_hex( $security );
515                            $tags_security->{$tag} = $security;
516                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
517                  }                  },
518                    "D6 00 0C 0A 06", sub {
519                            my $rest = shift;
520                            warn "ERROR reading security from $rest\n";
521                            forget_tag $tag;
522                    },
523          );          );
524    
525          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";  
   
526  }  }
527    
528  sub write_tag {  sub write_tag {
529          my ($tag) = @_;          my ($tag,$data) = @_;
530    
531          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
532            $data = read_file( $path ) if -e $path;
533    
534            die "no data" unless $data;
535    
536            my $hex_data;
537    
538          my $data = read_file( $path );          if ( $data =~ s{^hex\s+}{} ) {
539                    $hex_data = $data;
540                    $hex_data =~ s{\s+}{}g;
541            } else {
542    
543                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
544    
545          $data = substr($data,0,16);                  my $max_len = $max_rfid_block * 4;
546    
547          my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) );                  if ( length($data) > $max_len ) {
548                            $data = substr($data,0,$max_len);
549                            warn "strip content to $max_len bytes\n";
550                    }
551    
552          print "write_tag $tag = $data ",dump( $hex_data );                  $hex_data = unpack('H*', $data);
553            }
554    
555            my $len = length($hex_data) / 2;
556            # pad to block size
557            $hex_data .= '00' x ( 4 - $len % 4 );
558            my $blocks = sprintf('%02x', length($hex_data) / 4);
559    
560            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
561    
562          cmd(          cmd(
563                  "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",
564                  "d6 00  0d  04 00  $tag  06  afb1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
565          ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
566    
567          my $to = $path;          my $to = $path;
568          $to .= '.' . time();          $to .= '.' . time();
# Line 321  sub write_tag { Line 570  sub write_tag {
570          rename $path, $to;          rename $path, $to;
571          print ">> $to\n";          print ">> $to\n";
572    
573          delete $tags_data->{$tag};      # force re-read of tag          forget_tag $tag;
574    }
575    
576    sub secure_tag_with {
577            my ( $tag, $data ) = @_;
578    
579            cmd(
580                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
581                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
582            );
583    
584            forget_tag $tag;
585  }  }
586    
587  sub secure_tag {  sub secure_tag {
# Line 330  sub secure_tag { Line 590  sub secure_tag {
590          my $path = "$secure_path/$tag";          my $path = "$secure_path/$tag";
591          my $data = substr(read_file( $path ),0,2);          my $data = substr(read_file( $path ),0,2);
592    
593          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() },  
         );  
594    
595          my $to = $path;          my $to = $path;
596          $to .= '.' . time();          $to .= '.' . time();
# Line 374  sub writechunk Line 631  sub writechunk
631  {  {
632          my $str=shift;          my $str=shift;
633          my $count = $port->write($str);          my $count = $port->write($str);
634            my $len = length($str);
635            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
636          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
637  }  }
638    
639  sub as_hex {  sub as_hex {
640          my @out;          my @out;
641          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
642                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
643                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
644                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
645                  push @out, $hex;                  push @out, $hex;
# Line 394  sub read_bytes { Line 653  sub read_bytes {
653          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
654                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
655                  die "no bytes on port: $!" unless defined $b;                  die "no bytes on port: $!" unless defined $b;
656                  #warn "## got $c bytes: ", as_hex($b), "\n";                  warn "## got $c bytes: ", as_hex($b), "\n";
657                  $data .= $b;                  $data .= $b;
658          }          }
659          $desc ||= '?';          $desc ||= '?';
# Line 440  sub crcccitt { Line 699  sub crcccitt {
699  sub checksum {  sub checksum {
700          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
701    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
702          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
703          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
704    
705          if ( $len_real != $len ) {          if ( $len_real != $len ) {
706                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
707                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
708          }          }
709    
710            my $xor = crcccitt( substr($bytes,1) ); # skip D6
711            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
712    
713          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
714                  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";
715                  return $bytes . $xor;                  return $bytes . $xor;
716          }          }
717          return $bytes . $checksum;          return $bytes . $checksum;
# Line 461  sub checksum { Line 720  sub checksum {
720  our $dispatch;  our $dispatch;
721    
722  sub readchunk {  sub readchunk {
723          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
724    
725          # read header of packet          # read header of packet
726          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 490  sub readchunk { Line 749  sub readchunk {
749          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
750    
751          if ( defined $to ) {          if ( defined $to ) {
752                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
753                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
754                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
755          } else {          } else {
756                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
757          }          }
758    
759          return $data;          return $data;
Legend:
Removed from v.34  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.26