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