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         my $data = $port->read( ord(substr($str,2,1)) );
  60         warn "drain ",as_hex( $str, $data ),"\n";
  61
  62         $port->read_char_time(100);      # 0.1 s char timeout
  63         $port->read_const_time(500); # 0.5 s read timeout
  64
  65         $port->write( hex2bytes( 'D5 00  05   04 00 11   8C66' ) );
  66         # hw-version     expect: 'D5 00  09   04 00 11   0A 05 00 02   7250'
  67         my $data = $port->read( 12 );
  68         return unless $data;
  69
  70         warn "# probe response: ",as_hex($data);
  71         if ( my $rest = assert $data => 'D5 00  09   04 00 11' ) {
  72                 my $hw_ver = join('.', unpack('CCCC', $rest));
  73                 warn "# 3M 810 hardware version $hw_ver\n";
  74
  75                 cmd(
  76 '13  04 01 00 02 00 03 00 04 00','FIXME: stats? rf-on?', sub { assert(shift,
  77 '13  00 02 01 01 03 02 02 03 00'
  78                 )});
  79
  80                 return $hw_ver;
  81         }
  82
  83         return;
  84 }
  85
  86 sub checksum {
  87         my $bytes = shift;
  88         my $crc = Digest::CRC->new(
  89                 # midified CCITT to xor with 0xffff instead of 0x0000
  90                 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
  91         ) or die $!;
  92         $crc->add( $bytes );
  93         pack('n', $crc->digest);
  94 }
  95
  96 sub cmd {
  97         my ( $hex, $description, $coderef ) = @_;
  98         my $bytes = hex2bytes($hex);
  99         if ( substr($bytes,0,1) !~ /(\xD5|\xD6)/ ) {
 100                 my $len = pack( 'n', length( $bytes ) + 2 );
 101                 $bytes = $len . $bytes;
 102                 my $checksum = checksum($bytes);
 103                 $bytes = "\xD6" . $bytes . $checksum;
 104         }
 105
 106         warn ">> ", as_hex( $bytes ), "\t\t[$description]\n" if $debug;
 107         $port->write( $bytes );
 108
 109         my $r_len = $port->read(3);
 110
 111         while ( length($r_len) < 3 ) {
 112                 $r_len = $port->read( 3 - length($r_len) );
 113         }
 114
 115         my $len = ord( substr($r_len,2,1) );
 116         my $data = $port->read( $len );
 117
 118         warn "<< ", as_hex($r_len,$data),
 119                 ' | ',
 120                 substr($data,-2,2) eq checksum(substr($r_len,1).substr($data,0,-2)) ? 'OK' : 'ERROR',
 121                 " $len bytes\n" if $debug;
 122
 123
 124         $coderef->( $data ) if $coderef;
 125
 126 }
 127
 128 sub assert {
 129         my ( $got, $expected ) = @_;
 130         $expected = hex2bytes($expected);
 131
 132         my $len = length($got);
 133         $len = length($expected) if length $expected < $len;
 134
 135         confess "got ", as_hex($got), " expected ", as_hex($expected)
 136         unless substr($got,0,$len) eq substr($expected,0,$len);
 137
 138         return substr($got,$len);
 139 }
 140
 141
 142 sub inventory {
 143
 144         my @tags;
 145
 146 cmd( 'FE  00 05', 'scan for tags', sub {
 147         my $data = shift;
 148         my $rest = assert $data => 'FE 00 00 05';
 149         my $nr = ord( substr( $rest, 0, 1 ) );
 150
 151         if ( ! $nr ) {
 152                 warn "# no tags in range\n";
 153         } else {
 154                 my $tags = substr( $rest, 1 );
 155                 my $tl = length( $tags );
 156                 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
 157
 158                 foreach ( 0 .. $nr - 1 ) {
 159                         push @tags, hex_tag substr($tags, $_ * 8, 8);
 160                 }
 161         }
 162
 163 });
 164
 165         warn "# tags ",dump @tags;
 166         return @tags;
 167 }
 168
 169
 170 # 3M defaults: 8,4
 171 # cards 16, stickers: 8
 172 my $max_rfid_block = 8;
 173 my $blocks = 8;
 174
 175 sub _matched {
 176         my ( $data, $hex ) = @_;
 177         my $b = hex2bytes $hex;
 178         my $l = length($b);
 179         if ( substr($data,0,$l) eq $b ) {
 180                 warn "_matched $hex [$l] in ",as_hex($data) if $debug;
 181                 return substr($data,$l);
 182         }
 183 }
 184
 185 sub read_blocks {
 186         my $tag = shift || confess "no tag?";
 187         $tag = shift if ref($tag);
 188
 189         my $tag_blocks;
 190         my $start = 0;
 191         cmd(
 192                  sprintf( "02 $tag %02x %02x", $start, $blocks ) => "read_blocks $tag $start/$blocks", sub {
 193                         my $data = shift;
 194                         if ( my $rest = _matched $data => '02 00' ) {
 195
 196                                 my $tag = hex_tag substr($rest,0,8);
 197                                 my $blocks = ord(substr($rest,8,1));
 198                                 warn "# response from $tag $blocks blocks ",as_hex substr($rest,9);
 199                                 foreach ( 1 .. $blocks ) {
 200                                         my $pos = ( $_ - 1 ) * 6 + 9;
 201                                         my $nr = unpack('v', substr($rest,$pos,2));
 202                                         my $payload = substr($rest,$pos+2,4);
 203                                         warn "## pos $pos block $nr ",as_hex($payload), $/;
 204                                         $tag_blocks->{$tag}->[$nr] = $payload;
 205                                 }
 206                         } elsif ( $rest = _matched $data => 'FE 00 00 05 01' ) {
 207                                 warn "FIXME ready? ",as_hex $rest;
 208                         } elsif ( $rest = _matched $data => '02 06' ) {
 209                                 die "ERROR ",as_hex($rest);
 210                         } else {
 211                                 die "FIXME unsuported ",as_hex($rest);
 212                         }
 213         });
 214
 215         warn "# tag_blocks ",dump($tag_blocks);
 216         return $tag_blocks;
 217 }
 218
 219 sub write_blocks {
 220         my $tag = shift;
 221         $tag = shift if ref $tag;
 222
 223         my $data = shift;
 224         $data = join('', @$data) if ref $data eq 'ARRAY';
 225
 226         warn "## write_blocks ",dump($tag,$data);
 227
 228         if ( length($data) % 4 ) {
 229                 $data .= '\x00' x ( 4 - length($data) % 4 );
 230                 warn "# padded data to ",dump($data);
 231         }
 232
 233         my $hex_data = as_hex $data;
 234         my $blocks   = sprintf('%02x', length($data) / 4 );
 235
 236         cmd(
 237                 "04 $tag 00 $blocks 00 $hex_data", "write_blocks $tag [$blocks] $hex_data", sub {
 238                         my $data = shift;
 239                         if ( my $rest = _matched $data => '04 00' ) {
 240                                 my $tag = substr($rest,0,8);
 241                                 my $blocks = substr($rest,8,1);
 242                                 warn "# WRITE ",as_hex($tag), " [$blocks]\n";
 243                         } elsif ( $rest = _matched $data => '04 06' ) {
 244                                 die "ERROR ",as_hex($rest);
 245                         } else {
 246                                 die "UNSUPPORTED";
 247                         }
 248                 }
 249         );
 250
 251 }
 252
 253 sub read_afi {
 254         my $tag = shift;
 255         $tag = shift if ref $tag;
 256
 257         my $afi;
 258
 259         cmd(
 260                 "0A $tag", "read_afi $tag", sub {
 261                 my $data = shift;
 262
 263                 if ( my $rest = _matched $data => '0A 00' ) {
 264
 265                         my $tag = substr($rest,0,8);
 266                            $afi = substr($rest,8,1);
 267
 268                         warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
 269
 270                 } elsif ( $rest = _matched $data => '0A 06' ) {
 271                         die "ERROR reading security from $tag ", as_hex($data);
 272                 } else {
 273                         die "IGNORED ",as_hex($data);
 274                 }
 275         });
 276         warn "## read_afi ",dump($tag, $afi);
 277         return $afi;
 278 }
 279
 280 sub write_afi {
 281         my $tag = shift;
 282         $tag = shift if ref $tag;
 283         my $afi = shift || die "no afi?";
 284
 285         $afi = as_hex $afi;
 286
 287         cmd(
 288                 "09 $tag $afi", "write_afi $tag $afi", sub {
 289                 my $data = shift;
 290
 291                 if ( my $rest = _matched $data => '09 00' ) {
 292                         my $tag_back = hex_tag substr($rest,0,8);
 293                         die "write_afi got $tag_back expected $tag" if $tag_back ne $tag;
 294                         warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
 295                 } elsif ( $rest = _matched $data => '0A 06' ) {
 296                         die "ERROR writing AFI to $tag ", as_hex($data);
 297                 } else {
 298                         die "IGNORED ",as_hex($data);
 299                 }
 300         });
 301         warn "## write_afi ", dump( $tag, $afi );
 302         return $afi;
 303 }
 304
 305 1
 306
 307 __END__
 308
 309 =head1 SEE ALSO
 310
 311 L<Biblio::RFID::Reader::API>