/[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 30 - (show annotations)
Mon Apr 6 13:18:55 2009 UTC (15 years ago) by dpavlin
File MIME type: text/plain
File size: 13252 byte(s)
program from file works now

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26