| 1 |
dpavlin |
1 |
#!/usr/bin/perl |
| 2 |
|
|
|
| 3 |
|
|
use Device::SerialPort qw (:STAT); |
| 4 |
|
|
use strict; |
| 5 |
|
|
use warnings; |
| 6 |
|
|
|
| 7 |
|
|
use Data::Dump qw/dump/; |
| 8 |
dpavlin |
2 |
use Carp qw/confess/; |
| 9 |
dpavlin |
1 |
|
| 10 |
|
|
my $response = { |
| 11 |
|
|
'd500090400110a0500027250' => 'version?', |
| 12 |
|
|
'd60007fe00000500c97b' => 'no tag in range', |
| 13 |
|
|
|
| 14 |
|
|
'd6000ffe00000501e00401003123aa26941a' => 'tag #1', |
| 15 |
|
|
'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card', |
| 16 |
|
|
'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe', |
| 17 |
|
|
|
| 18 |
|
|
'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card', |
| 19 |
|
|
'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe', |
| 20 |
|
|
}; |
| 21 |
|
|
|
| 22 |
|
|
=head1 NAME |
| 23 |
|
|
|
| 24 |
|
|
3m-810 - support for 3M 810 RFID reader |
| 25 |
|
|
|
| 26 |
|
|
=head1 SYNOPSIS |
| 27 |
|
|
|
| 28 |
|
|
3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]] |
| 29 |
|
|
|
| 30 |
|
|
=head1 DESCRIPTION |
| 31 |
|
|
|
| 32 |
|
|
Communicate with 3M 810 RFID reader and document it's protocol |
| 33 |
|
|
|
| 34 |
|
|
=head1 SEE ALSO |
| 35 |
|
|
|
| 36 |
|
|
L<Device::SerialPort(3)> |
| 37 |
|
|
|
| 38 |
|
|
L<perl(1)> |
| 39 |
|
|
|
| 40 |
|
|
=head1 AUTHOR |
| 41 |
|
|
|
| 42 |
|
|
Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/> |
| 43 |
|
|
|
| 44 |
|
|
=head1 COPYRIGHT AND LICENSE |
| 45 |
|
|
|
| 46 |
|
|
This program is free software; you may redistribute it and/or modify |
| 47 |
|
|
it under the same terms ans Perl itself. |
| 48 |
|
|
|
| 49 |
|
|
=cut |
| 50 |
|
|
|
| 51 |
|
|
# your serial port. |
| 52 |
|
|
my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV; |
| 53 |
|
|
$device ||= "/dev/ttyUSB0"; |
| 54 |
|
|
$baudrate ||= "19200"; |
| 55 |
|
|
$databits ||= "8"; |
| 56 |
|
|
$parity ||= "none"; |
| 57 |
|
|
$stopbits ||= "1"; |
| 58 |
|
|
$handshake ||= "none"; |
| 59 |
|
|
|
| 60 |
|
|
my $port=new Device::SerialPort($device) || die "new($device): $!\n"; |
| 61 |
|
|
$handshake=$port->handshake($handshake); |
| 62 |
|
|
$baudrate=$port->baudrate($baudrate); |
| 63 |
|
|
$databits=$port->databits($databits); |
| 64 |
|
|
$parity=$port->parity($parity); |
| 65 |
|
|
$stopbits=$port->stopbits($stopbits); |
| 66 |
|
|
|
| 67 |
|
|
print "## using $device $baudrate $databits $parity $stopbits\n"; |
| 68 |
|
|
|
| 69 |
|
|
# Just in case: reset our timing and buffers |
| 70 |
|
|
$port->lookclear(); |
| 71 |
|
|
$port->read_const_time(100); |
| 72 |
|
|
$port->read_char_time(5); |
| 73 |
|
|
|
| 74 |
|
|
# Turn on parity checking: |
| 75 |
|
|
#$port->stty_inpck(1); |
| 76 |
|
|
#$port->stty_istrip(1); |
| 77 |
|
|
|
| 78 |
|
|
cmd( 'D5 00 05 04 00 11 8C66', 'hw version?', |
| 79 |
dpavlin |
2 |
'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub { |
| 80 |
|
|
my ( $len, $payload, $checksum ) = @_; |
| 81 |
|
|
assert( 0, 3 ); |
| 82 |
|
|
print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n"; |
| 83 |
|
|
}); |
| 84 |
dpavlin |
1 |
|
| 85 |
|
|
cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?' ); |
| 86 |
|
|
# D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778 |
| 87 |
|
|
|
| 88 |
|
|
cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_", |
| 89 |
|
|
'D6 00 07 FE 00 00 05 00 C97B -- no tag' ) foreach ( 1 .. 10 ); |
| 90 |
|
|
|
| 91 |
|
|
# D6 00 0F FE 00 00 05 01 E00401003123AA26 941A # seen |
| 92 |
|
|
|
| 93 |
|
|
cmd( 'D6 00 0D 02 E00401003123AA26 00 03 1CC4', 'read offset: 0 blocks: 3' ); |
| 94 |
|
|
|
| 95 |
|
|
# D6 00 1F 02 00 E00401003123AA26 03 00 00 04 11 00 01 01 00 30 30 30 30 02 00 30 30 30 30 E5F4 |
| 96 |
|
|
warn "D6 00 1F 02 00 E00401003123AA26 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n"; |
| 97 |
|
|
|
| 98 |
|
|
cmd( 'D6 00 0D 02 E00401003123AA26 03 04 3970', 'read offset: 3 blocks: 4' ); |
| 99 |
|
|
|
| 100 |
|
|
# D6 00 25 02 00 E00401003123AA26 04 03 00 30 30 00 00 04 00 00 00 00 00 |
| 101 |
|
|
# 05 00 00 00 00 00 06 00 00 00 00 00 B9BA |
| 102 |
|
|
warn "D6 00 25 02 00 E00401003123AA26 04 03 00 39 30 31 32 04 00 33 34 35 36 |
| 103 |
|
|
05 00 00 00 00 00 06 00 00 00 00 00 524B\n"; |
| 104 |
|
|
warn "D6 00 0F FE 00 00 05 01 E00401003123AA26 941A ##### ready?\n"; |
| 105 |
|
|
|
| 106 |
|
|
for ( 1 .. 3 ) { |
| 107 |
|
|
|
| 108 |
|
|
# ++-->type 00-0a |
| 109 |
|
|
# D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4 |
| 110 |
|
|
# D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7 |
| 111 |
|
|
# D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F |
| 112 |
|
|
|
| 113 |
|
|
cmd(' D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00 8843', "write offset 0, block: 7 -- 0000000000 $_" ); |
| 114 |
|
|
warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n"; |
| 115 |
|
|
|
| 116 |
|
|
} |
| 117 |
|
|
warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n"; |
| 118 |
|
|
|
| 119 |
|
|
cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 ); |
| 120 |
|
|
|
| 121 |
|
|
cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?', |
| 122 |
|
|
'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' ); |
| 123 |
|
|
cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?', |
| 124 |
|
|
'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' ); |
| 125 |
|
|
|
| 126 |
|
|
cmd('D6 00 26 04 E00401003123AA26 00 06 00 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 A98B', 'blank offset: 0 blocks: 6', |
| 127 |
|
|
'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 ); |
| 128 |
|
|
|
| 129 |
|
|
undef $port; |
| 130 |
|
|
print "Port closed\n"; |
| 131 |
|
|
|
| 132 |
|
|
sub writechunk |
| 133 |
|
|
{ |
| 134 |
|
|
my $str=shift; |
| 135 |
|
|
my $count = $port->write($str); |
| 136 |
|
|
print ">> ", as_hex( $str ), "\t[$count]\n"; |
| 137 |
|
|
} |
| 138 |
|
|
|
| 139 |
|
|
sub as_hex { |
| 140 |
|
|
my @out; |
| 141 |
|
|
foreach my $str ( @_ ) { |
| 142 |
|
|
my $hex = unpack( 'H*', $str ); |
| 143 |
dpavlin |
2 |
$hex =~ s/(..)/$1 /g if length( $str ) > 2; |
| 144 |
dpavlin |
1 |
push @out, $hex; |
| 145 |
|
|
} |
| 146 |
|
|
return join(' ', @out); |
| 147 |
|
|
} |
| 148 |
|
|
|
| 149 |
|
|
sub read_bytes { |
| 150 |
|
|
my ( $len, $desc ) = @_; |
| 151 |
|
|
my $data = ''; |
| 152 |
|
|
while ( length( $data ) < $len ) { |
| 153 |
|
|
my ( $c, $b ) = $port->read(1); |
| 154 |
|
|
#warn "## got $c bytes: ", as_hex($b), "\n"; |
| 155 |
|
|
$data .= $b; |
| 156 |
|
|
} |
| 157 |
|
|
$desc ||= '?'; |
| 158 |
|
|
warn "#< ", as_hex($data), "\t$desc\n"; |
| 159 |
|
|
return $data; |
| 160 |
|
|
} |
| 161 |
|
|
|
| 162 |
dpavlin |
2 |
my $assert; |
| 163 |
|
|
|
| 164 |
|
|
sub assert { |
| 165 |
|
|
my ( $from, $to ) = @_; |
| 166 |
|
|
|
| 167 |
|
|
warn "# assert ", dump( $assert ); |
| 168 |
|
|
|
| 169 |
|
|
my $p = substr( $assert->{payload}, $from, $to ); |
| 170 |
|
|
my $e = substr( $assert->{expect}, $from, $to ); |
| 171 |
|
|
warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), "\t[$from-$to]\n" if $e ne $p; |
| 172 |
|
|
} |
| 173 |
|
|
|
| 174 |
dpavlin |
1 |
sub readchunk { |
| 175 |
dpavlin |
2 |
my ( $parser ) = @_; |
| 176 |
dpavlin |
1 |
|
| 177 |
dpavlin |
2 |
sleep 1; # FIXME remove |
| 178 |
|
|
|
| 179 |
dpavlin |
1 |
# read header of packet |
| 180 |
|
|
my $header = read_bytes( 2, 'header' ); |
| 181 |
dpavlin |
2 |
my $length = read_bytes( 1, 'length' ); |
| 182 |
|
|
my $len = ord($length); |
| 183 |
dpavlin |
1 |
my $data = read_bytes( $len, 'data' ); |
| 184 |
dpavlin |
2 |
my ( $cmd ) = unpack('C', $data ); |
| 185 |
dpavlin |
1 |
|
| 186 |
dpavlin |
2 |
my $payload = substr( $data, 0, -2 ); |
| 187 |
|
|
my $payload_len = length($data); |
| 188 |
|
|
warn "## payload too short $payload_len != $len\n" if $payload_len != $len; |
| 189 |
|
|
my $checksum = substr( $data, -2, 2 ); |
| 190 |
|
|
# FIXME check checksum |
| 191 |
dpavlin |
1 |
|
| 192 |
dpavlin |
2 |
print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n"; |
| 193 |
|
|
|
| 194 |
|
|
$assert->{len} = $len; |
| 195 |
|
|
$assert->{payload} = $payload; |
| 196 |
|
|
$assert->{checksum} = $checksum; |
| 197 |
|
|
|
| 198 |
|
|
$parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE'; |
| 199 |
|
|
|
| 200 |
|
|
return $data; |
| 201 |
dpavlin |
1 |
} |
| 202 |
|
|
|
| 203 |
dpavlin |
2 |
sub str2bytes { |
| 204 |
|
|
my $str = shift || confess "no str?"; |
| 205 |
|
|
$str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum |
| 206 |
|
|
$str =~ s/\s+/\\x/g; |
| 207 |
|
|
$str = '"\x' . $str . '"'; |
| 208 |
|
|
my $bytes = eval $str; |
| 209 |
|
|
die $@ if $@; |
| 210 |
|
|
return $bytes; |
| 211 |
|
|
} |
| 212 |
|
|
|
| 213 |
|
|
sub cmd { |
| 214 |
|
|
my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_; |
| 215 |
|
|
my $bytes = str2bytes( $cmd ); |
| 216 |
|
|
|
| 217 |
|
|
warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n"; |
| 218 |
|
|
$assert->{send} = $cmd; |
| 219 |
|
|
writechunk( $bytes ); |
| 220 |
|
|
|
| 221 |
|
|
if ( $expect ) { |
| 222 |
|
|
warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n"; |
| 223 |
|
|
$assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload |
| 224 |
|
|
readchunk( $coderef ); |
| 225 |
|
|
} |
| 226 |
|
|
} |
| 227 |
|
|
|
Parent Directory
| 
Revision Log