lib/RFID/Biblio/Reader/3M810.pm

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