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

Diff of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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