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 $debug = 0;

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);

# initial hand-shake with device

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 {
        print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\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','FIXME: unimplemented', sub { assert() }  );

# start scanning for tags

cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
     'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {
dispatch( 
         'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8
                sub {
                        my $rest = shift || die "no rest?";
                        my $nr = ord( substr( $rest, 0, 1 ) );
                        my $tags = substr( $rest, 1 );

                        my $tl = length( $tags );
                        die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;

                        my @tags;
                        push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );
                        warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags );
                        print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";
                }
) }

) foreach ( 1 .. 100 );

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" if $debug;
        return $data;
}

our $assert;

# my $rest = skip_assert( 3 );
sub skip_assert {
        assert( 0, shift );
}

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

        $from ||= 0;
        $to = length( $assert->{expect} ) if ! defined $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;

        # return the rest
        return substr( $assert->{payload}, $to );
}

our $dispatch;
sub dispatch {
        my ( $pattern, $coderef ) = @_;
        my $patt = substr( str2bytes($pattern), 3 ); # just payload
        my $l = length($patt);
        my $p = substr( $assert->{payload}, 0, $l );
        warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p );

        if ( $assert->{payload} eq $assert->{expect} ) {
                warn "## no dispatch, payload expected\n";
        } elsif ( $p eq $patt ) {
                # if matched call with rest of payload
                $coderef->( substr( $assert->{payload}, $l ) );
        } else {
                warn "## dispatch ignored\n";
        }
}

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