/[RFID]/3m-810.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 /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 27 by dpavlin, Mon Apr 6 11:21:15 2009 UTC revision 43 by dpavlin, Tue Jun 23 12:19:30 2009 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    
12  use IO::Socket::INET;  use IO::Socket::INET;
13    
# Line 18  sub meteor { Line 19  sub meteor {
19          push @a, scalar localtime() if $a[0] =~ m{^info};          push @a, scalar localtime() if $a[0] =~ m{^info};
20    
21          if ( ! defined $meteor_fh ) {          if ( ! defined $meteor_fh ) {
22                  warn "# open connection to $meteor_server";                  if ( $meteor_fh =
23                  $meteor_fh = IO::Socket::INET->new(                                  IO::Socket::INET->new(
24                                  PeerAddr => $meteor_server,                                          PeerAddr => $meteor_server,
25                                  Timeout => 1,                                          Timeout => 1,
26                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                                  )
27                  $meteor_fh = 0; # don't try again                  ) {
28                            warn "# meteor connected to $meteor_server";
29                    } else {
30                            warn "can't connect to meteor $meteor_server: $!";
31                            $meteor_fh = 0;
32                    }
33          }          }
34    
35          warn ">> meteor ",dump( @a );          if ( $meteor_fh ) {
36          print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;                  warn ">> meteor ",dump( @a );
37                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
38            }
39    }
40    
41    my $listen_port = 9000;                  # pick something not in use
42    sub http_server {
43    
44            my $server = IO::Socket::INET->new(
45                    Proto     => 'tcp',
46                    LocalPort => $listen_port,
47                    Listen    => SOMAXCONN,
48                    Reuse     => 1
49            );
50                                                                      
51            die "can't setup server" unless $server;
52    
53            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
54    
55            sub static {
56                    my ($client,$path) = @_;
57    
58                    $path = "www/$path";
59    
60                    return unless -e $path;
61    
62                    my $type = 'text/plain';
63                    $type = 'text/html' if $path =~ m{\.htm};
64                    $type = 'application/javascript' if $path =~ m{\.js};
65    
66                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
67                    open(my $html, $path);
68                    while(<$html>) {
69                            print $client $_;
70                    }
71                    close($html);
72    
73                    return $path;
74            }
75    
76            while (my $client = $server->accept()) {
77                    $client->autoflush(1);
78                    my $request = <$client>;
79    
80                    warn "<< $request\n";
81    
82                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
83                            my $method = $1;
84                            if ( my $path = static( $client,$1 ) ) {
85                                    warn ">> $path";
86                            } elsif ( $method =~ m{/scan} ) {
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\n";
88                                    my $tags = scan_for_tags();
89                                    print $client "tags: ",dump($tags);
90                                    my $json;
91                                    map { $json->{$_} = decode_tag($_) } keys %$tags;
92                                    print $client "decoded: ",dump( $json );
93                            } else {
94                                    print $client "HTTP/1.0 404 Unkown method\r\n";
95                            }
96                    } else {
97                            print $client "HTTP/1.0 500 No method\r\n";
98                    }
99                    close $client;
100            }
101    
102            die "server died";
103  }  }
104    
105  my $debug = 0;  my $debug = 0;
# Line 39  my $parity       = "none"; Line 111  my $parity       = "none";
111  my $stopbits  = "1";  my $stopbits  = "1";
112  my $handshake = "none";  my $handshake = "none";
113    
114    my $program_path = './program/';
115    my $secure_path = './secure/';
116    
117    # http server
118    my $http_server = 1;
119    
120    # 3M defaults: 8,4
121    my $max_rfid_block = 16;
122    my $read_blocks = 8;
123    
124  my $response = {  my $response = {
125          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
126          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 98  it under the same terms ans Perl itself. Line 180  it under the same terms ans Perl itself.
180  my $tags_data;  my $tags_data;
181  my $visible_tags;  my $visible_tags;
182    
183    my $item_type = {
184            1 => 'Book',
185            6 => 'CD/CD ROM',
186            2 => 'Magazine',
187            13 => 'Book with Audio Tape',
188            9 => 'Book with CD/CD ROM',
189            0 => 'Other',
190    
191            5 => 'Video',
192            4 => 'Audio Tape',
193            3 => 'Bound Journal',
194            8 => 'Book with Diskette',
195            7 => 'Diskette',
196    };
197    
198    warn "## known item type: ",dump( $item_type ) if $debug;
199    
200  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";
201  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
202  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 129  cmd( 'D5 00  05   04 00 11 Line 228  cmd( 'D5 00  05   04 00 11
228  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?',
229       '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() }  );
230    
231  # start scanning for tags  sub scan_for_tags {
232    
233  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 {  
234    
235                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
236                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
237                            my $rest = shift || die "no rest?";
238                            my $nr = ord( substr( $rest, 0, 1 ) );
239    
240                          my $tl = length( $tags );                          if ( ! $nr ) {
241                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  print "no tags in range\n";
242                                    update_visible_tags();
243                                    meteor( 'info-none-in-range' );
244                                    $tags_data = {};
245                            } else {
246    
247                                    my $tags = substr( $rest, 1 );
248    
249                                    my $tl = length( $tags );
250                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
251    
252                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
253                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
254                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  print "$nr tags in range: ", join(',', @tags ) , "\n";
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
255    
256                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
257    
258                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
259                            }
260                  }                  }
261          }          );
 ) while(1);  
 #) foreach ( 1 .. 100 );  
