/[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 28 by dpavlin, Mon Apr 6 12:36:22 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    my $meteor_fh;
15    
16    sub meteor {
17            my @a = @_;
18            push @a, scalar localtime() if $a[0] =~ m{^info};
19    
20            if ( ! defined $meteor_fh ) {
21                    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                    $meteor_fh = 0; # don't try again
27            }
28    
29            warn ">> meteor ",dump( @a );
30            print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
31    }
32    
33    my $debug = 0;
34    
35    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  my $response = {  my $response = {
43          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 18  my $response = { Line 51  my $response = {
51          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
52  };  };
53    
54    GetOptions(
55            'd|debug+'    => \$debug,
56            'device=s'    => \$device,
57            'baudrate=i'  => \$baudrate,
58            'databits=i'  => \$databits,
59            'parity=s'    => \$parity,
60            'stopbits=i'  => \$stopbits,
61            'handshake=s' => \$handshake,
62            'meteor=s'    => \$meteor_server,
63    ) or die $!;
64    
65    my $verbose = $debug > 0 ? $debug-- : 0;
66    
67  =head1 NAME  =head1 NAME
68    
69  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
70    
71  =head1 SYNOPSIS  =head1 SYNOPSIS
72    
73  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 36  L<Device::SerialPort(3)> Line 82  L<Device::SerialPort(3)>
82    
83  L<perl(1)>  L<perl(1)>
84    
85    L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
86    
87  =head1 AUTHOR  =head1 AUTHOR
88    
89  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 95  it under the same terms ans Perl itself.
95    
96  =cut  =cut
97    
98  # your serial port.  my $tags_data;
99  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  my $visible_tags;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
100    
101  my $port=new Device::SerialPort($device) || die "new($device): $!\n";  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  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
104  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
105  $databits=$port->databits($databits);  $databits=$port->databits($databits);
106  $parity=$port->parity($parity);  $parity=$port->parity($parity);
107  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
108    
109  print "## using $device $baudrate $databits $parity $stopbits\n";  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
110    
111  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
112  $port->lookclear();  $port->lookclear();
# Line 74  $port->read_char_time(5); Line 117  $port->read_char_time(5);
117  #$port->stty_inpck(1);  #$port->stty_inpck(1);
118  #$port->stty_istrip(1);  #$port->stty_istrip(1);
119    
120  sub cmd {  # initial hand-shake with device
121          my ( $cmd, $desc, $expect ) = @_;  
122          $cmd =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;  # fix checksum  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
123          $cmd =~ s/\s+/\\x/g;       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
124          $cmd = '"\x' . $cmd . '"';          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
125          my $bytes = eval $cmd;          print "hardware version $hw_ver\n";
126          die $@ if $@;          meteor( 'info', "Found reader hardware $hw_ver" );
127          warn ">> ", as_hex( $bytes ), "\t$desc\n";  });
128          writechunk( $bytes );  
129          warn "?? $expect\n" if $expect;  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
130          readchunk();       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
131    
132    # start scanning for tags
133    
134    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                            update_visible_tags();
142                            meteor( 'info-none-in-range' );
143                            $tags_data = {};
144                    } else {
145    
146                            my $tags = substr( $rest, 1 );
147    
148                            my $tl = length( $tags );
149                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
150    
151                            my @tags;
152                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
153                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
154                            print "$nr tags in range: ", join(',', @tags ) , "\n";
155    
156                            meteor( 'info-in-range', join(' ',@tags));
157    
158                            update_visible_tags( @tags );
159                    }
160            }
161    ) while(1);
162    #) foreach ( 1 .. 100 );
163    
164    
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                            if ( defined $tags_data->{$tag} ) {
175    #                               meteor( 'in-range', $tag );
176                            } else {
177                                    meteor( 'read', $tag );
178                                    read_tag( $tag );
179                            }
180                            $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                    my $data = delete $tags_data->{$tag};
189                    print "removed tag $tag with data ",dump( $data ),"\n";
190                    meteor( 'removed', $tag );
191            }
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  cmd( 'D5 00  05  04   00   11                 8C66', 'hw version?',  my $tag_data_block;
      'D5 00  09  04   00   11   0A 05 00 02   7250 -- hw 10.5.0.2' );  
