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