/[RFID]/3m-810.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 15 - (show annotations)
Thu Oct 2 21:20:10 2008 UTC (15 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 9336 byte(s)
added checksum based on great feedback from stackoverflow :-)
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 use Carp qw/confess/;
9
10 my $debug = 0;
11
12 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 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
43
44 =head1 AUTHOR
45
46 Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
47
48 =head1 COPYRIGHT AND LICENSE
49
50 This program is free software; you may redistribute it and/or modify
51 it under the same terms ans Perl itself.
52
53 =cut
54
55 # your serial port.
56 my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;
57 $device ||= "/dev/ttyUSB0";
58 $baudrate ||= "19200";
59 $databits ||= "8";
60 $parity ||= "none";
61 $stopbits ||= "1";
62 $handshake ||= "none";
63
64 my $port=new Device::SerialPort($device) || die "new($device): $!\n";
65 $handshake=$port->handshake($handshake);
66 $baudrate=$port->baudrate($baudrate);
67 $databits=$port->databits($databits);
68 $parity=$port->parity($parity);
69 $stopbits=$port->stopbits($stopbits);
70
71 print "## using $device $baudrate $databits $parity $stopbits\n";
72
73 # Just in case: reset our timing and buffers
74 $port->lookclear();
75 $port->read_const_time(100);
76 $port->read_char_time(5);
77
78 # Turn on parity checking:
79 #$port->stty_inpck(1);
80 #$port->stty_istrip(1);
81
82 # initial hand-shake with device
83
84 cmd( 'D5 00 05 04 00 11 8C66', 'hw version?',
85 'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub {
86 print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
87 });
88
89 cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?',
90 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert() } );
91
92 # start scanning for tags
93
94 cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_",
95 'D6 00 07 FE 00 00 05 00 C97B', 'no tag', sub {
96 dispatch(
97 'D6 00 0F FE 00 00 05 ',# 01 E00401003123AA26 941A # seen, serial length: 8
98 sub {
99 my $rest = shift || die "no rest?";
100 my $nr = ord( substr( $rest, 0, 1 ) );
101 my $tags = substr( $rest, 1 );
102
103 my $tl = length( $tags );
104 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
105
106 my @tags;
107 push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );
108 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
109 print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";
110 }
111 ) }
112
113 ) foreach ( 1 .. 100 );
114
115 cmd( 'D6 00 0D 02 E00401003123AA26 00 03 1CC4', 'read offset: 0 blocks: 3' );
116
117 # 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
118 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";
119
120 cmd( 'D6 00 0D 02 E00401003123AA26 03 04 3970', 'read offset: 3 blocks: 4' );
121
122 # D6 00 25 02 00 E00401003123AA26 04 03 00 30 30 00 00 04 00 00 00 00 00
123 # 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
124 warn "D6 00 25 02 00 E00401003123AA26 04 03 00 39 30 31 32 04 00 33 34 35 36
125 05 00 00 00 00 00 06 00 00 00 00 00 524B\n";
126 warn "D6 00 0F FE 00 00 05 01 E00401003123AA26 941A ##### ready?\n";
127
128 for ( 1 .. 3 ) {
129
130 # ++-->type 00-0a
131 # 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
132 # 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
133 # 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
134
135 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 $_" );
136 warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
137
138 }
139 warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
140
141 cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
142
143 cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
144 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
145 cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
146 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
147
148 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',
149 'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
150
151 undef $port;
152 print "Port closed\n";
153
154 sub writechunk
155 {
156 my $str=shift;
157 my $count = $port->write($str);
158 print "#> ", as_hex( $str ), "\t[$count]\n";
159 }
160
161 sub as_hex {
162 my @out;
163 foreach my $str ( @_ ) {
164 my $hex = unpack( 'H*', $str );
165 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
166 $hex =~ s/\s+$//;
167 push @out, $hex;
168 }
169 return join(' | ', @out);
170 }
171
172 sub read_bytes {
173 my ( $len, $desc ) = @_;
174 my $data = '';
175 while ( length( $data ) < $len ) {
176 my ( $c, $b ) = $port->read(1);
177 #warn "## got $c bytes: ", as_hex($b), "\n";
178 $data .= $b;
179 }
180 $desc ||= '?';
181 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
182 return $data;
183 }
184
185 our $assert;
186
187 # my $rest = skip_assert( 3 );
188 sub skip_assert {
189 assert( 0, shift );
190 }
191
192 sub assert {
193 my ( $from, $to ) = @_;
194
195 $from ||= 0;
196 $to = length( $assert->{expect} ) if ! defined $to;
197
198 my $p = substr( $assert->{payload}, $from, $to );
199 my $e = substr( $assert->{expect}, $from, $to );
200 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
201
202 # return the rest
203 return substr( $assert->{payload}, $to );
204 }
205
206 our $dispatch;
207 sub dispatch {
208 my ( $pattern, $coderef ) = @_;
209 my $patt = substr( str2bytes($pattern), 3 ); # just payload
210 my $l = length($patt);
211 my $p = substr( $assert->{payload}, 0, $l );
212 warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
213
214 if ( $assert->{payload} eq $assert->{expect} ) {
215 warn "## no dispatch, payload expected" if $debug;
216 } elsif ( $p eq $patt ) {
217 # if matched call with rest of payload
218 $coderef->( substr( $assert->{payload}, $l ) );
219 } else {
220 warn "## dispatch ignored" if $debug;
221 }
222 }
223
224 use Digest::CRC;
225
226 sub crcccitt {
227 my $bytes = shift;
228 my $crc = Digest::CRC->new(
229 # midified CCITT to xor with 0xffff instead of 0x0000
230 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
231 ) or die $!;
232 $crc->add( $bytes );
233 pack('n', $crc->digest);
234 }
235
236 # my $checksum = checksum( $bytes );
237 # my $checksum = checksum( $bytes, $original_checksum );
238 sub checksum {
239 my ( $bytes, $checksum ) = @_;
240
241 my $xor = crcccitt( substr($bytes,1) ); # skip D6
242 warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
243
244 if ( defined $checksum && $xor ne $checksum ) {
245 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
246 }
247 }
248
249 sub readchunk {
250 my ( $parser ) = @_;
251
252 sleep 1; # FIXME remove
253
254 # read header of packet
255 my $header = read_bytes( 2, 'header' );
256 my $length = read_bytes( 1, 'length' );
257 my $len = ord($length);
258 my $data = read_bytes( $len, 'data' );
259
260 my $payload = substr( $data, 0, -2 );
261 my $payload_len = length($data);
262 warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
263
264 my $checksum = substr( $data, -2, 2 );
265 checksum( $header . $length . $payload, $checksum );
266
267 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
268
269 $assert->{len} = $len;
270 $assert->{payload} = $payload;
271
272 $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
273
274 return $data;
275 }
276
277 sub str2bytes {
278 my $str = shift || confess "no str?";
279 my $b = $str;
280 $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum
281 $b =~ s/\s+$//;
282 $b =~ s/\s+/\\x/g;
283 $b = '"\x' . $b . '"';
284 my $bytes = eval $b;
285 die $@ if $@;
286 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
287 return $bytes;
288 }
289
290 sub cmd {
291 my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
292 my $bytes = str2bytes( $cmd );
293
294 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
295 $assert->{send} = $cmd;
296 writechunk( $bytes );
297
298 if ( $expect ) {
299 warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
300 $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
301 readchunk( $coderef );
302 }
303 }
304

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26