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