/[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 38 by dpavlin, Mon Jun 1 18:36:42 2009 UTC revision 50 by dpavlin, Wed Jun 24 09:30:28 2009 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10  use File::Slurp;  use File::Slurp;
11    use JSON;
12    
13  use IO::Socket::INET;  use IO::Socket::INET;
14    
15    my $debug = 0;
16    
17  my $meteor_server = '192.168.1.13:4671';  my $meteor_server = '192.168.1.13:4671';
18  my $meteor_fh;  my $meteor_fh;
19    
# Line 38  sub meteor { Line 41  sub meteor {
41          }          }
42  }  }
43    
44  my $debug = 0;  my $listen_port = 9000;                  # pick something not in use
45    sub http_server {
46    
47            my $server = IO::Socket::INET->new(
48                    Proto     => 'tcp',
49                    LocalPort => $listen_port,
50                    Listen    => SOMAXCONN,
51                    Reuse     => 1
52            );
53                                                                      
54            die "can't setup server" unless $server;
55    
56            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
57    
58            sub static {
59                    my ($client,$path) = @_;
60    
61                    $path = "www/$path";
62    
63                    return unless -e $path;
64    
65                    my $type = 'text/plain';
66                    $type = 'text/html' if $path =~ m{\.htm};
67                    $type = 'application/javascript' if $path =~ m{\.js};
68    
69                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
70                    open(my $html, $path);
71                    while(<$html>) {
72                            print $client $_;
73                    }
74                    close($html);
75    
76                    return $path;
77            }
78    
79            while (my $client = $server->accept()) {
80                    $client->autoflush(1);
81                    my $request = <$client>;
82    
83                    warn "WEB << $request\n" if $debug;
84    
85                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
86                            my $method = $1;
87                            my $param;
88                            if ( $method =~ s{\?(.+)}{} ) {
89                                    foreach my $p ( split(/[&;]/, $1) ) {
90                                            my ($n,$v) = split(/=/, $p, 2);
91                                            $param->{$n} = $v;
92                                    }
93                                    warn "WEB << param: ",dump( $param ) if $debug;
94                            }
95                            if ( my $path = static( $client,$1 ) ) {
96                                    warn "WEB >> $path" if $debug;
97                            } elsif ( $method =~ m{/scan} ) {
98                                    my $tags = scan_for_tags();
99                                    my $json = {};
100                                    map {
101                                            my $d = decode_tag($_);
102                                            $d->{sid} = $_;
103                                            push @{ $json->{tags} },  $d;
104                                    } keys %$tags;
105                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
106                                            $param->{callback}, "(", to_json($json), ")\r\n";
107                            } else {
108                                    print $client "HTTP/1.0 404 Unkown method\r\n";
109                            }
110                    } else {
111                            print $client "HTTP/1.0 500 No method\r\n";
112                    }
113                    close $client;
114            }
115    
116            die "server died";
117    }
118    
119    
120    my $last_message = {};
121    sub _message {
122            my $type = shift @_;
123            my $text = join(' ',@_);
124            my $last = $last_message->{$type};
125            if ( $text ne $last ) {
126                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
127                    $last_message->{$type} = $text;
128            }
129    }
130    
131    sub _log { _message('log',@_) };
132    sub diag { _message('diag',@_) };
133    
134  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
135  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 50  my $handshake = "none"; Line 141  my $handshake = "none";
141  my $program_path = './program/';  my $program_path = './program/';
142  my $secure_path = './secure/';  my $secure_path = './secure/';
143    
144    # http server
145    my $http_server = 1;
146    
147    # 3M defaults: 8,4
148    my $max_rfid_block = 16;
149    my $read_blocks = 8;
150    
151  my $response = {  my $response = {
152          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
153          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 71  GetOptions( Line 169  GetOptions(
169          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
170          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
171          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
172            'http-server!' => \$http_server,
173  ) or die $!;  ) or die $!;
174    
175  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 134  $databits=$port->databits($databits); Line 233  $databits=$port->databits($databits);
233  $parity=$port->parity($parity);  $parity=$port->parity($parity);
234  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
235    
236  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
237    
238  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
239  $port->lookclear();  $port->lookclear();
# Line 157  cmd( 'D5 00  05   04 00 11 Line 256  cmd( 'D5 00  05   04 00 11
256  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
257       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
258    
259  # start scanning for tags  sub scan_for_tags {
260    
261  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
          'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
                 my $rest = shift || die "no rest?";  
                 my $nr = ord( substr( $rest, 0, 1 ) );  
   
                 if ( ! $nr ) {  
                         print "no tags in range\n";  
                         update_visible_tags();  
                         meteor( 'info-none-in-range' );  
                         $tags_data = {};  
                 } else {  
262    
263                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
264                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
265                            my $rest = shift || die "no rest?";
266                            my $nr = ord( substr( $rest, 0, 1 ) );
267    
268                            if ( ! $nr ) {
269                                    _log "no tags in range\n";
270                                    update_visible_tags();
271                                    meteor( 'info-none-in-range' );
272                                    $tags_data = {};
273                            } else {
274    
275                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
276                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
277                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
278    
279                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
280                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
281                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  _log "$nr tags in range: ", join(',', @tags ) , "\n";
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
282    
283                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
284    
285                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
286                            }
287                  }                  }
288          }          );
289  ) while(1);  
290  #) foreach ( 1 .. 100 );          diag "tags: ",dump( @tags );
291            return $tags_data;
292    
293    }
294    
295    # start scanning for tags
296    
297    if ( $http_server ) {
298            http_server;
299    } else {
300            scan_for_tags while 1;
301    }
302    
303    die "over and out";
304    
305  sub update_visible_tags {  sub update_visible_tags {
306          my @tags = @_;          my @tags = @_;
# Line 235  my $tag_data_block; Line 346  my $tag_data_block;
346  sub read_tag_data {  sub read_tag_data {
347          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
348          die "no rest?" unless $rest;          die "no rest?" unless $rest;
349    
350            my $last_block = 0;
351    
352          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
353          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
354          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 244  sub read_tag_data { Line 358  sub read_tag_data {
358                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
359                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
360                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
361                  die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;                  warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
362                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
363                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
364                  warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;                  warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
365                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
366                    $last_block = $ord;
367          }          }
368          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
369    
370          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
371          print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";          print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
372    
373            return $last_block + 1;
374    }
375    
376    sub decode_tag {
377            my $tag = shift;
378    
379            my $data = $tags_data->{$tag} || die "no data for $tag";
380    
381            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
382            my $hash = {
383                    u1 => $u1,
384                    u2 => $u2,
385                    set => ( $set_item & 0xf0 ) >> 4,
386                    total => ( $set_item & 0x0f ),
387    
388                    type => $type,
389                    content => $content,
390    
391                    branch => $br_lib >> 20,
392                    library => $br_lib & 0x000fffff,
393    
394                    custom => $custom,
395            };
396    
397            return $hash;
398  }  }
399    
400  sub read_tag {  sub read_tag {
# Line 263  sub read_tag { Line 404  sub read_tag {
404    
405          print "read_tag $tag\n";          print "read_tag $tag\n";
406    
407          cmd(          my $start_block = 0;
                 "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",  
                 "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {  
                         print "FIXME: tag $tag ready?\n";  
                 },  
                 "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";  
                         read_tag_data( 0, @_ );  
                 },  
         );  
408    
409          cmd(          while ( $start_block < $max_rfid_block ) {
410                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
411                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
412                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
413                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
414          );                          "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";
415                                    $start_block = read_tag_data( $start_block, @_ );
416                                    warn "# read tag upto $start_block\n";
417                            },
418                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
419                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
420                            },
421                    );
422    
423            }
424    
425          my $security;          my $security;
426    
# Line 294  sub read_tag { Line 436  sub read_tag {
436                  }                  }
437          );          );
438    
439          my $data = $tags_data->{$tag} || die "no data for $tag";          print "TAG $tag ", dump(decode_tag( $tag ));
         my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);  
         my $set   = ( $set_item & 0xf0 ) >> 4;  
         my $total = ( $set_item & 0x0f );  
         my $branch  = $br_lib >> 20;  
         my $library = $br_lib & 0x000fffff;  
         print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' library: $library branch: $branch custom: $custom security: $security\n";  
   
