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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26