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($rest);
 212                         } else {
 213                                 die "FIXME unsuported ",as_hex($rest);
 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         cmd(
 239                 "04 $tag 00 $blocks 00 $hex_data", "write_blocks $tag [$blocks] $hex_data", sub {
 240                         my $data = shift;
 241                         if ( my $rest = _matched $data => '04 00' ) {
 242                                 my $tag = substr($rest,0,8);
 243                                 my $blocks = substr($rest,8,1);
 244                                 warn "# WRITE ",as_hex($tag), " [$blocks]\n";
 245                         } elsif ( $rest = _matched $data => '04 06' ) {
 246                                 die "ERROR ",as_hex($rest);
 247                         } else {
 248                                 die "UNSUPPORTED";
 249                         }
 250                 }
 251         );
 252
 253 }
 254
 255 sub read_afi {
 256         my $tag = shift;
 257         $tag = shift if ref $tag;
 258
 259         my $afi;
 260
 261         cmd(
 262                 "0A $tag", "read_afi $tag", sub {
 263                 my $data = shift;
 264
 265                 if ( my $rest = _matched $data => '0A 00' ) {
 266
 267                         my $tag = substr($rest,0,8);
 268                            $afi = substr($rest,8,1);
 269
 270                         warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
 271
 272                 } elsif ( $rest = _matched $data => '0A 06' ) {
 273                         die "ERROR reading security from $tag ", as_hex($data);
 274                 } else {
 275                         die "IGNORED ",as_hex($data);
 276                 }
 277         });
 278         warn "## read_afi ",dump($tag, $afi);
 279         return $afi;
 280 }
 281
 282 sub write_afi {
 283         my $tag = shift;
 284         $tag = shift if ref $tag;
 285         my $afi = shift || die "no afi?";
 286
 287         $afi = as_hex $afi;
 288
 289         cmd(
 290                 "09 $tag $afi", "write_afi $tag $afi", sub {
 291                 my $data = shift;
 292
 293                 if ( my $rest = _matched $data => '09 00' ) {
 294                         my $tag_back = hex_tag substr($rest,0,8);
 295                         die "write_afi got $tag_back expected $tag" if $tag_back ne $tag;
 296                         warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
 297                 } elsif ( $rest = _matched $data => '0A 06' ) {
 298                         die "ERROR writing AFI to $tag ", as_hex($data);
 299                 } else {
 300                         die "IGNORED ",as_hex($data);
 301                 }
 302         });
 303         warn "## write_afi ", dump( $tag, $afi );
 304         return $afi;
 305 }
 306
 307 sub tag_type { 'RFID501' }
 308
 309 1;
 310
 311 __END__
 312
 313 =head1 SEE ALSO
 314
 315 L<Biblio::RFID::Reader::API>