/[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 42 - (show annotations)
Thu Jun 4 13:52:10 2009 UTC (14 years, 9 months ago) by dpavlin
File MIME type: text/plain
File size: 15671 byte(s)
return *next* block to read from read_tag_data
cleanup dispatcher (which is still a mess)

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26