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

   1 package Biblio::RFID::Reader::3M810;
   2
   3 =head1 NAME
   4
   5 Biblio::RFID::Reader::3M810 - support for 3M 810 RFID reader
   6
   7 =head1 DESCRIPTION
   8
   9 This module uses L<Biblio::RFID::Reader::Serial> over USB/serial adapter
  10 with 3M 810 RFID reader, often used in library applications.
  11
  12 This is most mature implementation which supports full API defined
  13 in L<Biblio::RFID::Reader::API>. 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 More inforation about process of reverse engeeniring protocol with
  23 this reader is available at L<http://blog.rot13.org/rfid/>
  24
  25 =cut
  26
  27 use warnings;
  28 use strict;
  29
  30 use base 'Biblio::RFID::Reader::Serial';
  31 use Biblio::RFID;
  32
  33 use Data::Dump qw(dump);
  34 use Carp qw(confess);
  35 use Time::HiRes;
  36 use Digest::CRC;
  37
  38 sub serial_settings {{
  39         baudrate  => "19200",
  40         databits  => "8",
  41         parity    => "none",
  42         stopbits  => "1",
  43         handshake => "none",
  44 }}
  45
  46 sub assert;
  47
  48 my $port;
  49 sub init {
  50         my $self = shift;
  51         $port = $self->port;
  52
  53         # disable timeouts
  54         $port->read_char_time(0);
  55         $port->read_const_time(0);
  56
  57         # drain on startup
  58         my ( $count, $str ) = $port->read(3);
  59         if ( $count ) {
  60                 my $data = $port->read( ord(substr($str,2,1)) );
  61                 warn "drain ",as_hex( $str, $data ),"\n";
  62         }
  63
  64         $port->read_char_time(100);      # 0.1 s char timeout
  65         $port->read_const_time(500); # 0.5 s read timeout
  66
  67         $port->write( hex2bytes( 'D5 00  05   04 00 11   8C66' ) );
  68         # hw-version     expect: 'D5 00  09   04 00 11   0A 05 00 02   7250'
  69         my $data = $port->read( 12 );
  70         return unless $data;
  71
  72         warn "# probe response: ",as_hex($data);
  73         if ( my $rest = assert $data => 'D5 00  09   04 00 11' ) {
  74                 my $hw_ver = join('.', unpack('CCCC', $rest));
  75                 warn "# 3M 810 hardware version $hw_ver\n";
  76
  77                 cmd(
  78 '13  04 01 00 02 00 03 00 04 00','FIXME: stats? rf-on?', sub { assert(shift,
  79 '13  00 02 01 01 03 02 02 03 00'
  80                 )});
  81
  82                 return $hw_ver;
  83         }
  84
  85         return;
  86 }
  87
  88 sub checksum {
  89         my $bytes = shift;
  90         my $crc = Digest::CRC->new(
  91                 # midified CCITT to xor with 0xffff instead of 0x0000
  92                 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
  93         ) or die $!;
  94         $crc->add( $bytes );
  95         pack('n', $crc->digest);
  96 }
  97
  98 sub cmd {
  99         my ( $hex, $description, $coderef ) = @_;
 100         my $bytes = hex2bytes($hex);
 101         if ( substr($bytes,0,1) !~ /(\xD5|\xD6)/ ) {
 102                 my $len = pack( 'n', length( $bytes ) + 2 );
 103                 $bytes = $len . $bytes;
 104                 my $checksum = checksum($bytes);
 105                 $bytes = "\xD6" . $bytes . $checksum;
 106         }
 107
 108         warn ">> ", as_hex( $bytes ), "\t\t[$description]\n" if $debug;
 109         $port->write( $bytes );
 110
 111         my $r_len = $port->read(3);
 112
 113         while ( length($r_len) < 3 ) {
 114                 $r_len = $port->read( 3 - length($r_len) );
 115         }
 116
 117         my $len = ord( substr($r_len,2,1) );
 118         my $data = $port->read( $len );
 119
 120         warn "<< ", as_hex($r_len,$data),
 121                 ' | ',
 122                 substr($data,-2,2) eq checksum(substr($r_len,1).substr($data,0,-2)) ? 'OK' : 'ERROR',
 123                 " $len bytes\n" if $debug;
 124
 125
 126         $coderef->( $data ) if $coderef;
 127
 128 }
 129
 130 sub assert {
 131         my ( $got, $expected ) = @_;
 132         $expected = hex2bytes($expected);
 133
 134         my $len = length($got);
 135         $len = length($expected) if length $expected < $len;
 136
 137         confess "got ", as_hex($got), " expected ", as_hex($expected)
 138         unless substr($got,0,$len) eq substr($expected,0,$len);
 139
 140         return substr($got,$len);
 141 }
 142
 143
 144 sub inventory {
 145
 146         my @tags;
 147
 148 cmd( 'FE  00 05', 'scan for tags', sub {
 149         my $data = shift;
 150         my $rest = assert $data => 'FE 00 00 05';
 151         my $nr = ord( substr( $rest, 0, 1 ) );
 152
 153         if ( ! $nr ) {
 154                 warn "# no tags in range\n";
 155         } else {
 156                 my $tags = substr( $rest, 1 );
 157                 my $tl = length( $tags );
 158                 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
 159
 160                 foreach ( 0 .. $nr - 1 ) {
 161                         push @tags, hex_tag substr($tags, $_ * 8, 8);
 162                 }
 163         }
 164
 165 });
 166
 167         warn "# tags ",dump @tags;
 168         return @tags;
 169 }
 170
 171
 172 # 3M defaults: 8,4
 173 # cards 16, stickers: 8
 174 my $max_rfid_block = 8;
 175 my $blocks = 8;
 176
 177 sub _matched {
 178         my ( $data, $hex ) = @_;
 179         my $b = hex2bytes $hex;
 180         my $l = length($b);
 181         if ( substr($data,0,$l) eq $b ) {
 182                 warn "_matched $hex [$l] in ",as_hex($data) if $debug;
 183                 return substr($data,$l);
 184         }
 185 }
 186
 187 sub read_blocks {
 188         my $tag = shift || confess "no tag?";
 189         $tag = shift if ref($tag);
 190
 191         my $tag_blocks;
 192         my $start = 0;
 193         cmd(
 194                  sprintf( "02 $tag %02x %02x", $start, $blocks ) => "read_blocks $tag $start/$blocks", sub {
 195                         my $data = shift;
 196                         if ( my $rest = _matched $data => '02 00' ) {
 197
 198                                 my $tag = hex_tag substr($rest,0,8);
 199                                 my $blocks = ord(substr($rest,8,1));
 200                                 warn "# response from $tag $blocks blocks ",as_hex substr($rest,9);
 201                                 foreach ( 1 .. $blocks ) {
 202                                         my $pos = ( $_ - 1 ) * 6 + 9;
 203                                         my $nr = unpack('v', substr($rest,$pos,2));
 204                                         my $payload = substr($rest,$pos+2,4);
 205                                         warn "## pos $pos block $nr ",as_hex($payload), $/;
 206                                         $tag_blocks->{$tag}->[$nr] = $payload;
 207                                 }
 208                         } elsif ( $rest = _matched $data => 'FE 00 00 05 01' ) {
 209                                 warn "FIXME ready? ",as_hex $rest;
 210                         } elsif ( $rest = _matched $data => '02 06' ) {
 211                                 die "ERROR ",as_hex($data);
 212                         } else {
 213                                 die "FIXME unsuported ",as_hex($data);
 214                         }
 215         });
 216
 217         warn "# tag_blocks ",dump($tag_blocks);
 218         return $tag_blocks;
 219 }
 220
 221 sub write_blocks {
 222         my $tag = shift;
 223         $tag = shift if ref $tag;
 224
 225         my $data = shift;
 226         $data = join('', @$data) if ref $data eq 'ARRAY';
 227
 228         warn "## write_blocks ",dump($tag,$data);
 229
 230         if ( length($data) % 4 ) {
 231                 $data .= '\x00' x ( 4 - length($data) % 4 );
 232                 warn "# padded data to ",dump($data);
 233         }
 234
 235         my $hex_data = as_hex $data;
 236         my $blocks   = sprintf('%02x', length($data) / 4 );
 237
 238         my $retry = 0;
 239 retry_write:
 240
 241         cmd(
 242                 "04 $tag 00 $blocks 00 $hex_data", "write_blocks $tag [$blocks] $hex_data", sub {
 243                         my $data = shift;
 244                         if ( my $rest = _matched $data => '04 00' ) {
 245                                 my $tag = substr($rest,0,8);
 246                                 my $blocks = substr($rest,8,1);
 247                                 warn "# WRITE ",as_hex($tag), " [$blocks]\n";
 248                         } elsif ( $rest = _matched $data => '04 06' ) {
 249                                 die "ERROR ",as_hex($data);
 250                         } else {
 251                                 die "UNSUPPORTED ", as_hex($data);
 252                         }
 253                 }
 254         );
 255
 256         my $verify_blocks = read_blocks($tag);
 257         die "can't find data from tag $tag" unless exists $verify_blocks->{$tag};
 258
 259         if ( join('', @{ $verify_blocks->{$tag} }) ne $data ) {
 260                 $retry++;
 261                 warn "ERROR reading data back from tag, retry $retry\n";
 262                 die "ABORTED" if $retry == 10;
 263                 goto retry_write;
 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                         die "ERROR reading security from $tag ", as_hex($data);
 287                 } else {
 288                         die "IGNORED ",as_hex($data);
 289                 }
 290         });
 291         warn "## read_afi ",dump($tag, $afi);
 292         return $afi;
 293 }
 294
 295 =head2 afi_retry
 296
 297 This specified how many times will driver try to write afi to tag
 298
 299   Biblio::RFID::Reader::3M810::afi_retry = 100;
 300
 301 =cut
 302
 303 our $afi_retry = 100;
 304
 305 sub write_afi {
 306         my $tag = shift;
 307         $tag = shift if ref $tag;
 308         my $afi = shift || die "no afi?";
 309
 310         $afi = as_hex $afi;
 311         my $retry = 0;
 312
 313 retry:
 314
 315         cmd(
 316                 "09 $tag $afi", "write_afi $tag $afi", sub {
 317                 my $data = shift;
 318
 319                 if ( my $rest = _matched $data => '09 00' ) {
 320                         my $tag_back = hex_tag substr($rest,0,8);
 321                         die "write_afi got $tag_back expected $tag" if $tag_back ne $tag;
 322                         warn "# SECURITY ", hex_tag($tag), " AFI: $afi";
 323                 } elsif ( $rest = _matched $data => '09 06' ) {
 324                         if ( $retry++ <= $afi_retry ) {
 325 #                               warn "ERROR writing AFI $afi to $tag retry $retry\n";
 326                                 goto retry;
 327                         }
 328                         die "ERROR writing AFI $afi to $tag ", as_hex($data);
 329                 } else {
 330                         die "IGNORED ",as_hex($data);
 331                 }
 332         });
 333
 334         warn "INFO: tag $tag AFI $afi retry: $retry\n";
 335
 336         warn "## write_afi ", dump( $tag, $afi );
 337         return $afi;
 338 }
 339
 340 sub tag_type { 'RFID501' }
 341
 342 1;
 343
 344 __END__
 345
 346 =head1 SEE ALSO
 347
 348 L<Biblio::RFID::Reader::API>