/[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 43 by dpavlin, Tue Jun 23 12:19:30 2009 UTC
# Line 38  sub meteor { Line 38  sub meteor {
38          }          }
39  }  }
40    
41    my $listen_port = 9000;                  # pick something not in use
42    sub http_server {
43    
44            my $server = IO::Socket::INET->new(
45                    Proto     => 'tcp',
46                    LocalPort => $listen_port,
47                    Listen    => SOMAXCONN,
48                    Reuse     => 1
49            );
50                                                                      
51            die "can't setup server" unless $server;
52    
53            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
54    
55            sub static {
56                    my ($client,$path) = @_;
57    
58                    $path = "www/$path";
59    
60                    return unless -e $path;
61    
62                    my $type = 'text/plain';
63                    $type = 'text/html' if $path =~ m{\.htm};
64                    $type = 'application/javascript' if $path =~ m{\.js};
65    
66                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
67                    open(my $html, $path);
68                    while(<$html>) {
69                            print $client $_;
70                    }
71                    close($html);
72    
73                    return $path;
74            }
75    
76            while (my $client = $server->accept()) {
77                    $client->autoflush(1);
78                    my $request = <$client>;
79    
80                    warn "<< $request\n";
81    
82                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
83                            my $method = $1;
84                            if ( my $path = static( $client,$1 ) ) {
85                                    warn ">> $path";
86                            } elsif ( $method =~ m{/scan} ) {
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\n";
88                                    my $tags = scan_for_tags();
89                                    print $client "tags: ",dump($tags);
90                                    my $json;
91                                    map { $json->{$_} = decode_tag($_) } keys %$tags;
92                                    print $client "decoded: ",dump( $json );
93                            } else {
94                                    print $client "HTTP/1.0 404 Unkown method\r\n";
95                            }
96                    } else {
97                            print $client "HTTP/1.0 500 No method\r\n";
98                    }
99                    close $client;
100            }
101    
102            die "server died";
103    }
104    
105  my $debug = 0;  my $debug = 0;
106    
107  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 50  my $handshake = "none"; Line 114  my $handshake = "none";
114  my $program_path = './program/';  my $program_path = './program/';
115  my $secure_path = './secure/';  my $secure_path = './secure/';
116    
117    # http server
118    my $http_server = 1;
119    
120  # 3M defaults: 8,4  # 3M defaults: 8,4
121  my $max_rfid_block = 16;  my $max_rfid_block = 16;
122  my $read_blocks = 8;  my $read_blocks = 8;
# Line 161  cmd( 'D5 00  05   04 00 11 Line 228  cmd( 'D5 00  05   04 00 11
228  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?',
229       '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() }  );
230    
231  # start scanning for tags  sub scan_for_tags {
232    
233  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 {  
234    
235                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
236                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
237                            my $rest = shift || die "no rest?";
238                            my $nr = ord( substr( $rest, 0, 1 ) );
239    
240                            if ( ! $nr ) {
241                                    print "no tags in range\n";
242                                    update_visible_tags();
243                                    meteor( 'info-none-in-range' );
244                                    $tags_data = {};
245                            } else {
246    
247                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
                         die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;  
248    
249                          my @tags;                                  my $tl = length( $tags );
250                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
251    
252                          meteor( 'info-in-range', join(' ',@tags));                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
253                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
254                                    print "$nr tags in range: ", join(',', @tags ) , "\n";
255    
256                          update_visible_tags( @tags );                                  meteor( 'info-in-range', join(' ',@tags));
257    
258                                    update_visible_tags( @tags );
259                            }
260                  }                  }
261          }          );
262  ) while(1);  
263  #) foreach ( 1 .. 100 );          warn "## tags: ",dump( @tags );
264            return $tags_data;
265    
266    }
267    
268    # start scanning for tags
269    
270    if ( $http_server ) {
271            http_server;
272    } else {
273            scan_for_tags while 1;
274    }
275    
276    die "over and out";
277    
278  sub update_visible_tags {  sub update_visible_tags {
279          my @tags = @_;          my @tags = @_;
# Line 261  sub read_tag_data { Line 341  sub read_tag_data {
341          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
342    
343          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
344          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";
345    
346          return $last_block;          return $last_block + 1;
347    }
348    
349    sub decode_tag {
350            my $tag = shift;
351    
352            my $data = $tags_data->{$tag} || die "no data for $tag";
353    
354            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
355            my $hash = {
356                    u1 => $u1,
357                    u2 => $u2,
358                    set => ( $set_item & 0xf0 ) >> 4,
359                    total => ( $set_item & 0x0f ),
360    
361                    type => $type,
362                    content => $content,
363    
364                    branch => $br_lib >> 20,
365                    library => $br_lib & 0x000fffff,
366    
367                    custom => $custom,
368            };
369    
370            return $hash;
371  }  }
372    
373  sub read_tag {  sub read_tag {
# Line 305  sub read_tag { Line 409  sub read_tag {
409                  }                  }
410          );          );
411    
412          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";  
   
413  }  }
414    
415  sub write_tag {  sub write_tag {
# Line 451  sub skip_assert { Line 548  sub skip_assert {
548  sub assert {  sub assert {
549          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
550    
         return unless $assert->{expect};  
   
551          $from ||= 0;          $from ||= 0;
552          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
553    
# Line 502  sub checksum { Line 597  sub checksum {
597  our $dispatch;  our $dispatch;
598    
599  sub readchunk {  sub readchunk {
600          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
601    
602          # read header of packet          # read header of packet
603          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 530  sub readchunk { Line 625  sub readchunk {
625          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
626          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
627    
628          if ( defined $to && $payload ) {          if ( defined $to ) {
629                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
630                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
631                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
632          } else {          } else {
Legend:
Removed from v.41  
changed lines
  Added in v.43
  ViewVC Help
Powered by ViewVC 1.1.26