File Coverage

lib/Biblio/RFID/Reader/3M810.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package Biblio::RFID::Reader::3M810;

=head1 NAME

Biblio::RFID::Reader::3M810 - support for 3M 810 RFID reader

=head1 DESCRIPTION

This module uses L over USB/serial adapter
with 3M 810 RFID reader, often used in library applications.

This is most mature implementation which supports full API defined
in L. This include scanning for all tags in reader
range, reading and writing of data, and AFI security manipulation.

This implementation is developed using Portmon on Windows to capture serial traffic
L

Checksum for this reader is developed using help from C
L

More inforation about process of reverse engeeniring protocol with
this reader is available at L

=cut

use warnings;
use strict;

use base 'Biblio::RFID::Reader::Serial';
use Biblio::RFID;

use Data::Dump qw(dump);
use Carp qw(confess);
use Time::HiRes;
use Digest::CRC;

sub serial_settings {{
	baudrate  => "19200",
	databits  => "8",
	parity	  => "none",
	stopbits  => "1",
	handshake => "none",
}}

sub assert;

my $port;
sub init {
	my $self = shift;
	$port = $self->port;

	# disable timeouts
	$port->read_char_time(0);
	$port->read_const_time(0);

	# drain on startup
	my ( $count, $str ) = $port->read(3);
	if ( $count ) {
		my $data = $port->read( ord(substr($str,2,1)) );
		warn "drain ",as_hex( $str, $data ),"\n";
	}

	$port->read_char_time(100);	 # 0.1 s char timeout
	$port->read_const_time(500); # 0.5 s read timeout

	$port->write( hex2bytes( 'D5 00  05   04 00 11   8C66' ) );
	# hw-version     expect: 'D5 00  09   04 00 11   0A 05 00 02   7250'
	my $data = $port->read( 12 );
	return unless $data;

	warn "# probe response: ",as_hex($data);
	if ( my $rest = assert $data => 'D5 00  09   04 00 11' ) {
		my $hw_ver = join('.', unpack('CCCC', $rest));
		warn "# 3M 810 hardware version $hw_ver\n";

		cmd(
'13  04 01 00 02 00 03 00 04 00','FIXME: stats? rf-on?', sub { assert(shift,
'13  00 02 01 01 03 02 02 03 00'
		)});

		return $hw_ver;
	}

	return;
}

sub checksum {
	my $bytes = shift;
	my $crc = Digest::CRC->new(
		# midified CCITT to xor with 0xffff instead of 0x0000
		width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
	) or die $!;
	$crc->add( $bytes );
	pack('n', $crc->digest);
}

sub cmd {
	my ( $hex, $description, $coderef ) = @_;
	my $bytes = hex2bytes($hex);
	if ( substr($bytes,0,1) !~ /(\xD5|\xD6)/ ) {
		my $len = pack( 'n', length( $bytes ) + 2 );
		$bytes = $len . $bytes;
		my $checksum = checksum($bytes);
		$bytes = "\xD6" . $bytes . $checksum;
	}

	warn ">> ", as_hex( $bytes ), "\t\t[$description]\n" if $debug;
	$port->write( $bytes );

	my $r_len = $port->read(3);

	while ( length($r_len) < 3 ) {
		$r_len = $port->read( 3 - length($r_len) );
	}

	my $len = ord( substr($r_len,2,1) );
	my $data = $port->read( $len );

	warn "<< ", as_hex($r_len,$data),
		' | ',
		substr($data,-2,2) eq checksum(substr($r_len,1).substr($data,0,-2)) ? 'OK' : 'ERROR',
		" $len bytes\n" if $debug;


	$coderef->( $data ) if $coderef;

}

sub assert {
	my ( $got, $expected ) = @_;
	$expected = hex2bytes($expected);

	my $len = length($got);
	$len = length($expected) if length $expected < $len;

	confess "got ", as_hex($got), " expected ", as_hex($expected)
	unless substr($got,0,$len) eq substr($expected,0,$len);

	return substr($got,$len);
}


sub inventory {

	my @tags;

cmd( 'FE  00 05', 'scan for tags', sub {
	my $data = shift;
	my $rest = assert $data => 'FE 00 00 05';
	my $nr = ord( substr( $rest, 0, 1 ) );

	if ( ! $nr ) {
		warn "# no tags in range\n";
	} else {
		my $tags = substr( $rest, 1 );
		my $tl = length( $tags );
		die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;

		foreach ( 0 .. $nr - 1 ) {
			push @tags, hex_tag substr($tags, $_ * 8, 8);
		}
	}

});

	warn "# tags ",dump @tags;
	return @tags;
}


