/[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 42 by dpavlin, Thu Jun 4 13:52:10 2009 UTC revision 45 by dpavlin, Tue Jun 23 13:29:10 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 75  GetOptions( Line 146  GetOptions(
146          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
147          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
148          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
149            'http-server!' => \$http_server,
150  ) or die $!;  ) or die $!;
151    
152  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 161  cmd( 'D5 00  05   04 00 11 Line 233  cmd( 'D5 00  05   04 00 11
233  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?',
234       '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() }  );
235    
236  # start scanning for tags  sub scan_for_tags {
237    
238  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 {  
239    
240                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
241                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
242                            my $rest = shift || die "no rest?";
243                            my $nr = ord( substr( $rest, 0, 1 ) );
244    
245                            if ( ! $nr ) {
246                                    print "no tags in range\n";
247                                    update_visible_tags();
248                                    meteor( 'info-none-in-range' );
249                                    $tags_data = {};
250                            } else {
251    
252                                    my $tags = substr( $rest, 1 );
253    
254                          my $tl = length( $tags );                                  my $tl = length( $tags );
255                          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;
256    
257                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
258                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
259                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  print "$nr tags in range: ", join(',', @tags ) , "\n";
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
260    
261                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
262    
263                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
264                            }
265                  }                  }
266          }          );
267  ) while(1);  
268  #) foreach ( 1 .. 100 );          warn "## tags: ",dump( @tags );
269            return $tags_data;
270    
271    }
272    
273    # start scanning for tags
274    
275    if ( $http_server ) {
276            http_server;
277    } else {
278            scan_for_tags while 1;
279    }
280    
281    die "over and out";
282    
283  sub update_visible_tags {  sub update_visible_tags {
284          my @tags = @_;          my @tags = @_;
# Line 266  sub read_tag_data { Line 351  sub read_tag_data {
351          return $last_block + 1;          return $last_block + 1;
352  }  }
353    
354    sub decode_tag {
355            my $tag = shift;
356    
357            my $data = $tags_data->{$tag} || die "no data for $tag";
358    
359            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
360            my $hash = {
361                    u1 => $u1,
362                    u2 => $u2,
363                    set => ( $set_item & 0xf0 ) >> 4,
364                    total => ( $set_item & 0x0f ),
365    
366                    type => $type,
367                    content => $content,
368    
369                    branch => $br_lib >> 20,
370                    library => $br_lib & 0x000fffff,
371    
372                    custom => $custom,
373            };
374    
375            return $hash;
376    }
377    
378  sub read_tag {  sub read_tag {
379          my ( $tag ) = @_;          my ( $tag ) = @_;
380    
# Line 305  sub read_tag { Line 414  sub read_tag {
414                  }                  }
415          );          );
416    
417          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";  
   
418  }  }
419    
420  sub write_tag {  sub write_tag {
# Line 500  sub checksum { Line 602  sub checksum {
602  our $dispatch;  our $dispatch;
603    
604  sub readchunk {  sub readchunk {
605          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
606    
607          # read header of packet          # read header of packet
608          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
Legend:
Removed from v.42  
changed lines
  Added in v.45
  ViewVC Help
Powered by ViewVC 1.1.26