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