440  }  }
441    
442  sub write_tag {  sub write_tag {
# Line 317  sub write_tag { Line 452  sub write_tag {
452                  $hex_data =~ s{\s+}{}g;                  $hex_data =~ s{\s+}{}g;
453          } else {          } else {
454    
                 # pad to block size  
455                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );
456    
457                  my $max_len = 7 * 4;                  my $max_len = $max_rfid_block * 4;
458    
459                  if ( length($data) > $max_len ) {                  if ( length($data) > $max_len ) {
460                          $data = substr($data,0,$max_len);                          $data = substr($data,0,$max_len);
# Line 331  sub write_tag { Line 465  sub write_tag {
465          }          }
466    
467          my $len = length($hex_data) / 2;          my $len = length($hex_data) / 2;
468          my $blocks = sprintf('%02x', $len / 4);          # pad to block size
469            $hex_data .= '00' x ( 4 - $len % 4 );
470            my $blocks = sprintf('%02x', length($hex_data) / 4);
471    
472          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
473    
474          cmd(          cmd(
475                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
476                  "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
477          ) foreach ( 1 .. 3 ); # xxx 3m software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
478    
479          my $to = $path;          my $to = $path;
480          $to .= '.' . time();          $to .= '.' . time();
# Line 398  print "Port closed\n"; Line 534  print "Port closed\n";
534  sub writechunk  sub writechunk
535  {  {
536          my $str=shift;          my $str=shift;
 warn "DEBUG: ", as_hex($str);  
537          my $count = $port->write($str);          my $count = $port->write($str);
538          my $len = length($str);          my $len = length($str);
539          die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;          die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
# Line 489  sub checksum { Line 624  sub checksum {
624  our $dispatch;  our $dispatch;
625    
626  sub readchunk {  sub readchunk {
627          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
628    
629          # read header of packet          # read header of packet
630          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 518  sub readchunk { Line 653  sub readchunk {
653          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
654    
655          if ( defined $to ) {          if ( defined $to ) {
656                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
657                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
658                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
659          } else {          } else {
Legend:
Removed from v.38  
changed lines
  Added in v.50
  ViewVC Help
Powered by ViewVC 1.1.26