/[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 25 - (show annotations)
Sun Mar 29 01:05:49 2009 UTC (15 years ago) by dpavlin
File MIME type: text/plain
File size: 12401 byte(s)
better protocol to communicate with meteor comet server

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 use Getopt::Long;
10
11 use IO::Socket::INET;
12
13 my $meteor_server = '192.168.1.13:4671';
14
15 my $meteor = IO::Socket::INET->new( $meteor_server )
16 || die "can't connect to meteor $meteor_server: $!";
17
18 sub meteor {
19 my @a = @_;
20 push @a, scalar localtime() if $a[0] =~ m{^info};
21
22 warn ">> meteor ",dump( @a );
23 print $meteor "ADDMESSAGE test ",join('|',@a),"\n";
24 }
25
26 my $debug = 0;
27
28 my $device = "/dev/ttyUSB0";
29 my $baudrate = "19200";
30 my $databits = "8";
31 my $parity = "none";
32 my $stopbits = "1";
33 my $handshake = "none";
34
35 my $response = {
36 'd500090400110a0500027250' => 'version?',
37 'd60007fe00000500c97b' => 'no tag in range',
38
39 'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
40 'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
41 'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
42
43 'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
44 'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
45 };
46
47 GetOptions(
48 'd|debug+' => \$debug,
49 'device=s' => \$device,
50 'baudrate=i' => \$baudrate,
51 'databits=i' => \$databits,
52 'parity=s' => \$parity,
53 'stopbits=i' => \$stopbits,
54 'handshake=s' => \$handshake,
55 ) or die $!;
56
57 my $verbose = $debug > 0 ? $debug-- : 0;
58
59 =head1 NAME
60
61 3m-810 - support for 3M 810 RFID reader
62
63 =head1 SYNOPSIS
64
65 3m-810.pl --device /dev/ttyUSB0
66
67 =head1 DESCRIPTION
68
69 Communicate with 3M 810 RFID reader and document it's protocol
70
71 =head1 SEE ALSO
72
73 L<Device::SerialPort(3)>
74
75 L<perl(1)>
76
77 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
78
79 =head1 AUTHOR
80
81 Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
82
83 =head1 COPYRIGHT AND LICENSE
84
85 This program is free software; you may redistribute it and/or modify
86 it under the same terms ans Perl itself.
87
88 =cut
89
90 my $tags_data;
91 my $visible_tags;
92
93 my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
94 warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
95 $handshake=$port->handshake($handshake);
96 $baudrate=$port->baudrate($baudrate);
97 $databits=$port->databits($databits);
98 $parity=$port->parity($parity);
99 $stopbits=$port->stopbits($stopbits);
100
101 print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
102
103 # Just in case: reset our timing and buffers
104 $port->lookclear();
105 $port->read_const_time(100);
106 $port->read_char_time(5);
107
108 # Turn on parity checking:
109 #$port->stty_inpck(1);
110 #$port->stty_istrip(1);
111
112 # initial hand-shake with device
113
114 cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
115 'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
116 my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
117 print "hardware version $hw_ver\n";
118 meteor( 'info', "Found reader hardware $hw_ver" );
119 });
120
121 cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?',
122 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } );
123
124 # start scanning for tags
125
126 cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags, retry $_",
127 'D6 00 0F FE 00 00 05 ', sub { # 01 E00401003123AA26 941A # seen, serial length: 8
128 my $rest = shift || die "no rest?";
129 my $nr = ord( substr( $rest, 0, 1 ) );
130
131 if ( ! $nr ) {
132 print "no tags in range\n";
133 update_visible_tags();
134 meteor( 'info-none-in-range' );
135 $tags_data = {};
136 } else {
137
138 my $tags = substr( $rest, 1 );
139
140 my $tl = length( $tags );
141 die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
142
143 my @tags;
144 push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
145 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
146 print "$nr tags in range: ", join(',', @tags ) , "\n";
147
148 meteor( 'info-in-range', join(' ',@tags));
149
150 update_visible_tags( @tags );
151 }
152 }
153 ) while(1);
154 #) foreach ( 1 .. 100 );
155
156
157
158 sub update_visible_tags {
159 my @tags = @_;
160
161 my $last_visible_tags = $visible_tags;
162 $visible_tags = {};
163
164 foreach my $tag ( @tags ) {
165 if ( ! defined $last_visible_tags->{$tag} ) {
166 if ( defined $tags_data->{$tag} ) {
167 # meteor( 'in-range', $tag );
168 } else {
169 meteor( 'read', $tag );
170 read_tag( $tag );
171 }
172 $visible_tags->{$tag}++;
173 } else {
174 warn "## using cached data for $tag" if $debug;
175 }
176 delete $last_visible_tags->{$tag}; # leave just missing tags
177 }
178
179 foreach my $tag ( keys %$last_visible_tags ) {
180 my $data = delete $tags_data->{$tag};
181 print "removed tag $tag with data ",dump( $data ),"\n";
182 meteor( 'removed', $tag );
183 }
184
185 warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
186 }
187
188
189 sub read_tag {
190 my ( $tag ) = @_;
191
192 confess "no tag?" unless $tag;
193
194 print "read_tag $tag\n";
195
196 cmd(
197 "D6 00 0D 02 $tag 00 03 1CC4", 'read $tag offset: 0 blocks: 3',
198 "D6 00 0F FE 00 00 05 01 $tag 941A", sub {
199 print "FIXME: tag $tag ready?\n";
200 },
201 "D6 00 1F 02 00", sub { # $tag 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n";
202 my $rest = shift || die "no rest?";
203 warn "## DATA ", dump( $rest ) if $debug;
204 my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
205 my $blocks = ord(substr($rest,8,1));
206 $rest = substr($rest,9); # leave just data blocks
207 my @data;
208 foreach my $nr ( 0 .. $blocks - 1 ) {
209 my $block = substr( $rest, $nr * 6, 6 );
210 warn "## block ",as_hex( $block ) if $debug;
211 my $ord = unpack('v',substr( $block, 0, 2 ));
212 die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
213 my $data = substr( $block, 2 );
214 die "data payload should be 4 bytes" if length($data) != 4;
215 warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
216 $data[ $ord ] = $data;
217 }
218 $tags_data->{ $tag } = join('', @data);
219 print "DATA $tag ",dump( $tags_data ), "\n";
220 }
221 );
222
223 # D6 00 1F 02 00 $tag 03 00 00 04 11 00 01 01 00 30 30 30 30 02 00 30 30 30 30 E5F4
224 if (0) {
225 cmd( "D6 00 0D 02 $tag 03 04 3970", 'read offset: 3 blocks: 4' );
226
227 # D6 00 25 02 00 $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
228 # $tag 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
229 warn "?? D6 00 25 02 00 $tag 04 03 00 39 30 31 32 04 00 ....\n";
230 }
231 warn "?? D6 00 0F FE 00 00 05 01 $tag 941A ##### ready?\n";
232
233 }
234
235 exit;
236
237 for ( 1 .. 3 ) {
238
239 # ++-->type 00-0a
240 # 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
241 # 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
242 # 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
243
244 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 $_" );
245 warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
246
247 }
248 warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
249
250 cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
251
252 cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
253 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
254 cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
255 'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
256
257 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',
258 'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
259
260 undef $port;
261 print "Port closed\n";
262
263 sub writechunk
264 {
265 my $str=shift;
266 my $count = $port->write($str);
267 print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
268 }
269
270 sub as_hex {
271 my @out;
272 foreach my $str ( @_ ) {
273 my $hex = unpack( 'H*', $str );
274 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
275 $hex =~ s/\s+$//;
276 push @out, $hex;
277 }
278 return join(' | ', @out);
279 }
280
281 sub read_bytes {
282 my ( $len, $desc ) = @_;
283 my $data = '';
284 while ( length( $data ) < $len ) {
285 my ( $c, $b ) = $port->read(1);
286 #warn "## got $c bytes: ", as_hex($b), "\n";
287 $data .= $b;
288 }
289 $desc ||= '?';
290 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
291 return $data;
292 }
293
294 our $assert;
295
296 # my $rest = skip_assert( 3 );
297 sub skip_assert {
298 assert( 0, shift );
299 }
300
301 sub assert {
302 my ( $from, $to ) = @_;
303
304 $from ||= 0;
305 $to = length( $assert->{expect} ) if ! defined $to;
306
307 my $p = substr( $assert->{payload}, $from, $to );
308 my $e = substr( $assert->{expect}, $from, $to );
309 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
310
311 # return the rest
312 return substr( $assert->{payload}, $to );
313 }
314
315 use Digest::CRC;
316
317 sub crcccitt {
318 my $bytes = shift;
319 my $crc = Digest::CRC->new(
320 # midified CCITT to xor with 0xffff instead of 0x0000
321 width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
322 ) or die $!;
323 $crc->add( $bytes );
324 pack('n', $crc->digest);
325 }
326
327 # my $checksum = checksum( $bytes );
328 # my $checksum = checksum( $bytes, $original_checksum );
329 sub checksum {
330 my ( $bytes, $checksum ) = @_;
331
332 my $xor = crcccitt( substr($bytes,1) ); # skip D6
333 warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
334
335 my $len = ord(substr($bytes,2,1));
336 my $len_real = length($bytes) - 1;
337
338 if ( $len_real != $len ) {
339 print "length wrong: $len_real != $len\n";
340 $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
341 }
342
343 if ( defined $checksum && $xor ne $checksum ) {
344 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
345 return $bytes . $xor;
346 }
347 return $bytes . $checksum;
348 }
349
350 our $dispatch;
351
352 sub readchunk {
353 sleep 1; # FIXME remove
354
355 # read header of packet
356 my $header = read_bytes( 2, 'header' );
357 my $length = read_bytes( 1, 'length' );
358 my $len = ord($length);
359 my $data = read_bytes( $len, 'data' );
360
361 my $payload = substr( $data, 0, -2 );
362 my $payload_len = length($data);
363 warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
364
365 my $checksum = substr( $data, -2, 2 );
366 checksum( $header . $length . $payload , $checksum );
367
368 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
369
370 $assert->{len} = $len;
371 $assert->{payload} = $payload;
372
373 my $full = $header . $length . $data; # full
374 # find longest match for incomming data
375 my ($to) = grep {
376 my $match = substr($payload,0,length($_));
377 m/^\Q$match\E/
378 } sort { length($a) <=> length($b) } keys %$dispatch;
379 warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
380
381 if ( defined $to ) {
382 my $rest = substr( $payload, length($to) );
383 warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
384 $dispatch->{ $to }->( $rest );
385 } else {
386 print "NO DISPATCH for ",dump( $full ),"\n";
387 }
388
389 return $data;
390 }
391
392 sub str2bytes {
393 my $str = shift || confess "no str?";
394 my $b = $str;
395 $b =~ s/\s+//g;
396 $b =~ s/(..)/\\x$1/g;
397 $b = "\"$b\"";
398 my $bytes = eval $b;
399 die $@ if $@;
400 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
401 return $bytes;
402 }
403
404 sub cmd {
405 my $cmd = shift || confess "no cmd?";
406 my $cmd_desc = shift || confess "no description?";
407 my @expect = @_;
408
409 my $bytes = str2bytes( $cmd );
410
411 # fix checksum if needed
412 $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
413
414 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
415 $assert->{send} = $cmd;
416 writechunk( $bytes );
417
418 while ( @expect ) {
419 my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
420 my $coderef = shift @expect || confess "no coderef?";
421 confess "not coderef" unless ref $coderef eq 'CODE';
422
423 next if defined $dispatch->{ $pattern };
424
425 $dispatch->{ substr($pattern,3) } = $coderef;
426 warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
427 }
428
429 readchunk;
430 }
431

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26