/[RFID]/cpr-m02.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 /cpr-m02.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 24 by dpavlin, Sat Mar 28 14:20:27 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                            $tags_data = {};
131                    } else {
132    
133                            my $tags = substr( $rest, 1 );
134    
135                            my $tl = length( $tags );
136                            die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
137    
138                            my @tags;
139                            push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
140                            warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
141                            print "$nr tags in range: ", join(',', @tags ) , "\n";
142    
143                            update_visible_tags( @tags );
144    
145                            my $html = join('', map { "<li><tt>$_</tt>" } @tags);
146                            meteor( 0, "Tags:<ul>$html</ul>" );
147                    }
148            }
149    ) while(1);
150    #) foreach ( 1 .. 100 );
151    
152    
153    
154    sub update_visible_tags {
155            my @tags = @_;
156    
157            my $last_visible_tags = $visible_tags;
158            $visible_tags = {};
159    
160            foreach my $tag ( @tags ) {
161                    if ( ! defined $last_visible_tags->{$tag} ) {
162                            read_tag( $tag );
163                            $visible_tags->{$tag}++;
164                    } else {
165                            warn "## using cached data for $tag" if $debug;
166                    }
167                    delete $last_visible_tags->{$tag}; # leave just missing tags
168            }
169    
170            foreach my $tag ( keys %$last_visible_tags ) {
171                    my $data = delete $tags_data->{$tag};
172                    print "removed tag $tag with data ",dump( $data ),"\n";
173            }
174    
175            warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
176  }  }
177    
 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' );  