# 3M defaults: 8,4
# cards 16, stickers: 8
my $max_rfid_block = 8;
my $blocks = 8;

sub _matched {
	my ( $data, $hex ) = @_;
	my $b = hex2bytes $hex;
	my $l = length($b);
	if ( substr($data,0,$l) eq $b ) {
		warn "_matched $hex [$l] in ",as_hex($data) if $debug;
		return substr($data,$l);
	}
}

sub read_blocks {
	my $tag = shift || confess "no tag?";
	$tag = shift if ref($tag);

	my $tag_blocks;
	my $start = 0;
	cmd(
		 sprintf( "02 $tag %02x %02x", $start, $blocks ) => "read_blocks $tag $start/$blocks", sub {
			my $data = shift;
			if ( my $rest = _matched $data => '02 00' ) {

				my $tag = hex_tag substr($rest,0,8);
				my $blocks = ord(substr($rest,8,1));
				warn "# response from $tag $blocks blocks ",as_hex substr($rest,9);
				foreach ( 1 .. $blocks ) {
					my $pos = ( $_ - 1 ) * 6 + 9;
					my $nr = unpack('v', substr($rest,$pos,2));
					my $payload = substr($rest,$pos+2,4);
					warn "## pos $pos block $nr ",as_hex($payload), $/;
					$tag_blocks->{$tag}->[$nr] = $payload;
				}
			} elsif ( $rest = _matched $data => 'FE 00 00 05 01' ) {
				warn "FIXME ready? ",as_hex $rest;
			} elsif ( $rest = _matched $data => '02 06' ) {
				die "ERROR ",as_hex($rest);
			} else {
				die "FIXME unsuported ",as_hex($rest);
			}
	});

	warn "# tag_blocks ",dump($tag_blocks);
	return $tag_blocks;
}

sub write_blocks {
	my $tag = shift;
	$tag = shift if ref $tag;

	my $data = shift;
	$data = join('', @$data) if ref $data eq 'ARRAY';

	warn "## write_blocks ",dump($tag,$data);

	if ( length($data) % 4 ) {
		$data .= '\x00' x ( 4 - length($data) % 4 );
		warn "# padded data to ",dump($data);
	}

	my $hex_data = as_hex $data;
	my $blocks   = sprintf('%02x', length($data) / 4 );

	cmd(
		"04 $tag 00 $blocks 00 $hex_data", "write_blocks $tag [$blocks] $hex_data", sub {
			my $data = shift;
			if ( my $rest = _matched $data => '04 00' ) {
				my $tag = substr($rest,0,8);
				my $blocks = substr($rest,8,1);
				warn "# WRITE ",as_hex($tag), " [$blocks]\n";
			} elsif ( $rest = _matched $data => '04 06' ) {
				die "ERROR ",as_hex($rest);
			} else {
				die "UNSUPPORTED";
			}
		}
	);

}

sub read_afi {
	my $tag = shift;
	$tag = shift if ref $tag;

	my $afi;

	cmd(
		"0A $tag", "read_afi $tag", sub {
		my $data = shift;

		if ( my $rest = _matched $data => '0A 00' ) {

			my $tag = substr($rest,0,8);
			   $afi = substr($rest,8,1);

			warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);

		} elsif ( $rest = _matched $data => '0A 06' ) {
			die "ERROR reading security from $tag ", as_hex($data);
		} else {
			die "IGNORED ",as_hex($data);
		}
	});
	warn "## read_afi ",dump($tag, $afi);
	return $afi;
}

sub write_afi {
	my $tag = shift;
	$tag = shift if ref $tag;
	my $afi = shift || die "no afi?";

	$afi = as_hex $afi;

	cmd(
		"09 $tag $afi", "write_afi $tag $afi", sub {
		my $data = shift;

		if ( my $rest = _matched $data => '09 00' ) {
			my $tag_back = hex_tag substr($rest,0,8);
			die "write_afi got $tag_back expected $tag" if $tag_back ne $tag;
			warn "# SECURITY ", hex_tag($tag), " AFI: ", as_hex($afi);
		} elsif ( $rest = _matched $data => '0A 06' ) {
			die "ERROR writing AFI to $tag ", as_hex($data);
		} else {
			die "IGNORED ",as_hex($data);
		}
	});
	warn "## write_afi ", dump( $tag, $afi );
	return $afi;
}

1

__END__