lib/RFID/Biblio/3M810.pm

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