/[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 41 by dpavlin, Thu Jun 4 13:36:20 2009 UTC revision 58 by dpavlin, Sat Jul 4 08:33:56 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 $meteor_server = '192.168.1.13:4671';  my $debug = 0;
16    
17    my $tags_data;
18    my $tags_security;
19    my $visible_tags;
20    
21    my $meteor_server; # = '192.168.1.13:4671';
22  my $meteor_fh;  my $meteor_fh;
23    
24  sub meteor {  sub meteor {
# Line 38  sub meteor { Line 45  sub meteor {
45          }          }
46  }  }
47    
48  my $debug = 0;  my $listen_port = 9000;                  # pick something not in use
49    sub http_server {
50    
51            my $server = IO::Socket::INET->new(
52                    Proto     => 'tcp',
53                    LocalPort => $listen_port,
54                    Listen    => SOMAXCONN,
55                    Reuse     => 1
56            );
57                                                                      
58            die "can't setup server" unless $server;
59    
60            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
61    
62            sub static {
63                    my ($client,$path) = @_;
64    
65                    $path = "www/$path";
66                    $path .= 'rfid.html' if $path =~ m{/$};
67    
68                    return unless -e $path;
69    
70                    my $type = 'text/plain';
71                    $type = 'text/html' if $path =~ m{\.htm};
72                    $type = 'application/javascript' if $path =~ m{\.js};
73    
74                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
75                    open(my $html, $path);
76                    while(<$html>) {
77                            print $client $_;
78                    }
79                    close($html);
80    
81                    return $path;
82            }
83    
84            while (my $client = $server->accept()) {
85                    $client->autoflush(1);
86                    my $request = <$client>;
87    
88                    warn "WEB << $request\n" if $debug;
89    
90                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
91                            my $method = $1;
92                            my $param;
93                            if ( $method =~ s{\?(.+)}{} ) {
94                                    foreach my $p ( split(/[&;]/, $1) ) {
95                                            my ($n,$v) = split(/=/, $p, 2);
96                                            $param->{$n} = $v;
97                                    }
98                                    warn "WEB << param: ",dump( $param ) if $debug;
99                            }
100                            if ( my $path = static( $client,$1 ) ) {
101                                    warn "WEB >> $path" if $debug;
102                            } elsif ( $method =~ m{/scan} ) {
103                                    my $tags = scan_for_tags();
104                                    my $json = { time => time() };
105                                    map {
106                                            my $d = decode_tag($_);
107                                            $d->{sid} = $_;
108                                            $d->{security} = $tags_security->{$_};
109                                            push @{ $json->{tags} },  $d;
110                                    } keys %$tags;
111                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
112                                            $param->{callback}, "(", to_json($json), ")\r\n";
113                            } else {
114                                    print $client "HTTP/1.0 404 Unkown method\r\n";
115                            }
116                    } else {
117                            print $client "HTTP/1.0 500 No method\r\n";
118                    }
119                    close $client;
120            }
121    
122            die "server died";
123    }
124    
125    
126    my $last_message = {};
127    sub _message {
128            my $type = shift @_;
129            my $text = join(' ',@_);
130            my $last = $last_message->{$type};
131            if ( $text ne $last ) {
132                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
133                    $last_message->{$type} = $text;
134            }
135    }
136    
137    sub _log { _message('log',@_) };
138    sub diag { _message('diag',@_) };
139    
140  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
141  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 50  my $handshake = "none"; Line 147  my $handshake = "none";
147  my $program_path = './program/';  my $program_path = './program/';
148  my $secure_path = './secure/';  my $secure_path = './secure/';
149    
150    # http server
151    my $http_server = 1;
152    
153  # 3M defaults: 8,4  # 3M defaults: 8,4
154  my $max_rfid_block = 16;  my $max_rfid_block = 16;
155  my $read_blocks = 8;  my $read_blocks = 8;
# Line 75  GetOptions( Line 175  GetOptions(
175          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
176          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
177          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
178            'http-server!' => \$http_server,
179  ) or die $!;  ) or die $!;
180    
181  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 110  it under the same terms ans Perl itself. Line 211  it under the same terms ans Perl itself.
211    
212  =cut  =cut
213    
 my $tags_data;  
 my $visible_tags;  
   
