/[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 17 by dpavlin, Fri Oct 3 08:53:57 2008 UTC revision 27 by dpavlin, Mon Apr 6 11:21:15 2009 UTC
# Line 6  use warnings; Line 6  use warnings;
6    
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  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;  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?',
44          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  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 52  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 81  $port->read_char_time(5); Line 119  $port->read_char_time(5);
119    
120  # initial hand-shake with device  # initial hand-shake with device
121    
122  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
123       'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
124          print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
125            print "hardware version $hw_ver\n";
126            meteor( 'info', "Found reader hardware $hw_ver" );
127  });  });
128    
129  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','stats?',  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','FIXME: unimplemented', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
131    
132  # start scanning for tags  # start scanning for tags
133    
134  cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
135       'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
136  dispatch(                  my $rest = shift || die "no rest?";
137           'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8                  my $nr = ord( substr( $rest, 0, 1 ) );
138                  sub {  
139                          my $rest = shift || die "no rest?";                  if ( ! $nr ) {
140                          my $nr = ord( substr( $rest, 0, 1 ) );                          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 );                          my $tags = substr( $rest, 1 );
147    
148                          my $tl = length( $tags );                          my $tl = length( $tags );
# Line 106  dispatch( Line 151  dispatch(
151                          my @tags;                          my @tags;
152                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
153                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
154                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          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    
                         # XXX read first tag  
                         read_tag( @tags );  
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 ( 1 .. 100 );          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    
 my $read_cached;  
196    
197  sub read_tag {  sub read_tag {
198          my ( $tag ) = @_;          my ( $tag ) = @_;
199    
200            confess "no tag?" unless $tag;
201    
202          print "read_tag $tag\n";          print "read_tag $tag\n";
         return if $read_cached->{ $tag }++;  
203    
204          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          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                            my $rest = shift || die "no rest?";
211                            warn "## DATA ", dump( $rest ) if $debug;
212                            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                            my @data;
216                            foreach my $nr ( 0 .. $blocks - 1 ) {
217                                    my $block = substr( $rest, $nr * 6, 6 );
218                                    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                            $tags_data->{ $tag } = join('', @data);
227                            print "DATA $tag ",dump( $tags_data ), "\n";
228                    }
229            );
230    
231          #        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          #        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
         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";  
232  if (0) {  if (0) {
233          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );          cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
234    
# Line 139  if (0) { Line 240  if (0) {
240    
241  }  }
242    
243    exit;
244    
245  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
246    
247  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  sub writechunk Line 272  sub writechunk
272  {  {
273          my $str=shift;          my $str=shift;
274          my $count = $port->write($str);          my $count = $port->write($str);
275          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
276  }  }
277    
278  sub as_hex {  sub as_hex {
# Line 217  sub assert { Line 320  sub assert {
320          return substr( $assert->{payload}, $to );          return substr( $assert->{payload}, $to );
321  }  }
322    
 our $dispatch;  
 sub dispatch {  
         my ( $pattern, $coderef ) = @_;  
         my $patt = substr( str2bytes($pattern), 3 ); # just payload  
         my $l = length($patt);  
         my $p = substr( $assert->{payload}, 0, $l );  
         warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;  
   
         if ( $assert->{payload} eq $assert->{expect} ) {  
                 warn "## no dispatch, payload expected" if $debug;  
         } elsif ( $p eq $patt ) {  
                 # if matched call with rest of payload  
                 $coderef->( substr( $assert->{payload}, $l ) );  
         } else {  
                 warn "## dispatch ignored" if $debug;  
         }  
 }  
   
323  use Digest::CRC;  use Digest::CRC;
324    
325  sub crcccitt {  sub crcccitt {
# Line 270  sub checksum { Line 355  sub checksum {
355          return $bytes . $checksum;          return $bytes . $checksum;
356  }  }
357    
358  sub readchunk {  our $dispatch;
         my ( $parser ) = @_;  
359    
360    sub readchunk {
361          sleep 1;        # FIXME remove          sleep 1;        # FIXME remove
362    
363          # read header of packet          # read header of packet
# Line 286  sub readchunk { Line 371  sub readchunk {
371          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;          warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
372    
373          my $checksum = substr( $data, -2, 2 );          my $checksum = substr( $data, -2, 2 );
374          checksum( $header . $length . $payload, $checksum );          checksum( $header . $length . $payload , $checksum );
375    
376          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";          print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
377    
378          $assert->{len}      = $len;          $assert->{len}      = $len;
379          $assert->{payload}  = $payload;          $assert->{payload}  = $payload;
380    
381          $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';          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    
389            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          return $data;          return $data;
398  }  }
# Line 311  sub str2bytes { Line 410  sub str2bytes {
410  }  }
411    
412  sub cmd {  sub cmd {
413          my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;          my $cmd = shift || confess "no cmd?";
414            my $cmd_desc = shift || confess "no description?";
415            my @expect = @_;
416    
417          my $bytes = str2bytes( $cmd );          my $bytes = str2bytes( $cmd );
418    
419          # fix checksum if needed          # fix checksum if needed
420          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );          $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
421    
422          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";          warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
423          $assert->{send} = $cmd;          $assert->{send} = $cmd;
424          writechunk( $bytes );          writechunk( $bytes );
425    
426          if ( $expect ) {          while ( @expect ) {
427                  warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";                  my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
428                  $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload                  my $coderef = shift @expect || confess "no coderef?";
429                  readchunk( $coderef );                  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          }          }
436    
437            readchunk;
438  }  }
439    
Legend:
Removed from v.17  
changed lines
  Added in v.27
  ViewVC Help
Powered by ViewVC 1.1.26