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