214  my $item_type = {  my $item_type = {
215          1 => 'Book',          1 => 'Book',
216          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 138  $databits=$port->databits($databits); Line 236  $databits=$port->databits($databits);
236  $parity=$port->parity($parity);  $parity=$port->parity($parity);
237  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
238    
239  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
240    
241  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
242  $port->lookclear();  $port->lookclear();
# Line 161  cmd( 'D5 00  05   04 00 11 Line 259  cmd( 'D5 00  05   04 00 11
259  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?',
260       '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() }  );
261    
262  # start scanning for tags  sub scan_for_tags {
263    
264  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 {  
265    
266                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
267                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
268                            my $rest = shift || die "no rest?";
269                            my $nr = ord( substr( $rest, 0, 1 ) );
270    
271                            if ( ! $nr ) {
272                                    _log "no tags in range\n";
273                                    update_visible_tags();
274                                    meteor( 'info-none-in-range' );
275                                    $tags_data = {};
276                            } else {
277    
278                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
279                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
280                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
281    
282                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
283                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
284                          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";  
285    
286                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
287    
288                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
289                            }
290                  }                  }
291          }          );
292  ) while(1);  
293  #) foreach ( 1 .. 100 );          diag "tags: ",dump( @tags );
294            return $tags_data;
295    
296    }
297    
298    # start scanning for tags
299    
300    if ( $http_server ) {
301            http_server;
302    } else {
303            while (1) {
304                    scan_for_tags;
305                    sleep 1;
306            }
307    }
308    
309    die "over and out";
310    
311  sub update_visible_tags {  sub update_visible_tags {
312          my @tags = @_;          my @tags = @_;
# Line 202  sub update_visible_tags { Line 315  sub update_visible_tags {
315          $visible_tags = {};          $visible_tags = {};
316    
317          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
318                    $visible_tags->{$tag}++;
319                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
320                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
321  #                               meteor( 'in-range', $tag );  #                               meteor( 'in-range', $tag );
# Line 209  sub update_visible_tags { Line 323  sub update_visible_tags {
323                                  meteor( 'read', $tag );                                  meteor( 'read', $tag );
324                                  read_tag( $tag );                                  read_tag( $tag );
325                          }                          }
                         $visible_tags->{$tag}++;  
326                  } else {                  } else {
327                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
328                  }                  }
# Line 261  sub read_tag_data { Line 374  sub read_tag_data {
374          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
375    
376          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
377          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";
378    
379          return $last_block;          return $last_block + 1;
380    }
381    
382    sub decode_tag {
383            my $tag = shift;
384    
385            my $data = $tags_data->{$tag} || die "no data for $tag";
386    
387            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
388            my $hash = {
389                    u1 => $u1,
390                    u2 => $u2,
391                    set => ( $set_item & 0xf0 ) >> 4,
392                    total => ( $set_item & 0x0f ),
393    
394                    type => $type,
395                    content => $content,
396    
397                    branch => $br_lib >> 20,
398                    library => $br_lib & 0x000fffff,
399    
400                    custom => $custom,
401            };
402    
403            return $hash;
404  }  }
405    
406  sub read_tag {  sub read_tag {
# Line 301  sub read_tag { Line 438  sub read_tag {
438                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
439                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
440                          $security = as_hex( $security );                          $security = as_hex( $security );
441                            $tags_security->{$tag} = $security;
442                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
443                  }                  }
444          );          );
445    
446          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";  
   
447  }  }
448    
449  sub write_tag {  sub write_tag {
# Line 451  sub skip_assert { Line 582  sub skip_assert {
582  sub assert {  sub assert {
583          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
584    
         return unless $assert->{expect};  
   
585          $from ||= 0;          $from ||= 0;
586          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
587    
# Line 502  sub checksum { Line 631  sub checksum {
631  our $dispatch;  our $dispatch;
632    
633  sub readchunk {  sub readchunk {
634          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
635    
636          # read header of packet          # read header of packet
637          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 530  sub readchunk { Line 659  sub readchunk {
659          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
660          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
661    
662          if ( defined $to && $payload ) {          if ( defined $to ) {
663                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
664                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
665                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
666          } else {          } else {
667                  print "NO DISPATCH for ",dump( $full ),"\n";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
668          }          }
669    
670          return $data;          return $data;
Legend:
Removed from v.41  
changed lines
  Added in v.58
  ViewVC Help
Powered by ViewVC 1.1.26