lib/RFID/Serial/3M810.pm

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