197    
198  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  sub read_tag_data {
199  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778          my ($start_block,$rest) = @_;
200            die "no rest?" unless $rest;
201            warn "## DATA [$start_block] ", dump( $rest ) if $debug;
202            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
203            my $blocks = ord(substr($rest,8,1));
204            $rest = substr($rest,9); # leave just data blocks
205            foreach my $nr ( 0 .. $blocks - 1 ) {
206                    my $block = substr( $rest, $nr * 6, 6 );
207                    warn "## block ",as_hex( $block ) if $debug;
208                    my $ord   = unpack('v',substr( $block, 0, 2 ));
209                    my $expected_ord = $nr + $start_block;
210                    die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
211                    my $data  = substr( $block, 2 );
212                    die "data payload should be 4 bytes" if length($data) != 4;
213                    warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
214                    $tag_data_block->{$tag}->[ $ord ] = $data;
215            }
216            $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
217            print "DATA $tag ",dump( $tags_data ), "\n";
218    }
219    
220  cmd( 'D6 00  05  FE     00  05  FA40', "XXX scan $_",  sub read_tag {
221       'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );          my ( $tag ) = @_;
222    
223  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen          confess "no tag?" unless $tag;
224    
225  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          print "read_tag $tag\n";
226    
227  #     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          cmd(
228  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";                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
229                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
230                            print "FIXME: tag $tag ready?\n";
231                    },
232                    "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";
233                            read_tag_data( 0, @_ );
234                    },
235            );
236    
237            cmd(
238                    "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
239                    "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
240                            read_tag_data( 3, @_ );
241                    }
242            );
243    
244  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );  }
245    
246  #     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";  
247    
248  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
249    
# Line 140  print "Port closed\n"; Line 274  print "Port closed\n";
274  sub writechunk  sub writechunk
275  {  {
276          my $str=shift;          my $str=shift;
   
277          my $count = $port->write($str);          my $count = $port->write($str);
278          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
279  }  }
280    
281  sub as_hex {  sub as_hex {
282          my @out;          my @out;
283          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
284                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
285                  $hex =~ s/(..)/$1 /g;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
286                    $hex =~ s/\s+$//;
287                  push @out, $hex;                  push @out, $hex;
288          }          }
289          return join('  ', @out);          return join(' | ', @out);
290  }  }
291    
292  sub read_bytes {  sub read_bytes {
# Line 160  sub read_bytes { Line 294  sub read_bytes {
294          my $data = '';          my $data = '';
295          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
296                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
297                    die "no bytes on port: $!" unless defined $b;
298                  #warn "## got $c bytes: ", as_hex($b), "\n";                  #warn "## got $c bytes: ", as_hex($b), "\n";
299                  $data .= $b;                  $data .= $b;
300          }          }
301          $desc ||= '?';          $desc ||= '?';
302          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
303          return $data;          return $data;
304  }  }
305    
306    our $assert;
307    
308    # my $rest = skip_assert( 3 );
309    sub skip_assert {
310            assert( 0, shift );
311    }
312    
313    sub assert {
314            my ( $from, $to ) = @_;
315    
316            $from ||= 0;
317            $to = length( $assert->{expect} ) if ! defined $to;
318    
319            my $p = substr( $assert->{payload}, $from, $to );
320            my $e = substr( $assert->{expect},  $from, $to );
321            warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
322    
323            # return the rest
324            return substr( $assert->{payload}, $to );
325    }
326    
327    use Digest::CRC;
328    
329    sub crcccitt {
330            my $bytes = shift;
331            my $crc = Digest::CRC->new(
332                    # midified CCITT to xor with 0xffff instead of 0x0000
333                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
334            ) or die $!;
335            $crc->add( $bytes );
336            pack('n', $crc->digest);
337    }
338    
339    # my $checksum = checksum( $bytes );
340    # my $checksum = checksum( $bytes, $original_checksum );
341    sub checksum {
342            my ( $bytes, $checksum ) = @_;
343    
344            my $xor = crcccitt( substr($bytes,1) ); # skip D6
345            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
346    
347            my $len = ord(substr($bytes,2,1));
348            my $len_real = length($bytes) - 1;
349    
350            if ( $len_real != $len ) {
351                    print "length wrong: $len_real != $len\n";
352                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
353            }
354    
355            if ( defined $checksum && $xor ne $checksum ) {
356                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
357                    return $bytes . $xor;
358            }
359            return $bytes . $checksum;
360    }
361    
362    our $dispatch;
363    
364  sub readchunk {  sub readchunk {
365            sleep 1;        # FIXME remove
366    
367          # read header of packet          # read header of packet
368          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
369          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
370            my $len = ord($length);
371          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
372    
373          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
374            my $payload_len = length($data);
375            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
376    
377            my $checksum = substr( $data, -2, 2 );
378            checksum( $header . $length . $payload , $checksum );
379    
380            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
381    
382            $assert->{len}      = $len;
383            $assert->{payload}  = $payload;
384    
385            my $full = $header . $length . $data; # full
386            # find longest match for incomming data
387            my ($to) = grep {
388                    my $match = substr($payload,0,length($_));
389                    m/^\Q$match\E/
390            } sort { length($a) <=> length($b) } keys %$dispatch;
391            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
392    
393            if ( defined $to ) {
394                    my $rest = substr( $payload, length($to) );
395                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
396                    $dispatch->{ $to }->( $rest );
397            } else {
398                    print "NO DISPATCH for ",dump( $full ),"\n";
399            }
400    
401            return $data;
402    }
403    
404    sub str2bytes {
405            my $str = shift || confess "no str?";
406            my $b = $str;
407            $b =~ s/\s+//g;
408            $b =~ s/(..)/\\x$1/g;
409            $b = "\"$b\"";
410            my $bytes = eval $b;
411            die $@ if $@;
412            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
413            return $bytes;
414    }
415    
416    sub cmd {
417            my $cmd = shift || confess "no cmd?";
418            my $cmd_desc = shift || confess "no description?";
419            my @expect = @_;
420    
421            my $bytes = str2bytes( $cmd );
422    
423            # fix checksum if needed
424            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
425    
426            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
427            $assert->{send} = $cmd;
428            writechunk( $bytes );
429    
430            while ( @expect ) {
431                    my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
432                    my $coderef = shift @expect || confess "no coderef?";
433                    confess "not coderef" unless ref $coderef eq 'CODE';
434    
435                    next if defined $dispatch->{ $pattern };
436    
437                    $dispatch->{ substr($pattern,3) } = $coderef;
438                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
439            }
440    
441          sleep 1;          readchunk;
442  }  }
443    
Legend:
Removed from v.1  
changed lines
  Added in v.28
  ViewVC Help
Powered by ViewVC 1.1.26