262    
263            warn "## tags: ",dump( @tags );
264            return $tags_data;
265    
266    }
267    
268    # start scanning for tags
269    
270    if ( $http_server ) {
271            http_server;
272    } else {
273            scan_for_tags while 1;
274    }
275    
276    die "over and out";
277    
278  sub update_visible_tags {  sub update_visible_tags {
279          my @tags = @_;          my @tags = @_;
# Line 182  sub update_visible_tags { Line 294  sub update_visible_tags {
294                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
295                  }                  }
296                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
297    
298                    if ( -e "$program_path/$tag" ) {
299                                    meteor( 'write', $tag );
300                                    write_tag( $tag );
301                    }
302                    if ( -e "$secure_path/$tag" ) {
303                                    meteor( 'secure', $tag );
304                                    secure_tag( $tag );
305                    }
306          }          }
307    
308          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
# Line 193  sub update_visible_tags { Line 314  sub update_visible_tags {
314          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;
315  }  }
316    
317    my $tag_data_block;
318    
319    sub read_tag_data {
320            my ($start_block,$rest) = @_;
321            die "no rest?" unless $rest;
322    
323            my $last_block = 0;
324    
325            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
326            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
327            my $blocks = ord(substr($rest,8,1));
328            $rest = substr($rest,9); # leave just data blocks
329            foreach my $nr ( 0 .. $blocks - 1 ) {
330                    my $block = substr( $rest, $nr * 6, 6 );
331                    warn "## block ",as_hex( $block ) if $debug;
332                    my $ord   = unpack('v',substr( $block, 0, 2 ));
333                    my $expected_ord = $nr + $start_block;
334                    warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
335                    my $data  = substr( $block, 2 );
336                    die "data payload should be 4 bytes" if length($data) != 4;
337                    warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
338                    $tag_data_block->{$tag}->[ $ord ] = $data;
339                    $last_block = $ord;
340            }
341            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
342    
343            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
344            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
345    
346            return $last_block + 1;
347    }
348    
349    sub decode_tag {
350            my $tag = shift;
351    
352            my $data = $tags_data->{$tag} || die "no data for $tag";
353    
354            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
355            my $hash = {
356                    u1 => $u1,
357                    u2 => $u2,
358                    set => ( $set_item & 0xf0 ) >> 4,
359                    total => ( $set_item & 0x0f ),
360    
361                    type => $type,
362                    content => $content,
363    
364                    branch => $br_lib >> 20,
365                    library => $br_lib & 0x000fffff,
366    
367                    custom => $custom,
368            };
369    
370            return $hash;
371    }
372    
373  sub read_tag {  sub read_tag {
374          my ( $tag ) = @_;          my ( $tag ) = @_;
# Line 201  sub read_tag { Line 377  sub read_tag {
377    
378          print "read_tag $tag\n";          print "read_tag $tag\n";
379    
380            my $start_block = 0;
381    
382            while ( $start_block < $max_rfid_block ) {
383    
384                    cmd(
385                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
386                                    "read $tag offset: $start_block blocks: $read_blocks",
387                            "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";
388                                    $start_block = read_tag_data( $start_block, @_ );
389                                    warn "# read tag upto $start_block\n";
390                            },
391                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
392                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
393                            },
394                    );
395    
396            }
397    
398            my $security;
399    
400          cmd(          cmd(
401                  "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',                  "D6 00 0B 0A $tag 1234", "check security $tag",
402                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
403                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
404                  },                          my $from_tag;
405                  "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";                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
406                          my $rest = shift || die "no rest?";                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
407                          warn "## DATA ", dump( $rest ) if $debug;                          $security = as_hex( $security );
408                          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));                          warn "# SECURITY $tag = $security\n";
                         my $blocks = ord(substr($rest,8,1));  
                         $rest = substr($rest,9); # leave just data blocks  
                         my @data;  
                         foreach my $nr ( 0 .. $blocks - 1 ) {  
                                 my $block = substr( $rest, $nr * 6, 6 );  
                                 warn "## block ",as_hex( $block ) if $debug;  
                                 my $ord   = unpack('v',substr( $block, 0, 2 ));  
                                 die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;  
                                 my $data  = substr( $block, 2 );  
                                 die "data payload should be 4 bytes" if length($data) != 4;  
                                 warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;  
                                 $data[ $ord ] = $data;  
                         }  
                         $tags_data->{ $tag } = join('', @data);  
                         print "DATA $tag ",dump( $tags_data ), "\n";  
