/[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

Annotation of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 27 - (hide annotations)
Mon Apr 6 11:21:15 2009 UTC (14 years, 11 months ago) by dpavlin
File MIME type: text/plain
File size: 12657 byte(s)
added timeout to meteor connect

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26