178    
179  cmd( 'D6 00  0C  13   04   01 00  02 00  03 00  04 00   AAF2','stats?' );  sub read_tag {
180  #     D6 00  0C  13   00   02 01 01 03 02 02 03  00   E778          my ( $tag ) = @_;
181    
182  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 );  
183    
184  #     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A       # seen          return if defined $tags_data->{$tag};
185    
186  cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );          print "read_tag $tag\n";
187    
188  #     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(
189  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',
190                    "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
191                            print "FIXME: tag $tag ready?\n";
192                    },
193                    "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";
194                            my $rest = shift || die "no rest?";
195                            warn "## DATA ", dump( $rest ) if $debug;
196                            my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
197                            my $blocks = ord(substr($rest,8,1));
198                            $rest = substr($rest,9); # leave just data blocks
199                            my @data;
200                            foreach my $nr ( 0 .. $blocks - 1 ) {
201                                    my $block = substr( $rest, $nr * 6, 6 );
202                                    warn "## block ",as_hex( $block ) if $debug;
203                                    my $ord   = unpack('v',substr( $block, 0, 2 ));
204                                    die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
205                                    my $data  = substr( $block, 2 );
206                                    die "data payload should be 4 bytes" if length($data) != 4;
207                                    warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
208                                    $data[ $ord ] = $data;
209                            }
210                            $tags_data->{ $tag } = join('', @data);
211                            print "DATA $tag ",dump( $tags_data ), "\n";
212                    }
213            );
214    
215            #        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
216    if (0) {
217            cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );
218    
219            #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00  
220            #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
221            warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
222    }
223            warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";
224    
225  cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );          my $item = unpack('H*', substr($tag,-8) ) % 100000;
226            meteor( $item, "Loading $item" );
227    
228  #     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00    }
229  #                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA  
230  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";  
231    
232  for ( 1 .. 3 ) {  for ( 1 .. 3 ) {
233    
# Line 140  print "Port closed\n"; Line 258  print "Port closed\n";
258  sub writechunk  sub writechunk
259  {  {
260          my $str=shift;          my $str=shift;
   
261          my $count = $port->write($str);          my $count = $port->write($str);
262          print ">> ", as_hex( $str ), "\t[$count]\n";          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
263  }  }
264    
265  sub as_hex {  sub as_hex {
266          my @out;          my @out;
267          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
268                  my $hex = unpack( 'H*', $str );                  my $hex = unpack( 'H*', $str );
269                  $hex =~ s/(..)/$1 /g;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
270                    $hex =~ s/\s+$//;
271                  push @out, $hex;                  push @out, $hex;
272          }          }
273          return join('  ', @out);          return join(' | ', @out);
274  }  }
275    
276  sub read_bytes {  sub read_bytes {
# Line 164  sub read_bytes { Line 282  sub read_bytes {
282                  $data .= $b;                  $data .= $b;
283          }          }
284          $desc ||= '?';          $desc ||= '?';
285          warn "#< ", as_hex($data), "\t$desc\n";          warn "#< ", as_hex($data), "\t$desc\n" if $debug;
286          return $data;          return $data;
287  }  }
288    
289    our $assert;
290    
291    # my $rest = skip_assert( 3 );
292    sub skip_assert {
293            assert( 0, shift );
294    }
295    
296    sub assert {
297            my ( $from, $to ) = @_;
298    
299            $from ||= 0;
300            $to = length( $assert->{expect} ) if ! defined $to;
301    
302            my $p = substr( $assert->{payload}, $from, $to );
303            my $e = substr( $assert->{expect},  $from, $to );
304            warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
305    
306            # return the rest
307            return substr( $assert->{payload}, $to );
308    }
309    
310    use Digest::CRC;
311    
312    sub crcccitt {
313            my $bytes = shift;
314            my $crc = Digest::CRC->new(
315                    # midified CCITT to xor with 0xffff instead of 0x0000
316                    width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
317            ) or die $!;
318            $crc->add( $bytes );
319            pack('n', $crc->digest);
320    }
321    
322    # my $checksum = checksum( $bytes );
323    # my $checksum = checksum( $bytes, $original_checksum );
324    sub checksum {
325            my ( $bytes, $checksum ) = @_;
326    
327            my $xor = crcccitt( substr($bytes,1) ); # skip D6
328            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
329    
330            my $len = ord(substr($bytes,2,1));
331            my $len_real = length($bytes) - 1;
332    
333            if ( $len_real != $len ) {
334                    print "length wrong: $len_real != $len\n";
335                    $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
336            }
337    
338            if ( defined $checksum && $xor ne $checksum ) {
339                    print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
340                    return $bytes . $xor;
341            }
342            return $bytes . $checksum;
343    }
344    
345    our $dispatch;
346    
347  sub readchunk {  sub readchunk {
348            sleep 1;        # FIXME remove
349    
350          # read header of packet          # read header of packet
351          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
352          my $len = ord( read_bytes( 1, 'length' ) );          my $length = read_bytes( 1, 'length' );
353            my $len = ord($length);
354          my $data = read_bytes( $len, 'data' );          my $data = read_bytes( $len, 'data' );
355    
356          warn "<< ",as_hex( $header, ), " [$len] ", as_hex( $data ), "\n";          my $payload  = substr( $data, 0, -2 );
357            my $payload_len = length($data);
358            warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
359    
360            my $checksum = substr( $data, -2, 2 );
361            checksum( $header . $length . $payload , $checksum );
362    
363            print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;
364    
365            $assert->{len}      = $len;
366            $assert->{payload}  = $payload;
367    
368            my $full = $header . $length . $data; # full
369            # find longest match for incomming data
370            my ($to) = grep {
371                    my $match = substr($payload,0,length($_));
372                    m/^\Q$match\E/
373            } sort { length($a) <=> length($b) } keys %$dispatch;
374            warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
375    
376            if ( defined $to ) {
377                    my $rest = substr( $payload, length($to) );
378                    warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
379                    $dispatch->{ $to }->( $rest );
380            } else {
381                    print "NO DISPATCH for ",dump( $full ),"\n";
382            }
383    
384            return $data;
385    }
386    
387    sub str2bytes {
388            my $str = shift || confess "no str?";
389            my $b = $str;
390            $b =~ s/\s+//g;
391            $b =~ s/(..)/\\x$1/g;
392            $b = "\"$b\"";
393            my $bytes = eval $b;
394            die $@ if $@;
395            warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
396            return $bytes;
397    }
398    
399    sub cmd {
400            my $cmd = shift || confess "no cmd?";
401            my $cmd_desc = shift || confess "no description?";
402            my @expect = @_;
403    
404            my $bytes = str2bytes( $cmd );
405    
406            # fix checksum if needed
407            $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
408    
409            warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
410            $assert->{send} = $cmd;
411            writechunk( $bytes );
412    
413            while ( @expect ) {
414                    my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
415                    my $coderef = shift @expect || confess "no coderef?";
416                    confess "not coderef" unless ref $coderef eq 'CODE';
417    
418                    next if defined $dispatch->{ $pattern };
419    
420                    $dispatch->{ substr($pattern,3) } = $coderef;
421                    warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
422            }
423    
424          sleep 1;          readchunk;
425  }  }
426    
Legend:
Removed from v.1  
changed lines
  Added in v.24
  ViewVC Help
Powered by ViewVC 1.1.26