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