/[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 44 by dpavlin, Tue Jun 23 13:10:18 2009 UTC revision 63 by dpavlin, Thu Feb 11 10:52:14 2010 UTC
# Line 9  use Carp qw/confess/; Line 9  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10  use File::Slurp;  use File::Slurp;
11  use JSON;  use JSON;
12    use POSIX qw(strftime);
13    
14  use IO::Socket::INET;  use IO::Socket::INET;
15    
16  my $meteor_server = '192.168.1.13:4671';  my $debug = 0;
17    
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $meteor_server; # = '192.168.1.13:4671';
23  my $meteor_fh;  my $meteor_fh;
24    
25  sub meteor {  sub meteor {
# Line 40  sub meteor { Line 47  sub meteor {
47  }  }
48    
49  my $listen_port = 9000;                  # pick something not in use  my $listen_port = 9000;                  # pick something not in use
50    my $server_url  = "http://localhost:$listen_port";
51    
52  sub http_server {  sub http_server {
53    
54          my $server = IO::Socket::INET->new(          my $server = IO::Socket::INET->new(
# Line 51  sub http_server { Line 60  sub http_server {
60                                                                                                                                        
61          die "can't setup server" unless $server;          die "can't setup server" unless $server;
62    
63          print "Server $0 accepting clients at http://localhost:$listen_port/\n";          print "Server $0 ready at $server_url\n";
64    
65          sub static {          sub static {
66                  my ($client,$path) = @_;                  my ($client,$path) = @_;
67    
68                  $path = "www/$path";                  $path = "www/$path";
69                    $path .= 'rfid.html' if $path =~ m{/$};
70    
71                  return unless -e $path;                  return unless -e $path;
72    
# Line 78  sub http_server { Line 88  sub http_server {
88                  $client->autoflush(1);                  $client->autoflush(1);
89                  my $request = <$client>;                  my $request = <$client>;
90    
91                  warn "<< $request\n";                  warn "WEB << $request\n" if $debug;
92    
93                  if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {                  if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
94                          my $method = $1;                          my $method = $1;
95                            my $param;
96                            if ( $method =~ s{\?(.+)}{} ) {
97                                    foreach my $p ( split(/[&;]/, $1) ) {
98                                            my ($n,$v) = split(/=/, $p, 2);
99                                            $param->{$n} = $v;
100                                    }
101                                    warn "WEB << param: ",dump( $param ) if $debug;
102                            }
103                          if ( my $path = static( $client,$1 ) ) {                          if ( my $path = static( $client,$1 ) ) {
104                                  warn ">> $path";                                  warn "WEB >> $path" if $debug;
105                          } elsif ( $method =~ m{/scan} ) {                          } elsif ( $method =~ m{/scan} ) {
                                 my $callback = $1 if $method =~ m{\?callback=([^&;]+)};  
106                                  my $tags = scan_for_tags();                                  my $tags = scan_for_tags();
107                                  my $json;                                  my $json = { time => time() };
108                                  map {                                  map {
109                                          my $d = decode_tag($_);                                          my $d = decode_tag($_);
110                                          $d->{sid} = $_;                                          $d->{sid} = $_;
111                                            $d->{security} = $tags_security->{$_};
112                                          push @{ $json->{tags} },  $d;                                          push @{ $json->{tags} },  $d;
113                                  } keys %$tags;                                  } keys %$tags;
114                                  print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n$callback(", to_json($json), ")\r\n";                                  print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
115                                            $param->{callback}, "(", to_json($json), ")\r\n";
116                            } elsif ( $method =~ m{/program} ) {
117    
118                                    my $status = 501; # Not implementd
119    
120                                    foreach my $p ( keys %$param ) {
121                                            next unless $p =~ m/^tag_(\S+)/;
122                                            my $tag = $1;
123                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
124                                            $content = "\x00" if $param->{$p} eq 'blank';
125                                            $status = 302;
126    
127                                            warn "PROGRAM $tag $content\n";
128                                            write_tag( $tag, $content );
129                                    }
130    
131                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
132    
133                          } else {                          } else {
134                                  print $client "HTTP/1.0 404 Unkown method\r\n";                                  print $client "HTTP/1.0 404 Unkown method\r\n";
135                          }                          }
# Line 106  sub http_server { Line 142  sub http_server {
142          die "server died";          die "server died";
143  }  }
144    
145  my $debug = 0;  
146    my $last_message = {};
147    sub _message {
148            my $type = shift @_;
149            my $text = join(' ',@_);
150            my $last = $last_message->{$type};
151            if ( $text ne $last ) {
152                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
153                    $last_message->{$type} = $text;
154            }
155    }
156    
157    sub _log { _message('log',@_) };
158    sub diag { _message('diag',@_) };
159    
160  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
161  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 146  GetOptions( Line 195  GetOptions(
195          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
196          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
197          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
198            'http-server!' => \$http_server,
199  ) or die $!;  ) or die $!;
200    
201  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 181  it under the same terms ans Perl itself. Line 231  it under the same terms ans Perl itself.
231    
232  =cut  =cut
233    
 my $tags_data;  
 my $visible_tags;  
   
234  my $item_type = {  my $item_type = {
235          1 => 'Book',          1 => 'Book',
236          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 209  $databits=$port->databits($databits); Line 256  $databits=$port->databits($databits);
256  $parity=$port->parity($parity);  $parity=$port->parity($parity);
257  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
258    
259  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
260    
261  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
262  $port->lookclear();  $port->lookclear();
# Line 236  sub scan_for_tags { Line 283  sub scan_for_tags {
283    
284          my @tags;          my @tags;
285    
286          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
287                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
288                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
289                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
290    
291                          if ( ! $nr ) {                          if ( ! $nr ) {
292                                  print "no tags in range\n";                                  _log "no tags in range\n";
293                                  update_visible_tags();                                  update_visible_tags();
294                                  meteor( 'info-none-in-range' );                                  meteor( 'info-none-in-range' );
295                                  $tags_data = {};                                  $tags_data = {};
296                          } else {                          } else {
297    
298                                  my $tags = substr( $rest, 1 );                                  my $tags = substr( $rest, 1 );
   
299                                  my $tl = length( $tags );                                  my $tl = length( $tags );
300                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
301    
302                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
303                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
304                                  print "$nr tags in range: ", join(',', @tags ) , "\n";                                  _log "$nr tags in range: ", join(',', @tags ) , "\n";
305    
306                                  meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
307    
# Line 264  sub scan_for_tags { Line 310  sub scan_for_tags {
310                  }                  }
311          );          );
312    
313          warn "## tags: ",dump( @tags );          diag "tags: ",dump( @tags );
314          return $tags_data;          return $tags_data;
315    
316  }  }
# Line 274  sub scan_for_tags { Line 320  sub scan_for_tags {
320  if ( $http_server ) {  if ( $http_server ) {
321          http_server;          http_server;
322  } else {  } else {
323          scan_for_tags while 1;          while (1) {
324                    scan_for_tags;
325                    sleep 1;
326            }
327  }  }
328    
329  die "over and out";  die "over and out";
# Line 286  sub update_visible_tags { Line 335  sub update_visible_tags {
335          $visible_tags = {};          $visible_tags = {};
336    
337          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
338                    $visible_tags->{$tag}++;
339                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
340                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
341  #                               meteor( 'in-range', $tag );  #                               meteor( 'in-range', $tag );
# Line 293  sub update_visible_tags { Line 343  sub update_visible_tags {
343                                  meteor( 'read', $tag );                                  meteor( 'read', $tag );
344                                  read_tag( $tag );                                  read_tag( $tag );
345                          }                          }
                         $visible_tags->{$tag}++;  
346                  } else {                  } else {
347                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
348                  }                  }
# Line 350  sub read_tag_data { Line 399  sub read_tag_data {
399          return $last_block + 1;          return $last_block + 1;
400  }  }
401    
402    my $saved_in_log;
403    
404  sub decode_tag {  sub decode_tag {
405          my $tag = shift;          my $tag = shift;
406    
# Line 371  sub decode_tag { Line 422  sub decode_tag {
422                  custom => $custom,                  custom => $custom,
423          };          };
424    
425            if ( ! $saved_in_log->{$tag}++ ) {
426                    open(my $log, '>>', 'rfid-log.txt');
427                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
428                    close($log);
429            }
430    
431          return $hash;          return $hash;
432  }  }
433    
# Line 409  sub read_tag { Line 466  sub read_tag {
466                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
467                          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 );
468                          $security = as_hex( $security );                          $security = as_hex( $security );
469                            $tags_security->{$tag} = $security;
470                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
471                  }                  }
472          );          );
# Line 417  sub read_tag { Line 475  sub read_tag {
475  }  }
476    
477  sub write_tag {  sub write_tag {
478          my ($tag) = @_;          my ($tag,$data) = @_;
479    
480          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
481            $data = read_file( $path ) if -e $path;
482    
483            die "no data" unless $data;
484    
         my $data = read_file( $path );  
485          my $hex_data;          my $hex_data;
486    
487          if ( $data =~ s{^hex\s+}{} ) {          if ( $data =~ s{^hex\s+}{} ) {
# Line 459  sub write_tag { Line 519  sub write_tag {
519          rename $path, $to;          rename $path, $to;
520          print ">> $to\n";          print ">> $to\n";
521    
522          delete $tags_data->{$tag};      # force re-read of tag          # force re-read of tag
523            delete $tags_data->{$tag};
524            delete $visible_tags->{$tag};
525  }  }
526    
527  sub secure_tag {  sub secure_tag {
# Line 634  sub readchunk { Line 696  sub readchunk {
696                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
697                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
698          } else {          } else {
699                  print "NO DISPATCH for ",dump( $full ),"\n";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
700          }          }
701    
702          return $data;          return $data;
Legend:
Removed from v.44  
changed lines
  Added in v.63
  ViewVC Help
Powered by ViewVC 1.1.26