lib/RFID/Serial/3M810.pm

   1 package RFID::Serial::3M810;
   2
   3 use base 'RFID::Serial';
   4 use RFID::Serial;
   5
   6 use Data::Dump qw(dump);
   7 use Carp qw(confess);
   8 use Time::HiRes;
   9 use Digest::CRC;
  10
  11 sub serial_settings {{
  12         device    => "/dev/ttyUSB1", # FIXME comment out before shipping
  13         baudrate  => "19200",
  14         databits  => "8",
  15         parity    => "none",
  16         stopbits  => "1",
  17         handshake => "none",
  18 }}
  19
  20 my $port;
  21 sub init {
  22         my $self = shift;
  23         $port = $self->port;
  24
  25         # drain on startup
  26         my ( $count, $str ) = $port->read(3);
  27         my $data = $port->read( ord(substr($str,2,1)) );
  28         warn "drain ",as_hex( $str, $data ),"\n";
  29
  30         setup();
  31
  32 }
  33
  34 sub checksum {
  35         my $bytes = shift;
  36         my $crc = Digest::CRC->new(
  37                 # midified CCITT to xor with 0xffff instead of 0x0000
  38                 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
  39         ) or die $!;
  40         $crc->add( $bytes );
  41         pack('n', $crc->digest);
  42 }
  43
  44 sub wait_device {
  45         Time::HiRes::sleep 0.015;
  46 }
  47
  48 sub cmd {
  49         my ( $hex, $description, $coderef ) = @_;
  50         my $bytes = hex2bytes($hex);
  51         if ( substr($bytes,0,1) !~ /(\xD5|\xD6)/ ) {
  52                 my $len = pack( 'n', length( $bytes ) + 2 );
  53                 $bytes = $len . $bytes;
  54                 my $checksum = checksum($bytes);
  55                 $bytes = "\xD6" . $bytes . $checksum;
  56         }
  57
  58         warn ">> ", as_hex( $bytes ), "\t\t[$description]\n";
  59         $port->write( $bytes );
  60
  61         wait_device;
  62
  63         my $r_len = $port->read(3);
  64
  65         while ( ! $r_len ) {
  66                 wait_device;
  67                 $r_len = $port->read(3);
  68         }
  69
  70         # FIXME sometimes, reader returns left-over junk
  71         if ( ! ord(substr($r_len,0,1)) && 0xD0 ) {
  72                 warn "INVALID reponse ",as_hex($r_len);
  73                 my $c;
  74                 while ( $c ne "\xD6" ) {
  75                         $c = $port->read(1) || return;
  76                         warn "# c ",as_hex($c);
  77                 }
  78                 $r_len = $c . $port->read(2);
  79                 warn "FIXED ",as_hex($r_len);
  80         }
  81
  82         wait_device;
  83
  84         my $len = ord( substr($r_len,2,1) );
  85         $data = $port->read( $len );
  86         warn "<< ", as_hex($r_len,$data)," $len\n";
  87
  88         $coderef->( $data ) if $coderef;
  89
  90 }
  91
  92 sub assert {
  93         my ( $got, $expected ) = @_;
  94         $expected = hex2bytes($expected);
  95
  96         my $len = length($got);
  97         $len = length($expected) if length $expected < $len;
  98
  99         confess "got ", as_hex($got), " expected ", as_hex($expected)
 100         unless substr($got,0,$len) eq substr($expected,0,$len);
 101
 102         return substr($got,$len);
 103 }
 104
 105 sub setup {
 106
 107 cmd(
 108 'D5 00  05   04 00 11   8C66', 'hw version', sub {
 109         my $data = shift;
 110         my $rest = assert $data => '04 00 11';
 111         my $hw_ver = join('.', unpack('CCCC', $rest));
 112         warn "# 3M 810 hardware version $hw_ver\n";
 113 });
 114
 115 cmd(
 116 '13  04 01 00 02 00 03 00 04 00','FIXME: stats? rf-on?', sub { assert(shift,
 117 '13  00 02 01 01 03 02 02 03 00'
 118 )});
 119 }
 120
 121 =head2 inventory
 122
 123   my @tags = inventory;
 124
 125 =cut
 126
 127 sub inventory {
 128
 129         my @tags;
 130
 131 cmd( 'FE  00 05', 'scan for tags', sub {
 132         my $data = shift;
 133         my $rest = assert $data => 'FE 00 00 05';
 134         my $nr = ord( substr( $rest, 0, 1 ) );
 135
 136         if ( ! $nr ) {
 137                 warn "# no tags in range\n";
 138         } else {
 139                 my $tags = substr( $rest, 1 );
 140                 my $tl = length( $tags );
 141                 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
 142
 143                 foreach ( 0 .. $nr - 1 ) {
 144                         push @tags, hex_tag substr($tags, $_ * 8, 8);
 145                 }
 146         }
 147
 148 });
 149
 150         warn "# tags ",dump @tags;
 151         return @tags;
 152 }
 153
 154
 155 # 3M defaults: 8,4
 156 # cards 16, stickers: 8
 157 my $max_rfid_block = 8;
 158 my $blocks = 8;
 159
 160 sub _matched {
 161         my ( $data, $hex ) = @_;
 162         my $b = hex2bytes $hex;
 163         my $l = length($b);
 164         if ( substr($data,0,$l) eq $b ) {
 165                 warn "_matched $hex [$l] in ",as_hex($data);
 166                 return substr($data,$l);
 167         }
 168 }
 169
 170 sub read_blocks {
 171         my $tag = shift || confess "no tag?";
 172         $tag = shift if ref($tag);
 173
 174         my $tag_blocks;
 175         my $start = 0;
 176         cmd(
 177                  sprintf( "02 $tag %02x %02x", $start, $blocks ) => "read_blocks $tag $start/$blocks", sub {
 178                         my $data = shift;
 179                         if ( my $rest = _matched $data => '02 00' ) {
 180
 181                                 my $tag = hex_tag substr($rest,0,8);
 182                                 my $blocks = ord(substr($rest,8,1));
 183                                 warn "# response from $tag $blocks blocks ",as_hex substr($rest,9);
 184                                 foreach ( 1 .. $blocks ) {
 185                                         my $pos = ( $_ - 1 ) * 6 + 9;
 186                                         my $nr = unpack('v', substr($rest,$pos,2));
 187                                         my $payload = substr($rest,$pos+2,4);
 188                                         warn "## pos $pos block $nr ",as_hex($payload), $/;
 189                                         $tag_blocks->{$tag}->[$nr] = $payload;
 190                                 }
 191                         } elsif ( my $rest = _matched $data => 'FE 00 00 05 01' ) {
 192                                 warn "FIXME ready? ",as_hex $test;
 193                         } elsif ( my $rest = _matched $data => '02 06' ) {
 194                                 warn "ERROR ",as_hex($rest);
 195                         } else {
 196                                 warn "FIXME unsuported ",as_hex($rest);
 197                         }
 198         });
 199
 200         warn "# tag_blocks ",dump($tag_blocks);
 201         return $tag_blocks;
 202 }
 203
 204 1