viewvc.cgi/RFID/3m-810.pl

#!/usr/bin/perl

use Device::SerialPort qw (:STAT);
use strict;
use warnings;

use Data::Dump qw/dump/;
use Carp qw/confess/;

my $response = {
        'd500090400110a0500027250'                              => 'version?',
        'd60007fe00000500c97b'                                  => 'no tag in range',

        'd6000ffe00000501e00401003123aa26941a'  => 'tag #1',
        'd6000ffe00000501e0040100017c0c388e2b'  => 'rfid card',
        'd6000ffe00000501e00401003123aa2875d4'  => 'tag red-stripe',

        'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
        'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
};

=head1 NAME

3m-810 - support for 3M 810 RFID reader

=head1 SYNOPSIS

3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]

=head1 DESCRIPTION

Communicate with 3M 810 RFID reader and document it's protocol

=head1 SEE ALSO

L<Device::SerialPort(3)>

L<perl(1)>

=head1 AUTHOR

Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>

=head1 COPYRIGHT AND LICENSE

This program is free software; you may redistribute it and/or modify
it under the same terms ans Perl itself.

=cut

# your serial port.
my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;
$device    ||= "/dev/ttyUSB0";
$baudrate  ||= "19200";
$databits  ||= "8";
$parity    ||= "none";
$stopbits  ||= "1";
$handshake ||= "none";

my $port=new Device::SerialPort($device) || die "new($device): $!\n";
$handshake=$port->handshake($handshake);
$baudrate=$port->baudrate($baudrate);
$databits=$port->databits($databits);
$parity=$port->parity($parity);
$stopbits=$port->stopbits($stopbits);

print "## using $device $baudrate $databits $parity $stopbits\n";

# Just in case: reset our timing and buffers
$port->lookclear();
$port->read_const_time(100);
$port->read_char_time(5);

# Turn on parity checking:
#$port->stty_inpck(1);
#$port->stty_istrip(1);

cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',
     'D5 00  09  04   00   11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {
        my ( $len, $payload, $checksum ) = @_;
        assert( 0, 3 );
        print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";
});

cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );
#     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778

cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",
     'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );

#     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen

cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );

#     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
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";

cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );

#     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00   
#                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA
warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36
                                                                       05 00   00 00 00 00   06 00   00 00 00 00    524B\n";
warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  941A ##### ready?\n";

for ( 1 .. 3 ) {

#                                                              ++-->type 00-0a
#     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
#     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
#     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

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 $_" );
warn "D6 00  0D  04 00  E00401003123AA26  07  CFF1 -- ack 7 block?\n";

}
warn "  D6 00   0F   FE 00   00   05 01  E00401003123AA26 941A\n";

cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );

cmd('D6 00  0C  09    E00401003123AA26  D7  3AF0', 'checkin?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );
cmd('D6 00  0C  09    E00401003123AA26  DA  EB5D', 'checkout?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );

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', 
    'D6 00  0D  04 00 E00401003123AA26  06  DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );

undef $port;
print "Port closed\n";

sub writechunk
{
        my $str=shift;
        my $count = $port->write($str);
        print ">> ", as_hex( $str ), "\t[$count]\n";
}

sub as_hex {
        my @out;
        foreach my $str ( @_ ) {
                my $hex = unpack( 'H*', $str );
                $hex =~ s/(..)/$1 /g if length( $str ) > 2;
                push @out, $hex;
        }
        return join('  ', @out);
}

sub read_bytes {
        my ( $len, $desc ) = @_;
        my $data = '';
        while ( length( $data ) < $len ) {
                my ( $c, $b ) = $port->read(1);
                #warn "## got $c bytes: ", as_hex($b), "\n";
                $data .= $b;
        }
        $desc ||= '?';
        warn "#< ", as_hex($data), "\t$desc\n";
        return $data;
}

my $assert;

sub assert {
        my ( $from, $to ) = @_;

        my $p = substr( $assert->{payload}, $from, $to );
        my $e = substr( $assert->{expect},  $from, $to );
        warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
}

sub readchunk {
        my ( $parser ) = @_;

        sleep 1;        # FIXME remove

        # read header of packet
        my $header = read_bytes( 2, 'header' );
        my $length = read_bytes( 1, 'length' );
        my $len = ord($length);
        my $data = read_bytes( $len, 'data' );
        my ( $cmd ) = unpack('C', $data );

        my $payload  = substr( $data, 0, -2 );
        my $payload_len = length($data);
        warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
        my $checksum = substr( $data, -2, 2 );
        # FIXME check checksum

        print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n";

        $assert->{len}      = $len;
        $assert->{payload}  = $payload;
        $assert->{checksum} = $checksum;

        $parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';

        return $data;
}

sub str2bytes {
        my $str = shift || confess "no str?";
        $str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum
        $str =~ s/\s+/\\x/g;
        $str = '"\x' . $str . '"';
        my $bytes = eval $str;
        die $@ if $@;
        return $bytes;
}

sub cmd {
        my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
        my $bytes = str2bytes( $cmd );

        warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
        $assert->{send} = $cmd;
        writechunk( $bytes );

        if ( $expect ) {
                warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
                $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
                readchunk( $coderef );
        }
}

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			my $p = substr( $assert->{payload}, $from, $to );
168			my $e = substr( $assert->{expect}, $from, $to );
169	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
170	dpavlin	2	}
171
172	dpavlin	1	sub readchunk {
173	dpavlin	2	my ( $parser ) = @_;
174	dpavlin	1
175	dpavlin	2	sleep 1; # FIXME remove
176
177	dpavlin	1	# read header of packet
178			my $header = read_bytes( 2, 'header' );
179	dpavlin	2	my $length = read_bytes( 1, 'length' );
180			my $len = ord($length);
181	dpavlin	1	my $data = read_bytes( $len, 'data' );
182	dpavlin	2	my ( $cmd ) = unpack('C', $data );
183	dpavlin	1
184	dpavlin	2	my $payload = substr( $data, 0, -2 );
185			my $payload_len = length($data);
186			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
187			my $checksum = substr( $data, -2, 2 );
188			# FIXME check checksum
189	dpavlin	1
190	dpavlin	2	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n";
191
192			$assert->{len} = $len;
193			$assert->{payload} = $payload;
194			$assert->{checksum} = $checksum;
195
196			$parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';
197
198			return $data;
199	dpavlin	1	}
200
201	dpavlin	2	sub str2bytes {
202			my $str = shift \|\| confess "no str?";
203			$str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum
204			$str =~ s/\s+/\\x/g;
205			$str = '"\x' . $str . '"';
206			my $bytes = eval $str;
207			die $@ if $@;
208			return $bytes;
209			}
210
211			sub cmd {
212			my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
213			my $bytes = str2bytes( $cmd );
214
215			warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
216			$assert->{send} = $cmd;
217			writechunk( $bytes );
218
219			if ( $expect ) {
220			warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
221			$assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
222			readchunk( $coderef );
223			}
224			}
225