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