/[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 17 - (hide annotations)
Fri Oct 3 08:53:57 2008 UTC (15 years, 6 months ago) by dpavlin
File MIME type: text/plain
File size: 9625 byte(s)
First custom packet sent to device :-)

- fix length if invalid
- str2bytes now support long hex numbers (for tags)
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 1
10 dpavlin 4 my $debug = 0;
11    
12 dpavlin 1 my $response = {
13     'd500090400110a0500027250' => 'version?',
14     'd60007fe00000500c97b' => 'no tag in range',
15    
16     'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
17     'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
18     'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
19    
20     'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
21     'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
22     };
23    
24     =head1 NAME
25    
26     3m-810 - support for 3M 810 RFID reader
27    
28     =head1 SYNOPSIS
29    
30     3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]
31    
32     =head1 DESCRIPTION
33    
34     Communicate with 3M 810 RFID reader and document it's protocol
35    
36     =head1 SEE ALSO
37    
38     L<Device::SerialPort(3)>
39    
40     L<perl(1)>
41    
42 dpavlin 15 L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
43    
44 dpavlin 1 =head1 AUTHOR
45    
46     Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
47    
48     =head1 COPYRIGHT AND LICENSE
49    
50     This program is free software; you may redistribute it and/or modify
51     it under the same terms ans Perl itself.
52    
53     =cut
54    
55     # your serial port.
56     my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;
57     $device ||= "/dev/ttyUSB0";
58     $baudrate ||= "19200";
59     $databits ||= "8";
60     $parity ||= "none";
61     $stopbits ||= "1";
62     $handshake ||= "none";
63    
64     my $port=new Device::SerialPort($device) || die "new($device): $!\n";
65     $handshake=$port->handshake($handshake);
66     $baudrate=$port->baudrate($baudrate);
67     $databits=$port->databits($databits);
68     $parity=$port->parity($parity);
69     $stopbits=$port->stopbits($stopbits);
70    
71     print "## using $device $baudrate $databits $parity $stopbits\n";
72    
73     # Just in case: reset our timing and buffers
74     $port->lookclear();
75     $port->read_const_time(100);
76     $port->read_char_time(5);
77    
78     # Turn on parity checking:
79     #$port->stty_inpck(1);
80     #$port->stty_istrip(1);
81    
82 dpavlin 4 # initial hand-shake with device
83    
84     cmd( 'D5 00 05 04 00 11 8C66', 'hw version?',
85     'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub {
86 dpavlin 5 print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
87 dpavlin 2 });
88 dpavlin 1
89 dpavlin 4 cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?',
90 dpavlin 5 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert() } );
91 dpavlin 1
92 dpavlin 4 # start scanning for tags
93 dpavlin 1
94 dpavlin 5 cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_",
95     'D6 00 07 FE 00 00 05 00 C97B', 'no tag', sub {
96     dispatch(
97     'D6 00 0F FE 00 00 05 ',# 01 E00401003123AA26 941A # seen, serial length: 8
98     sub {
99     my $rest = shift || die "no rest?";
100     my $nr = ord( substr( $rest, 0, 1 ) );
101     my $tags = substr( $rest, 1 );
102 dpavlin 1
103 dpavlin 5 my $tl = length( $tags );
104     die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
105    
106     my @tags;
107 dpavlin 16 push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
108 dpavlin 8 warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
109 dpavlin 16 print "seen $nr tags: ", join(',', @tags ) , "\n";
110    
111     # XXX read first tag
112     read_tag( @tags );
113    
114 dpavlin 5 }
115     ) }
116    
117     ) foreach ( 1 .. 100 );
118    
119 dpavlin 16 my $read_cached;
120 dpavlin 1
121 dpavlin 16 sub read_tag {
122     my ( $tag ) = @_;
123 dpavlin 1
124 dpavlin 16 print "read_tag $tag\n";
125     return if $read_cached->{ $tag }++;
126 dpavlin 1
127 dpavlin 16 cmd( "D6 00 0D 02 $tag 00 03 1CC4", 'read offset: 0 blocks: 3' );
128 dpavlin 1
129 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
130     warn "?? D6 00 1F 02 00 $tag 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n";
131     if (0) {
132     cmd( "D6 00 0D 02 $tag 03 04 3970", 'read offset: 3 blocks: 4' );
133    
134     # D6 00 25 02 00 $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
135     # $tag 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
136     warn "?? D6 00 25 02 00 $tag 04 03 00 39 30 31 32 04 00 ....\n";
137     }
138     warn "?? D6 00 0F FE 00 00 05 01 $tag 941A ##### ready?\n";
139    
140     }
141    
142 dpavlin 1 for ( 1 .. 3 ) {
143    
144     # ++-->type 00-0a
145     # 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
146     # 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
147     # 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
148    
149     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 $_" );
150     warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
151    
152     }
153     warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
154    
155     cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
156    
157     cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
158     'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
159     cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
160     'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
161    
162     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',
163     'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
164    
165     undef $port;
166     print "Port closed\n";
167    
168     sub writechunk
169     {
170     my $str=shift;
171     my $count = $port->write($str);
172 dpavlin 6 print "#> ", as_hex( $str ), "\t[$count]\n";
173 dpavlin 1 }
174    
175     sub as_hex {
176     my @out;
177     foreach my $str ( @_ ) {
178     my $hex = unpack( 'H*', $str );
179 dpavlin 2 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
180 dpavlin 8 $hex =~ s/\s+$//;
181 dpavlin 1 push @out, $hex;
182     }
183 dpavlin 8 return join(' | ', @out);
184 dpavlin 1 }
185    
186     sub read_bytes {
187     my ( $len, $desc ) = @_;
188     my $data = '';
189     while ( length( $data ) < $len ) {
190     my ( $c, $b ) = $port->read(1);
191     #warn "## got $c bytes: ", as_hex($b), "\n";
192     $data .= $b;
193     }
194     $desc ||= '?';
195 dpavlin 4 warn "#< ", as_hex($data), "\t$desc\n" if $debug;
196 dpavlin 1 return $data;
197     }
198    
199 dpavlin 5 our $assert;
200 dpavlin 2
201 dpavlin 5 # my $rest = skip_assert( 3 );
202     sub skip_assert {
203     assert( 0, shift );
204     }
205    
206 dpavlin 2 sub assert {
207     my ( $from, $to ) = @_;
208    
209 dpavlin 5 $from ||= 0;
210 dpavlin 4 $to = length( $assert->{expect} ) if ! defined $to;
211    
212 dpavlin 2 my $p = substr( $assert->{payload}, $from, $to );
213     my $e = substr( $assert->{expect}, $from, $to );
214 dpavlin 3 warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
215 dpavlin 5
216     # return the rest
217     return substr( $assert->{payload}, $to );
218 dpavlin 2 }
219    
220 dpavlin 5 our $dispatch;
221     sub dispatch {
222     my ( $pattern, $coderef ) = @_;
223     my $patt = substr( str2bytes($pattern), 3 ); # just payload
224     my $l = length($patt);
225     my $p = substr( $assert->{payload}, 0, $l );
226 dpavlin 6 warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
227 dpavlin 5
228     if ( $assert->{payload} eq $assert->{expect} ) {
229 dpavlin 6 warn "## no dispatch, payload expected" if $debug;
230 dpavlin 5 } elsif ( $p eq $patt ) {
231     # if matched call with rest of payload
232     $coderef->( substr( $assert->{payload}, $l ) );
233     } else {
234 dpavlin 6 warn "## dispatch ignored" if $debug;
235 dpavlin 5 }
236     }
237    
238 dpavlin 15 use Digest::CRC;
239    
240     sub crcccitt {
241     my $bytes = shift;
242     my $crc = Digest::CRC->new(
243     # midified CCITT to xor with 0xffff instead of 0x0000
244     width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
245     ) or die $!;
246     $crc->add( $bytes );
247     pack('n', $crc->digest);
248     }
249    
250 dpavlin 8 # my $checksum = checksum( $bytes );
251     # my $checksum = checksum( $bytes, $original_checksum );
252     sub checksum {
253     my ( $bytes, $checksum ) = @_;
254    
255 dpavlin 15 my $xor = crcccitt( substr($bytes,1) ); # skip D6
256     warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
257 dpavlin 10
258 dpavlin 16 my $len = ord(substr($bytes,2,1));
259 dpavlin 17 my $len_real = length($bytes) - 1;
260 dpavlin 16
261 dpavlin 17 if ( $len_real != $len ) {
262     print "length wrong: $len_real != $len\n";
263     $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
264     }
265    
266 dpavlin 8 if ( defined $checksum && $xor ne $checksum ) {
267 dpavlin 10 print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
268 dpavlin 16 return $bytes . $xor;
269 dpavlin 8 }
270 dpavlin 16 return $bytes . $checksum;
271 dpavlin 8 }
272    
273 dpavlin 1 sub readchunk {
274 dpavlin 2 my ( $parser ) = @_;
275 dpavlin 1
276 dpavlin 2 sleep 1; # FIXME remove
277    
278 dpavlin 1 # read header of packet
279     my $header = read_bytes( 2, 'header' );
280 dpavlin 2 my $length = read_bytes( 1, 'length' );
281     my $len = ord($length);
282 dpavlin 1 my $data = read_bytes( $len, 'data' );
283    
284 dpavlin 2 my $payload = substr( $data, 0, -2 );
285     my $payload_len = length($data);
286     warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
287 dpavlin 8
288 dpavlin 2 my $checksum = substr( $data, -2, 2 );
289 dpavlin 8 checksum( $header . $length . $payload, $checksum );
290 dpavlin 1
291 dpavlin 8 print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
292 dpavlin 2
293     $assert->{len} = $len;
294     $assert->{payload} = $payload;
295    
296 dpavlin 8 $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
297 dpavlin 2
298     return $data;
299 dpavlin 1 }
300    
301 dpavlin 2 sub str2bytes {
302     my $str = shift || confess "no str?";
303 dpavlin 5 my $b = $str;
304 dpavlin 17 $b =~ s/\s+//g;
305     $b =~ s/(..)/\\x$1/g;
306     $b = "\"$b\"";
307 dpavlin 5 my $bytes = eval $b;
308 dpavlin 2 die $@ if $@;
309 dpavlin 5 warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
310 dpavlin 2 return $bytes;
311     }
312    
313     sub cmd {
314     my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
315     my $bytes = str2bytes( $cmd );
316    
317 dpavlin 16 # fix checksum if needed
318     $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
319    
320 dpavlin 2 warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
321     $assert->{send} = $cmd;
322     writechunk( $bytes );
323    
324     if ( $expect ) {
325     warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
326     $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
327     readchunk( $coderef );
328     }
329     }
330    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26