/[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 16 by dpavlin, Thu Oct 2 22:53:57 2008 UTC revision 19 by dpavlin, Fri Oct 3 15:38:08 2008 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  my $debug = 0;  my $debug = 0;
12    
13    my $device    = "/dev/ttyUSB0";
14    my $baudrate  = "19200";
15    my $databits  = "8";
16    my $parity        = "none";
17    my $stopbits  = "1";
18    my $handshake = "none";
19    
20  my $response = {  my $response = {
21          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
22          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 21  my $response = { Line 29  my $response = {
29          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',          'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
30  };  };
31    
32    GetOptions(
33            'd|debug+'      => \$debug,
34            'device=s'    => \$device,
35            'baudrate=i'  => \$baudrate,
36            'databits=i'  => \$databits,
37            'parity=s'    => \$parity,
38            'stopbits=i'  => \$stopbits,
39            'handshake=s' => \$handshake,
40    ) or die $!;
41    
42  =head1 NAME  =head1 NAME
43    
44  3m-810 - support for 3M 810 RFID reader  3m-810 - support for 3M 810 RFID reader
45    
46  =head1 SYNOPSIS  =head1 SYNOPSIS
47    
48  3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]  3m-810.pl --device /dev/ttyUSB0
49    
50  =head1 DESCRIPTION  =head1 DESCRIPTION
51    
# Line 52  it under the same terms ans Perl itself. Line 70  it under the same terms ans Perl itself.
70    
71  =cut  =cut
72    
73  # your serial port.  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
74  my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
 $device    ||= "/dev/ttyUSB0";  
 $baudrate  ||= "19200";  
 $databits  ||= "8";  
 $parity    ||= "none";  
 $stopbits  ||= "1";  
 $handshake ||= "none";  
   
 my $port=new Device::SerialPort($device) || die "new($device): $!\n";  
75  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
76  $baudrate=$port->baudrate($baudrate);  $baudrate=$port->baudrate($baudrate);
77  $databits=$port->databits($databits);  $databits=$port->databits($databits);
# Line 108  dispatch( Line 118  dispatch(
118                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
119                          print "seen $nr tags: ", join(',', @tags ) , "\n";                          print "seen $nr tags: ", join(',', @tags ) , "\n";
120    
121                          # XXX read first tag                          # read data from tag
122                          read_tag( @tags );                          read_tag( $_ ) foreach @tags;
123    
124                  }                  }
125  ) }  ) }
# Line 124  sub read_tag { Line 134  sub read_tag {
134          print "read_tag $tag\n";          print "read_tag $tag\n";
135          return if $read_cached->{ $tag }++;          return if $read_cached->{ $tag }++;
136    
137          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );          cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read $tag offset: 0 blocks: 3',
138                            "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {
139    dispatch(       "D6 00  1F  02 00   $tag   ", sub { # 03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
140                            my $rest = shift || die "no rest?";
141                            warn "## DATA ", dump( $rest ) if $debug;
142                            my $blocks = ord(substr($rest,0,1));
143                            my @data;
144                            foreach my $nr ( 0 .. $blocks - 1 ) {
145                                    my $block = substr( $rest, 1 + $nr * 6, 6 );
146                                    warn "## block ",as_hex( $block ) if $debug;
147                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
148                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
149                                    my $data  = substr( $block, 2 );
150                                    die "data payload should be 4 bytes" if length($data) != 4;
151                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
152                                    $data[ $ord ] = $data;
153                            }
154                            $read_cached->{ $tag } = join('', @data);
155                            print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";
156                    })
157            });
158    
159          #        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";  
160  if (0) {  if (0) {
161          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' );
162    
# Line 139  if (0) { Line 168  if (0) {
168    
169  }  }
170    
171    exit;
172    
173  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
174    
175  #                                                              ++-->type 00-0a  #                                                              ++-->type 00-0a
# Line 169  sub writechunk Line 200  sub writechunk
200  {  {
201          my $str=shift;          my $str=shift;
202          my $count = $port->write($str);          my $count = $port->write($str);
203          print "#> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
204  }  }
205    
206  sub as_hex {  sub as_hex {
# Line 220  sub assert { Line 251  sub assert {
251  our $dispatch;  our $dispatch;
252  sub dispatch {  sub dispatch {
253          my ( $pattern, $coderef ) = @_;          my ( $pattern, $coderef ) = @_;
254    
255            $dispatch->{ $pattern } = $coderef;
256    
257          my $patt = substr( str2bytes($pattern), 3 ); # just payload          my $patt = substr( str2bytes($pattern), 3 ); # just payload
258          my $l = length($patt);          my $l = length($patt);
259          my $p = substr( $assert->{payload}, 0, $l );          my $p = substr( $assert->{payload}, 0, $l );
# Line 256  sub checksum { Line 290  sub checksum {
290          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
291    
292          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
293          my $len_real = length($bytes);          my $len_real = length($bytes) - 1;
294          print "length wrong: $len_real != $len\n" if $len_real != $len;  
295            if ( $len_real != $len ) {
296                    print "length wrong: $len_real != $len\n";
297                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
298            }
299    
300          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
301                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
# Line 297  sub readchunk { Line 335  sub readchunk {
335  sub str2bytes {  sub str2bytes {
336          my $str = shift || confess "no str?";          my $str = shift || confess "no str?";
337          my $b = $str;          my $b = $str;
338          $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum          $b =~ s/\s+//g;
339          $b =~ s/\s+$//;          $b =~ s/(..)/\\x$1/g;
340          $b =~ s/\s+/\\x/g;          $b = "\"$b\"";
         $b = '"\x' . $b . '"';  
341          my $bytes = eval $b;          my $bytes = eval $b;
342          die $@ if $@;          die $@ if $@;
343          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;          warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
Legend:
Removed from v.16  
changed lines
  Added in v.19
  ViewVC Help
Powered by ViewVC 1.1.26