/[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 46 by dpavlin, Tue Jun 23 13:50:13 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                            my $param;
86                            if ( $method =~ s{\?(.+)}{} ) {
87                                    foreach my $p ( split(/[&;]/, $1) ) {
88                                            my ($n,$v) = split(/=/, $p, 2);
89                                            $param->{$n} = $v;
90                                    }
91                                    warn "<< param: ",dump( $param );
92                            }
93                            if ( my $path = static( $client,$1 ) ) {
94                                    warn ">> $path";
95                            } elsif ( $method =~ m{/scan} ) {
96                                    my $tags = scan_for_tags();
97                                    my $json = {};
98                                    map {
99                                            my $d = decode_tag($_);
100                                            $d->{sid} = $_;
101                                            push @{ $json->{tags} },  $d;
102                                    } keys %$tags;
103                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
104                                            $param->{callback}, "(", to_json($json), ")\r\n";
105                            } else {
106                                    print $client "HTTP/1.0 404 Unkown method\r\n";
107                            }
108                    } else {
109                            print $client "HTTP/1.0 500 No method\r\n";
110                    }
111                    close $client;
112            }
113    
114            die "server died";
115    }
116    
117  my $debug = 0;  my $debug = 0;
118    
119  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 50  my $handshake = "none"; Line 126  my $handshake = "none";
126  my $program_path = './program/';  my $program_path = './program/';
127  my $secure_path = './secure/';  my $secure_path = './secure/';
128    
129    # http server
130    my $http_server = 1;
131    
132  # 3M defaults: 8,4  # 3M defaults: 8,4
133  my $max_rfid_block = 16;  my $max_rfid_block = 16;
134  my $read_blocks = 8;  my $read_blocks = 8;
# Line 75  GetOptions( Line 154  GetOptions(
154          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
155          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
156          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
157            'http-server!' => \$http_server,
158  ) or die $!;  ) or die $!;
159    
160  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 161  cmd( 'D5 00  05   04 00 11 Line 241  cmd( 'D5 00  05   04 00 11
241  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?',
242       '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() }  );
243    
244  # start scanning for tags  sub scan_for_tags {
245    
246  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 {  
247    
248                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
249                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
250                            my $rest = shift || die "no rest?";
251                            my $nr = ord( substr( $rest, 0, 1 ) );
252    
253                            if ( ! $nr ) {
254                                    print "no tags in range\n";
255                                    update_visible_tags();
256                                    meteor( 'info-none-in-range' );
257                                    $tags_data = {};
258                            } else {
259    
260                                    my $tags = substr( $rest, 1 );
261    
262                          my $tl = length( $tags );                                  my $tl = length( $tags );
263                          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;
264    
265                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
266                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
267                          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";  
268    
269                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
270    
271                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
272                            }
273                  }                  }
274          }          );
275  ) while(1);  
276  #) foreach ( 1 .. 100 );          warn "## tags: ",dump( @tags );
277            return $tags_data;
278    
279    }
280    
281    # start scanning for tags
282    
283    if ( $http_server ) {
284            http_server;
285    } else {
286            scan_for_tags while 1;
287    }
288    
289    die "over and out";
290    
291  sub update_visible_tags {  sub update_visible_tags {
292          my @tags = @_;          my @tags = @_;
# Line 261  sub read_tag_data { Line 354  sub read_tag_data {
354          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
355    
356          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
357          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";
358    
359            return $last_block + 1;
360    }
361    
362    sub decode_tag {
363            my $tag = shift;
364    
365            my $data = $tags_data->{$tag} || die "no data for $tag";
366    
367            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
368            my $hash = {
369                    u1 => $u1,
370                    u2 => $u2,
371                    set => ( $set_item & 0xf0 ) >> 4,
372                    total => ( $set_item & 0x0f ),
373    
374                    type => $type,
375                    content => $content,
376    
377          return $last_block;                  branch => $br_lib >> 20,
378                    library => $br_lib & 0x000fffff,
379    
380                    custom => $custom,
381            };
382    
383            return $hash;
384  }  }
385    
386  sub read_tag {  sub read_tag {
# Line 305  sub read_tag { Line 422  sub read_tag {
422                  }                  }
423          );          );
424    
425          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";  
   
426  }  }
427    
428  sub write_tag {  sub write_tag {
# Line 451  sub skip_assert { Line 561  sub skip_assert {
561  sub assert {  sub assert {
562          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
563    
         return unless $assert->{expect};  
   
564          $from ||= 0;          $from ||= 0;
565          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
566    
# Line 502  sub checksum { Line 610  sub checksum {
610  our $dispatch;  our $dispatch;
611    
612  sub readchunk {  sub readchunk {
613          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
614    
615          # read header of packet          # read header of packet
616          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 530  sub readchunk { Line 638  sub readchunk {
638          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
639          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
640    
641          if ( defined $to && $payload ) {          if ( defined $to ) {
642                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
643                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
644                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
645          } else {          } else {
Legend:
Removed from v.41  
changed lines
  Added in v.46
  ViewVC Help
Powered by ViewVC 1.1.26