409                  }                  }
410          );          );
411    
412          #        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          print "TAG $tag ", dump(decode_tag( $tag ));
 if (0) {  
         cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );  
   
         #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
         #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
         warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";  
413  }  }
         warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";  
414    
415    sub write_tag {
416            my ($tag) = @_;
417    
418            my $path = "$program_path/$tag";
419    
420            my $data = read_file( $path );
421            my $hex_data;
422    
423            if ( $data =~ s{^hex\s+}{} ) {
424                    $hex_data = $data;
425                    $hex_data =~ s{\s+}{}g;
426            } else {
427    
428                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
429    
430                    my $max_len = $max_rfid_block * 4;
431    
432                    if ( length($data) > $max_len ) {
433                            $data = substr($data,0,$max_len);
434                            warn "strip content to $max_len bytes\n";
435                    }
436    
437                    $hex_data = unpack('H*', $data);
438            }
439    
440            my $len = length($hex_data) / 2;
441            # pad to block size
442            $hex_data .= '00' x ( 4 - $len % 4 );
443            my $blocks = sprintf('%02x', length($hex_data) / 4);
444    
445            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
446    
447            cmd(
448                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
449                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
450            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
451    
452            my $to = $path;
453            $to .= '.' . time();
454    
455            rename $path, $to;
456            print ">> $to\n";
457    
458            delete $tags_data->{$tag};      # force re-read of tag
459    }
460    
461    sub secure_tag {
462            my ($tag) = @_;
463    
464            my $path = "$secure_path/$tag";
465            my $data = substr(read_file( $path ),0,2);
466    
467            cmd(
468                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
469                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
470            );
471    
472            my $to = $path;
473            $to .= '.' . time();
474    
475            rename $path, $to;
476            print ">> $to\n";
477  }  }
478    
479  exit;  exit;
# Line 272  sub writechunk Line 508  sub writechunk
508  {  {
509          my $str=shift;          my $str=shift;
510          my $count = $port->write($str);          my $count = $port->write($str);
511            my $len = length($str);
512            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
513          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
514  }  }
515    
# Line 291  sub read_bytes { Line 529  sub read_bytes {
529          my $data = '';          my $data = '';
530          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
531                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
532                    die "no bytes on port: $!" unless defined $b;
533                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
534                  $data .= $b;                  $data .= $b;
535          }          }
# Line 337  sub crcccitt { Line 576  sub crcccitt {
576  sub checksum {  sub checksum {
577          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
578    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
579          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
580          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
581    
582          if ( $len_real != $len ) {          if ( $len_real != $len ) {
583                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
584                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
585          }          }
586    
587            my $xor = crcccitt( substr($bytes,1) ); # skip D6
588            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
589    
590          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
591                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
592                  return $bytes . $xor;                  return $bytes . $xor;
# Line 358  sub checksum { Line 597  sub checksum {
597  our $dispatch;  our $dispatch;
598    
599  sub readchunk {  sub readchunk {
600          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
601    
602          # read header of packet          # read header of packet
603          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 387  sub readchunk { Line 626  sub readchunk {
626          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
627    
628          if ( defined $to ) {          if ( defined $to ) {
629                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
630                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
631                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
632          } else {          } else {
Legend:
Removed from v.27  
changed lines
  Added in v.43
  ViewVC Help
Powered by ViewVC 1.1.26