lib/RFID/Biblio/3M810.pm

   1 package RFID::Biblio::3M810;
   2
   3 use warnings;
   4 use strict;
   5
   6 use base 'RFID::Biblio';
   7 use RFID::Biblio;
   8
   9 use Data::Dump qw(dump);
  10 use Carp qw(confess);
  11 use Time::HiRes;
  12 use Digest::CRC;
  13
  14 sub serial_settings {{
  15         device    => "/dev/ttyUSB1", # FIXME comment out before shipping
  16         baudrate  => "19200",
  17         databits  => "8",
  18         parity    => "none",
  19         stopbits  => "1",
  20         handshake => "none",
  21 }}
  22
  23 my $port;
  24 sub init {
  25         my $self = shift;
  26         $port = $self->port;
  27
  28         # drain on startup
  29         my ( $count, $str ) = $port->read(3);
  30         my $data = $port->read( ord(substr($str,2,1)) );
  31         warn "drain ",as_hex( $str, $data ),"\n";
  32
  33         setup();
  34
  35 }
  36
  37 sub checksum {
  38         my $bytes = shift;
  39         my $crc = Digest::CRC->new(
  40                 # midified CCITT to xor with 0xffff instead of 0x0000
  41                 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
  42         ) or die $!;
  43         $crc->add( $bytes );
  44         pack('n', $crc->digest);
  45 }
  46
  47 sub wait_device {
  48         Time::HiRes::sleep 0.015;
  49 }
  50
  51 sub cmd {
  52         my ( $hex, $description, $coderef ) = @_;
  53         my $bytes = hex2bytes($hex);
  54         if ( substr($bytes,0,1) !~ /(\xD5|\xD6)/ ) {
  55                 my $len = pack( 'n', length( $bytes ) + 2 );
  56                 $bytes = $len . $bytes;
  57                 my $checksum = checksum($bytes);
  58                 $bytes = "\xD6" . $bytes . $checksum;
  59         }
  60
  61         warn ">> ", as_hex( $bytes ), "\t\t[$description]\n";
  62         $port->write( $bytes );
  63
  64         wait_device;
  65
  66         my $r_len = $port->read(3);
  67
  68         while ( length($r_len) < 3 ) {
  69                 wait_device;
  70                 $r_len = $port->read( 3 - length($r_len) );
  71         }
  72
  73         wait_device;
  74
  75         my $len = ord( substr($r_len,2,1) );
  76         my $data = $port->read( $len );
  77
  78         while ( length($data) < $len ) {
  79                 warn "# short read ", length($data), " < $len\n";
  80                 wait_device;
  81                 $data .= $port->read( $len - length($data) );
  82         }
  83
  84         warn "<< ", as_hex($r_len,$data),
  85                 ' | ',
  86                 substr($data,-2,2) eq checksum(substr($r_len,1).substr($data,0,-2)) ? 'OK' : 'ERROR',
  87                 " $len bytes\n";
  88
  89
  90         $coderef->( $data ) if $coderef;
  91
  92 }
  93
  94 sub assert {
  95         my ( $got, $expected ) = @_;
  96         $expected = hex2bytes($expected);
  97
  98         my $len = length($got);
  99         $len = length($expected) if length $expected < $len;
 100
 101         confess "got ", as_hex($got), " expected ", as_hex($expected)
 102         unless substr($got,0,$len) eq substr($expected,0,$len);
 103
 104         return substr($got,$len);
 105 }
 106
 107 sub setup {
 108
 109 cmd(
 110 'D5 00  05   04 00 11   8C66', 'hw version', sub {
 111         my $data = shift;
 112         my $rest = assert $data => '04 00 11';
 113         my $hw_ver = join('.', unpack('CCCC', $rest));
 114         warn "# 3M 810 hardware version $hw_ver\n";
 115 });
 116
 117 cmd(
 118 '13  04 01 00 02 00 03 00 04 00','FIXME: stats? rf-on?', sub { assert(shift,
 119 '13  00 02 01 01 03 02 02 03 00'
 120 )});
 121 }
 122
 123 =head2 inventory
 124
 125   my @tags = inventory;
 126
 127 =cut
 128
 129 sub inventory {
 130
 131         my @tags;
 132
 133 cmd( 'FE  00 05', 'scan for tags', sub {
 134         my $data = shift;
 135         my $rest = assert $data => 'FE 00 00 05';
 136         my $nr = ord( substr( $rest, 0, 1 ) );
 137
 138         if ( ! $nr ) {
 139                 warn "# no tags in range\n";
 140         } else {
 141                 my $tags = substr( $rest, 1 );
 142                 my $tl = length( $tags );
 143                 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
 144
 145                 foreach ( 0 .. $nr - 1 ) {
 146                         push @tags, hex_tag substr($tags, $_ * 8, 8);
 147                 }
 148         }
 149
 150 });
 151
 152         warn "# tags ",dump @tags;
 153         return @tags;
 154 }
 155
 156
 157 # 3M defaults: 8,4
 158 # cards 16, stickers: 8
 159 my $max_rfid_block = 8;
 160 my $blocks = 8;
 161
 162 sub _matched {
 163         my ( $data, $hex ) = @_;
 164         my $b = hex2bytes $hex;
 165         my $l = length($b);
 166         if ( substr($data,0,$l) eq $b ) {
 167                 warn "_matched $hex [$l] in ",as_hex($data);
 168                 return substr($data,$l);
 169         }
 170 }
 171
 172 sub read_blocks {
 173         my $tag = shift || confess "no tag?";
 174         $tag = shift if ref($tag);
 175
 176         my $tag_blocks;
 177         my $start = 0;
 178         cmd(
 179                  sprintf( "02 $tag %02x %02x", $start, $blocks ) => "read_blocks $tag $start/$blocks", sub {
 180                         my $data = shift;
 181                         if ( my $rest = _matched $data => '02 00' ) {
 182
 183                                 my $tag = hex_tag substr($rest,0,8);
 184                                 my $blocks = ord(substr($rest,8,1));
 185                                 warn "# response from $tag $blocks blocks ",as_hex substr($rest,9);
 186                                 foreach ( 1 .. $blocks ) {
 187                                         my $pos = ( $_ - 1 ) * 6 + 9;
 188                                         my $nr = unpack('v', substr($rest,$pos,2));
 189                                         my $payload = substr($rest,$pos+2,4);
 190                                         warn "## pos $pos block $nr ",as_hex($payload), $/;
 191                                         $tag_blocks->{$tag}->[$nr] = $payload;
 192                                 }
 193                         } elsif ( $rest = _matched $data => 'FE 00 00 05 01' ) {
 194                                 warn "FIXME ready? ",as_hex $rest;
 195                         } elsif ( $rest = _matched $data => '02 06' ) {
 196                                 warn "ERROR ",as_hex($rest);
 197                         } else {
 198                                 warn "FIXME unsuported ",as_hex($rest);
 199                         }
 200         });
 201
 202         warn "# tag_blocks ",dump($tag_blocks);
 203         return $tag_blocks;
 204 }
 205
 206 sub write_blocks {
 207         my $tag = shift;
 208         $tag = shift if ref $tag;
 209         my $data = join('', @_);
 210
 211         warn "## write_blocks ",dump($tag,$data);
 212
 213         if ( length($data) % 4 ) {
 214                 $data .= '\x00' x ( 4 - length($data) % 4 );
 215                 warn "# padded data to ",dump($data);
 216         }
 217
 218         my $hex_data = as_hex $data;
 219         my $blocks   = sprintf('%02x', length($data) / 4 );
 220
 221         cmd(
 222                 "04 $tag 00 $blocks 00 $hex_data", "write_blocks $tag [$blocks] $hex_data", sub {
 223                         my $data = shift;
 224                         if ( my $rest = _matched $data => '04 00' ) {
 225                                 my $tag = substr($rest,0,8);
 226                                 my $blocks = substr($rest,8,1);
 227                                 warn "# WRITE ",as_hex($tag), " [$blocks]\n";
 228                         } elsif ( $rest = _matched $data => '04 06' ) {
 229                                 warn "ERROR ",as_hex($rest);
 230                         } else {
 231                                 die "UNSUPPORTED";
 232                         }
 233                 }
 234         );
 235
 236 }
 237
 238 sub read_afi {
 239         my $tag = shift;
 240         $tag = shift if ref $tag;
 241
 242         my $afi;
 243
 244         cmd(
 245                 "0A $tag", "read_afi $tag", sub {
 246                 my $data = shift;
 247
 248                 if ( my $rest = _matched $data => '0A 00' ) {
 249
 250                         my $tag = substr($rest,0,8);
 251                            $afi = substr($rest,8,1);
 252
 253                         warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
 254
 255                 } elsif ( $rest = _matched $data => '0A 06' ) {
 256                         warn "ERROR reading security from $tag ", as_hex($data);
 257                 } else {
 258                         warn "IGNORED ",as_hex($data);
 259                 }
 260         });
 261         warn "## read_afi ",dump($tag, $afi);
 262         return $afi;
 263 }
 264
 265 sub write_afi {
 266         my $tag = shift;
 267         $tag = shift if ref $tag;
 268         my $afi = shift || die "no afi?";
 269
 270         $afi = as_hex $afi;
 271
 272         cmd(
 273                 "09 $tag $afi", "write_afi $tag $afi", sub {
 274                 my $data = shift;
 275
 276                 if ( my $rest = _matched $data => '09 00' ) {
 277
 278                         my $tag = substr($rest,0,8);
 279                            $afi = substr($rest,8,1);
 280
 281                         warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
 282
 283                 } elsif ( $rest = _matched $data => '0A 06' ) {
 284                         warn "ERROR writing AFI to $tag ", as_hex($data);
 285                         undef $afi;
 286                 } else {
 287                         warn "IGNORED ",as_hex($data);
 288                         undef $afi;
 289                 }
 290         });
 291         warn "## write_afi ", dump( $tag, $afi );
 292         return $afi;
 293 }
 294
 295 1