/[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!

Diff of /3m-810.pl

Parent Directory | Revision Log | View Patch Patch

-revision 5 by dpavlin,
Sun Sep 28 18:13:21 2008 UTC
+revision 33 by dpavlin,
Wed Apr  8 14:48:22 2009 UTC
 Line 6 
 use warnings;
  use Data::Dump qw/dump/;
  use Carp qw/confess/;
+ use Getopt::Long;
+ use File::Slurp;
+ use IO::Socket::INET;
+ my $meteor_server = '192.168.1.13:4671';
+ my $meteor_fh;
+ sub meteor {
+         my @a = @_;
+         push @a, scalar localtime() if $a[0] =~ m{^info};
+         if ( ! defined $meteor_fh ) {
+                 warn "# open connection to $meteor_server";
+                 $meteor_fh = IO::Socket::INET->new(
+                                 PeerAddr => $meteor_server,
+                                 Timeout => 1,
+                 ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
+                 $meteor_fh = 0; # don't try again
+         }
+         warn ">> meteor ",dump( @a );
+         print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
+ }
  my $debug = 0;
+ my $device    = "/dev/ttyUSB0";
+ my $baudrate  = "19200";
+ my $databits  = "8";
+ my $parity        = "none";
+ my $stopbits  = "1";
+ my $handshake = "none";
+ my $program_path = './program/';
  my $response = {
          'd500090400110a0500027250'                              => 'version?',
          'd60007fe00000500c97b'                                  => 'no tag in range',
-Line 21 
 my $response = {
+Line 54 
 my $response = {
          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
  };
+ GetOptions(
+         'd|debug+'    => \$debug,
+         'device=s'    => \$device,
+         'baudrate=i'  => \$baudrate,
+         'databits=i'  => \$databits,
+         'parity=s'    => \$parity,
+         'stopbits=i'  => \$stopbits,
+         'handshake=s' => \$handshake,
+         'meteor=s'    => \$meteor_server,
+ ) or die $!;
+ my $verbose = $debug > 0 ? $debug-- : 0;
  =head1 NAME
 m-810 - support for 3M 810 RFID reader
  =head1 SYNOPSIS
-m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]
+m-810.pl --device /dev/ttyUSB0
  =head1 DESCRIPTION
-Line 39 
 L<Device::SerialPort(3)>
+Line 85 
 L<Device::SerialPort(3)>
  L<perl(1)>
+ L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
  =head1 AUTHOR
  Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
-Line 50 
 it under the same terms ans Perl itself.
+Line 98 
 it under the same terms ans Perl itself.
  =cut
- # your serial port.
+ my $tags_data;
- my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;
+ my $visible_tags;
- $device    ||= "/dev/ttyUSB0";
- $baudrate  ||= "19200";
+ my $item_type = {
- $databits  ||= "8";
+=> 'Book',
- $parity    ||= "none";
+=> 'CD/CD ROM',
- $stopbits  ||= "1";
+=> 'Magazine',
- $handshake ||= "none";
+=> 'Book with Audio Tape',
+=> 'Book with CD/CD ROM',
+=> 'Other',
+=> 'Video',
+=> 'Audio Tape',
+=> 'Bound Journal',
+=> 'Book with Diskette',
+=> 'Diskette',
+ };
+ warn "## known item type: ",dump( $item_type ) if $debug;
- my $port=new Device::SerialPort($device) || die "new($device): $!\n";
+ my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
+ warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
  $handshake=$port->handshake($handshake);
  $baudrate=$port->baudrate($baudrate);
  $databits=$port->databits($databits);
  $parity=$port->parity($parity);
  $stopbits=$port->stopbits($stopbits);
- print "## using $device $baudrate $databits $parity $stopbits\n";
+ print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
  # Just in case: reset our timing and buffers
  $port->lookclear();
-Line 79 
 $port->read_char_time(5);
+Line 139 
 $port->read_char_time(5);
  # initial hand-shake with device
- cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
+ cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
-      '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 {
-         print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
+         my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
+         print "hardware version $hw_ver\n";
+         meteor( 'info', "Found reader hardware $hw_ver" );
  });
- 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?',
-      '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() }  );
  # start scanning for tags
- cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
+ cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
-      '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(
+                 my $rest = shift || die "no rest?";
-          'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8
+                 my $nr = ord( substr( $rest, 0, 1 ) );
-                 sub {
-                         my $rest = shift || die "no rest?";
+                 if ( ! $nr ) {
-                         my $nr = ord( substr( $rest, 0, 1 ) );
+                         print "no tags in range\n";
+                         update_visible_tags();
+                         meteor( 'info-none-in-range' );
+                         $tags_data = {};
+                 } else {
                          my $tags = substr( $rest, 1 );
                          my $tl = length( $tags );
                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
                          my @tags;
-                         push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );
+                         push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
-                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags );
+                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
-                         print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";
+                         print "$nr tags in range: ", join(',', @tags ) , "\n";
+                         meteor( 'info-in-range', join(' ',@tags));
+                         update_visible_tags( @tags );
+                 }
+         }
+ ) while(1);
+ #) foreach ( 1 .. 100 );
+ sub update_visible_tags {
+         my @tags = @_;
+         my $last_visible_tags = $visible_tags;
+         $visible_tags = {};
+         foreach my $tag ( @tags ) {
+                 if ( ! defined $last_visible_tags->{$tag} ) {
+                         if ( defined $tags_data->{$tag} ) {
+ #                               meteor( 'in-range', $tag );
+                         } else {
+                                 meteor( 'read', $tag );
+                                 read_tag( $tag );
+                         }
+                         $visible_tags->{$tag}++;
+                 } else {
+                         warn "## using cached data for $tag" if $debug;
                  }
- ) }
+                 delete $last_visible_tags->{$tag}; # leave just missing tags
+                 if ( -e "$program_path/$tag" ) {
+                                 meteor( 'write', $tag );
+                                 write_tag( $tag );
+                 }
+         }
+         foreach my $tag ( keys %$last_visible_tags ) {
+                 my $data = delete $tags_data->{$tag};
+                 print "removed tag $tag with data ",dump( $data ),"\n";
+                 meteor( 'removed', $tag );
+         }
- ) foreach ( 1 .. 100 );
+         warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
+ }
- cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );
+ my $tag_data_block;
- #     D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4
+ sub read_tag_data {
- warn "D6 00  1F  02 00   E00401003123AA26   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
+         my ($start_block,$rest) = @_;
+         die "no rest?" unless $rest;
+         warn "## DATA [$start_block] ", dump( $rest ) if $debug;
+         my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
+         my $blocks = ord(substr($rest,8,1));
+         $rest = substr($rest,9); # leave just data blocks
+         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 ));
+                 my $expected_ord = $nr + $start_block;
+                 die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
+                 my $data  = substr( $block, 2 );
+                 die "data payload should be 4 bytes" if length($data) != 4;
+                 warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
+                 $tag_data_block->{$tag}->[ $ord ] = $data;
+         }
+         $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
+         my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
+         print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
+ }
- cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );
+ sub read_tag {
+         my ( $tag ) = @_;
+         confess "no tag?" unless $tag;
+         print "read_tag $tag\n";
+         cmd(
+                 "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, @_ );
+                 },
+         );
+         cmd(
+                 "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
+                 "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00
+                         read_tag_data( 3, @_ );
+                 }
+         );
- #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00
+         my $security;
- #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA
- warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36
+         cmd(
-00   00 00 00 00   06 00   00 00 00 00    524B\n";
+                 "D6 00 0B 0A $tag 1234", "check security $tag",
- warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";
+                 "D6 00 0D 0A 00", sub {
+                         my $rest = shift;
+                         my $from_tag;
+                         ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
+                         die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
+                         $security = as_hex( $security );
+                         warn "# SECURITY $tag = $security\n";
+                 }
+         );
+         my $data = $tags_data->{$tag} || die "no data for $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";
+ }
+ sub write_tag {
+         my ($tag) = @_;
+         my $path = "$program_path/$tag";
+         my $data = read_file( $path );
+         $data = substr($data,0,16);
+         my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
+         print "write_tag $tag = $data ",dump( $hex_data );
+         cmd(
+                 "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
+                 "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
+         ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
+         my $to = $path;
+         $to .= '.' . time();
+         rename $path, $to;
+         print ">> $to\n";
+         delete $tags_data->{$tag};      # force re-read of tag
+ }
+ exit;
  for ( 1 .. 3 ) {
-Line 153 
 sub writechunk
+Line 351 
 sub writechunk
  {
          my $str=shift;
          my $count = $port->write($str);
-         print ">> ", as_hex( $str ), "\t[$count]\n";
+         print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
  }
  sub as_hex {
-Line 161 
 sub as_hex {
+Line 359 
 sub as_hex {
          foreach my $str ( @_ ) {
                  my $hex = unpack( 'H*', $str );
                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
+                 $hex =~ s/\s+$//;
                  push @out, $hex;
          }
-         return join('  ', @out);
+         return join(' | ', @out);
  }
  sub read_bytes {
-Line 171 
 sub read_bytes {
+Line 370 
 sub read_bytes {
          my $data = '';
          while ( length( $data ) < $len ) {
                  my ( $c, $b ) = $port->read(1);
+                 die "no bytes on port: $!" unless defined $b;
                  #warn "## got $c bytes: ", as_hex($b), "\n";
                  $data .= $b;
          }
-Line 200 
 sub assert {
+Line 400 
 sub assert {
          return substr( $assert->{payload}, $to );
  }
- our $dispatch;
+ use Digest::CRC;
- sub dispatch {
-         my ( $pattern, $coderef ) = @_;
+ sub crcccitt {
-         my $patt = substr( str2bytes($pattern), 3 ); # just payload
+         my $bytes = shift;
-         my $l = length($patt);
+         my $crc = Digest::CRC->new(
-         my $p = substr( $assert->{payload}, 0, $l );
+                 # midified CCITT to xor with 0xffff instead of 0x0000
-         warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p );
+                 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
+         ) or die $!;
-         if ( $assert->{payload} eq $assert->{expect} ) {
+         $crc->add( $bytes );
-                 warn "## no dispatch, payload expected\n";
+         pack('n', $crc->digest);
-         } elsif ( $p eq $patt ) {
+ }
-                 # if matched call with rest of payload
-                 $coderef->( substr( $assert->{payload}, $l ) );
+ # my $checksum = checksum( $bytes );
-         } else {
+ # my $checksum = checksum( $bytes, $original_checksum );
-                 warn "## dispatch ignored\n";
+ sub checksum {
+         my ( $bytes, $checksum ) = @_;
+         my $xor = crcccitt( substr($bytes,1) ); # skip D6
+         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
+         my $len = ord(substr($bytes,2,1));
+         my $len_real = length($bytes) - 1;
+         if ( $len_real != $len ) {
+                 print "length wrong: $len_real != $len\n";
+                 $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
          }
+         if ( defined $checksum && $xor ne $checksum ) {
+                 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
+                 return $bytes . $xor;
+         }
+         return $bytes . $checksum;
  }
- sub readchunk {
+ our $dispatch;
-         my ( $parser ) = @_;
+ sub readchunk {
          sleep 1;        # FIXME remove
          # read header of packet
-Line 228 
 sub readchunk {
+Line 445 
 sub readchunk {
          my $length = read_bytes( 1, 'length' );
          my $len = ord($length);
          my $data = read_bytes( $len, 'data' );
-         my ( $cmd ) = unpack('C', $data );
          my $payload  = substr( $data, 0, -2 );
          my $payload_len = length($data);
          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
          my $checksum = substr( $data, -2, 2 );
-         # FIXME check checksum
+         checksum( $header . $length . $payload , $checksum );
-         print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n";
+         print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
          $assert->{len}      = $len;
          $assert->{payload}  = $payload;
-         $assert->{checksum} = $checksum;
-         $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';
+         my $full = $header . $length . $data; # full
+         # find longest match for incomming data
+         my ($to) = grep {
+                 my $match = substr($payload,0,length($_));
+                 m/^\Q$match\E/
+         } sort { length($a) <=> length($b) } keys %$dispatch;
+         warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
+         if ( defined $to ) {
+                 my $rest = substr( $payload, length($to) );
+                 warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
+                 $dispatch->{ $to }->( $rest );
+         } else {
+                 print "NO DISPATCH for ",dump( $full ),"\n";
+         }
          return $data;
  }
-Line 250 
 sub readchunk {
+Line 480 
 sub readchunk {
  sub str2bytes {
          my $str = shift || confess "no str?";
          my $b = $str;
-         $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum
+         $b =~ s/\s+//g;
-         $b =~ s/\s+$//;
+         $b =~ s/(..)/\\x$1/g;
-         $b =~ s/\s+/\\x/g;
+         $b = "\"$b\"";
-         $b = '"\x' . $b . '"';
          my $bytes = eval $b;
          die $@ if $@;
          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
-Line 261 
 sub str2bytes {
+Line 490 
 sub str2bytes {
  }
  sub cmd {
-         my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
+         my $cmd = shift || confess "no cmd?";
+         my $cmd_desc = shift || confess "no description?";
+         my @expect = @_;
          my $bytes = str2bytes( $cmd );
-         warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
+         # fix checksum if needed
+         $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
+         warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
          $assert->{send} = $cmd;
          writechunk( $bytes );
-         if ( $expect ) {
+         while ( @expect ) {
-                 warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
+                 my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
-                 $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
+                 my $coderef = shift @expect || confess "no coderef?";
-                 readchunk( $coderef );
+                 confess "not coderef" unless ref $coderef eq 'CODE';
+                 next if defined $dispatch->{ $pattern };
+                 $dispatch->{ substr($pattern,3) } = $coderef;
+                 warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
          }
+         readchunk;
  }

 Legend:



Removed from v.5
 


changed lines


 
Added in v.33
 Legend:



Removed from v.5
 


changed lines


 
Added in v.33
-Removed from v.5
+Added in v.33

	ViewVC Help
Powered by ViewVC 1.1.26