/[RFID]/cpr-m02.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 /cpr-m02.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

3m-810.pl revision 41 by dpavlin, Thu Jun 4 13:36:20 2009 UTC cpr-m02.pl revision 82 by dpavlin, Fri Jul 9 23:10:05 2010 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    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 = 2;
 my $meteor_fh;  
17    
18  sub meteor {  my $tags_data;
19          my @a = @_;  my $tags_security;
20          push @a, scalar localtime() if $a[0] =~ m{^info};  my $visible_tags;
21    
22          if ( ! defined $meteor_fh ) {  my $listen_port = 9000;                  # pick something not in use
23                  if ( $meteor_fh =  my $server_url  = "http://localhost:$listen_port";
24                                  IO::Socket::INET->new(  
25                                          PeerAddr => $meteor_server,  sub http_server {
26                                          Timeout => 1,  
27                                  )          my $server = IO::Socket::INET->new(
28                  ) {                  Proto     => 'tcp',
29                          warn "# meteor connected to $meteor_server";                  LocalPort => $listen_port,
30                    Listen    => SOMAXCONN,
31                    Reuse     => 1
32            );
33                                                                      
34            die "can't setup server: $!" unless $server;
35    
36            print "Server $0 ready at $server_url\n";
37    
38            sub static {
39                    my ($client,$path) = @_;
40    
41                    $path = "www/$path";
42                    $path .= 'rfid.html' if $path =~ m{/$};
43    
44                    return unless -e $path;
45    
46                    my $type = 'text/plain';
47                    $type = 'text/html' if $path =~ m{\.htm};
48                    $type = 'application/javascript' if $path =~ m{\.js};
49    
50                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                    open(my $html, $path);
52                    while(<$html>) {
53                            print $client $_;
54                    }
55                    close($html);
56    
57                    return $path;
58            }
59    
60            while (my $client = $server->accept()) {
61                    $client->autoflush(1);
62                    my $request = <$client>;
63    
64                    warn "WEB << $request\n" if $debug;
65    
66                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                            my $method = $1;
68                            my $param;
69                            if ( $method =~ s{\?(.+)}{} ) {
70                                    foreach my $p ( split(/[&;]/, $1) ) {
71                                            my ($n,$v) = split(/=/, $p, 2);
72                                            $param->{$n} = $v;
73                                    }
74                                    warn "WEB << param: ",dump( $param ) if $debug;
75                            }
76                            if ( my $path = static( $client,$1 ) ) {
77                                    warn "WEB >> $path" if $debug;
78                            } elsif ( $method =~ m{/scan} ) {
79                                    my $tags = scan_for_tags();
80                                    my $json = { time => time() };
81                                    map {
82                                            my $d = decode_tag($_);
83                                            $d->{sid} = $_;
84                                            $d->{security} = $tags_security->{$_};
85                                            push @{ $json->{tags} },  $d;
86                                    } keys %$tags;
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
88                                            $param->{callback}, "(", to_json($json), ")\r\n";
89                            } elsif ( $method =~ m{/program} ) {
90    
91                                    my $status = 501; # Not implementd
92    
93                                    foreach my $p ( keys %$param ) {
94                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
95                                            my $tag = $1;
96                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
97                                            $content = "\x00" if $param->{$p} eq 'blank';
98                                            $status = 302;
99    
100                                            warn "PROGRAM $tag $content\n";
101                                            write_tag( $tag, $content );
102                                            secure_tag_with( $tag, $param->{$p} =~ /^130/ ? 'DA' : 'D7' );
103                                    }
104    
105                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
106    
107                            } elsif ( $method =~ m{/secure(.js)} ) {
108    
109                                    my $json = $1;
110    
111                                    my $status = 501; # Not implementd
112    
113                                    foreach my $p ( keys %$param ) {
114                                            next unless $p =~ m/^(E[0-9A-F]{15})$/;
115                                            my $tag = $1;
116                                            my $data = $param->{$p};
117                                            $status = 302;
118    
119                                            warn "SECURE $tag $data\n";
120                                            secure_tag_with( $tag, $data );
121                                    }
122    
123                                    if ( $json ) {
124                                            print $client "HTTP/1.0 200 OK\r\nContent-Type: application/json\r\n\r\n",
125                                                    $param->{callback}, "({ ok: 1 })\r\n";
126                                    } else {
127                                            print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
128                                    }
129    
130                            } else {
131                                    print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
132                            }
133                  } else {                  } else {
134                          warn "can't connect to meteor $meteor_server: $!";                          print $client "HTTP/1.0 500 No method\r\n\r\n";
                         $meteor_fh = 0;  
135                  }                  }
136                    close $client;
137          }          }
138    
139          if ( $meteor_fh ) {          die "server died";
140                  warn ">> meteor ",dump( @a );  }
141                  print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"  
142    
143    my $last_message = {};
144    sub _message {
145            my $type = shift @_;
146            my $text = join(' ',@_);
147            my $last = $last_message->{$type};
148            if ( $text ne $last ) {
149                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
150                    $last_message->{$type} = $text;
151          }          }
152  }  }
153    
154  my $debug = 0;  sub _log { _message('log',@_) };
155    sub diag { _message('diag',@_) };
156    
157  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
158  my $baudrate  = "19200";  my $baudrate  = "38400";
159  my $databits  = "8";  my $databits  = "8";
160  my $parity        = "none";  my $parity        = "even";
161  my $stopbits  = "1";  my $stopbits  = "1";
162  my $handshake = "none";  my $handshake = "none";
163    
164  my $program_path = './program/';  my $program_path = './program/';
165  my $secure_path = './secure/';  my $secure_path = './secure/';
166    
167    # http server
168    my $http_server = 1;
169    
170  # 3M defaults: 8,4  # 3M defaults: 8,4
171  my $max_rfid_block = 16;  # cards 16, stickers: 8
172    my $max_rfid_block = 8;
173  my $read_blocks = 8;  my $read_blocks = 8;
174    
175  my $response = {  my $response = {
# Line 74  GetOptions( Line 192  GetOptions(
192          'parity=s'    => \$parity,          'parity=s'    => \$parity,
193          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
194          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
195          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
196  ) or die $!;  ) or die $!;
197    
198  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 110  it under the same terms ans Perl itself. Line 228  it under the same terms ans Perl itself.
228    
229  =cut  =cut
230    
 my $tags_data;  
 my $visible_tags;  
   
231  my $item_type = {  my $item_type = {
232          1 => 'Book',          1 => 'Book',
233          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 138  $databits=$port->databits($databits); Line 253  $databits=$port->databits($databits);
253  $parity=$port->parity($parity);  $parity=$port->parity($parity);
254  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
255    
256  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
257    
258  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
259  $port->lookclear();  $port->lookclear();
# Line 149  $port->read_char_time(5); Line 264  $port->read_char_time(5);
264  #$port->stty_inpck(1);  #$port->stty_inpck(1);
265  #$port->stty_istrip(1);  #$port->stty_istrip(1);
266    
267    sub cpr_m02_checksum {
268            my $data = shift;
269    
270            my $preset = 0xffff;
271            my $polynom = 0x8408;
272    
273            my $crc = $preset;
274            foreach my $i ( 0 .. length($data) - 1 ) {
275                    $crc ^= ord(substr($data,$i,1));
276                    for my $j ( 0 .. 7 ) {
277                            if ( $crc & 0x0001 ) {
278                                    $crc = ( $crc >> 1 ) ^ $polynom;
279                            } else {
280                                    $crc = $crc >> 1;
281                            }
282                    }
283                    warn sprintf('%d %04x', $i, $crc & 0xffff);
284            }
285    
286            return pack('v', $crc);
287    }
288    
289    sub cpr {
290            my $hex = shift;
291            my $bytes = str2bytes($hex);
292            my $len = pack( 'c', length( $bytes ) + 3 );
293            my $send = $len . $bytes;
294            my $checksum = cpr_m02_checksum($send);
295            $send .= $checksum;
296    
297            warn ">> ", as_hex( $send );
298            writechunk( $send );
299            my $r_len = read_bytes( 1, 'response length' );
300            $r_len = ord($r_len) - 1;
301            my $data = read_bytes( $r_len, 'data' );
302            warn "<< ", as_hex( $data );
303    }
304    
305    cpr( '00  52 00' );
306    
307    exit;
308  # initial hand-shake with device  # initial hand-shake with device
309    
310  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',  cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
311       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
312          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
313          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
314  });  });
315    
316  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?',
317       '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() }  );
318    
319  # start scanning for tags  sub scan_for_tags {
320    
321  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 {  
322    
323                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
324                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
325                            my $rest = shift || die "no rest?";
326                            my $nr = ord( substr( $rest, 0, 1 ) );
327    
328                            if ( ! $nr ) {
329                                    _log "no tags in range\n";
330                                    update_visible_tags();
331                                    $tags_data = {};
332                            } else {
333    
334                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
335                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
336                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
337    
338                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
339                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
340                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
341    
342                          my @tags;                                  update_visible_tags( @tags );
343                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
344                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
345                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
346    
347                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
348            return $tags_data;
349    
350                          update_visible_tags( @tags );  }
351                  }  
352          }  # start scanning for tags
 ) while(1);  
 #) foreach ( 1 .. 100 );  
353    
354    if ( $http_server ) {
355            http_server;
356    } else {
357            while (1) {
358                    scan_for_tags;
359                    sleep 1;
360            }
361    }
362    
363    die "over and out";
364    
365  sub update_visible_tags {  sub update_visible_tags {
366          my @tags = @_;          my @tags = @_;
# Line 202  sub update_visible_tags { Line 369  sub update_visible_tags {
369          $visible_tags = {};          $visible_tags = {};
370    
371          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
372                    $visible_tags->{$tag}++;
373                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
374                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
375  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
376                          } else {                          } else {
                                 meteor( 'read', $tag );  
377                                  read_tag( $tag );                                  read_tag( $tag );
378                          }                          }
                         $visible_tags->{$tag}++;  
379                  } else {                  } else {
380                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
381                  }                  }
382                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
383    
384                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
385                                  write_tag( $tag );                                  write_tag( $tag );
386                  }                  }
387                  if ( -e "$secure_path/$tag" ) {                  if ( -e "$secure_path/$tag" ) {
                                 meteor( 'secure', $tag );  
388                                  secure_tag( $tag );                                  secure_tag( $tag );
389                  }                  }
390          }          }
391    
392          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
393                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
394                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
395          }          }
396    
397          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
# Line 261  sub read_tag_data { Line 424  sub read_tag_data {
424          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
425    
426          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
427          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";
428    
429            return $last_block + 1;
430    }
431    
432    my $saved_in_log;
433    
434    sub decode_tag {
435            my $tag = shift;
436    
437            my $data = $tags_data->{$tag};
438            if ( ! $data ) {
439                    warn "no data for $tag\n";
440                    return;
441            }
442    
443            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
444            my $hash = {
445                    u1 => $u1,
446                    u2 => $u2,
447                    set => ( $set_item & 0xf0 ) >> 4,
448                    total => ( $set_item & 0x0f ),
449    
450                    type => $type,
451                    content => $content,
452    
453                    branch => $br_lib >> 20,
454                    library => $br_lib & 0x000fffff,
455    
456          return $last_block;                  custom => $custom,
457            };
458    
459            if ( ! $saved_in_log->{$tag}++ ) {
460                    open(my $log, '>>', 'rfid-log.txt');
461                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
462                    close($log);
463            }
464    
465            return $hash;
466    }
467    
468    sub forget_tag {
469            my $tag = shift;
470            delete $tags_data->{$tag};
471            delete $visible_tags->{$tag};
472  }  }
473    
474  sub read_tag {  sub read_tag {
# Line 278  sub read_tag { Line 483  sub read_tag {
483          while ( $start_block < $max_rfid_block ) {          while ( $start_block < $max_rfid_block ) {
484    
485                  cmd(                  cmd(
486                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     BEEF", $start_block, $read_blocks ),
487                                  "read $tag offset: $start_block blocks: $read_blocks",                                  "read $tag offset: $start_block blocks: $read_blocks",
488                          "D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";                          "D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
489                                  $start_block = read_tag_data( $start_block, @_ );                                  $start_block = read_tag_data( $start_block, @_ );
490                                  warn "# read tag upto $start_block\n";                                  warn "# read tag upto $start_block\n";
491                          },                          },
492                          "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                          "D6 00  0F  FE  00 00  05 01   $tag    BEEF", sub {
493                                  print "FIXME: tag $tag ready? (expected block read instead)\n";                                  print "FIXME: tag $tag ready? (expected block read instead)\n";
494                          },                          },
495                            "D6 00 0D 02 06 $tag", sub {
496                                    my $rest = shift;
497                                    print "ERROR reading $tag ", as_hex($rest), $/;
498                                    forget_tag $tag;
499                                    $start_block = $max_rfid_block; # XXX break out of while
500                            },
501                  );                  );
502    
503          }          }
# Line 294  sub read_tag { Line 505  sub read_tag {
505          my $security;          my $security;
506    
507          cmd(          cmd(
508                  "D6 00 0B 0A $tag 1234", "check security $tag",                  "D6 00 0B 0A $tag BEEF", "check security $tag",
509                  "D6 00 0D 0A 00", sub {                  "D6 00 0D 0A 00", sub {
510                          my $rest = shift;                          my $rest = shift;
511                          my $from_tag;                          my $from_tag;
512                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
513                          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 );
514                          $security = as_hex( $security );                          $security = as_hex( $security );
515                            $tags_security->{$tag} = $security;
516                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
517                  }                  },
518                    "D6 00 0C 0A 06", sub {
519                            my $rest = shift;
520                            warn "ERROR reading security from $rest\n";
521                            forget_tag $tag;
522                    },
523          );          );
524    
525          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";  
   
526  }  }
527    
528  sub write_tag {  sub write_tag {
529          my ($tag) = @_;          my ($tag,$data) = @_;
530    
531          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
532            $data = read_file( $path ) if -e $path;
533    
534            die "no data" unless $data;
535    
         my $data = read_file( $path );  
536          my $hex_data;          my $hex_data;
537    
538          if ( $data =~ s{^hex\s+}{} ) {          if ( $data =~ s{^hex\s+}{} ) {
# Line 348  sub write_tag { Line 560  sub write_tag {
560          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";          print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
561    
562          cmd(          cmd(
563                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  BEEF", "write $tag",
564                  "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  BEEF", sub { assert() },
565          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
566    
567          my $to = $path;          my $to = $path;
# Line 358  sub write_tag { Line 570  sub write_tag {
570          rename $path, $to;          rename $path, $to;
571          print ">> $to\n";          print ">> $to\n";
572    
573          delete $tags_data->{$tag};      # force re-read of tag          forget_tag $tag;
574    }
575    
576    sub secure_tag_with {
577            my ( $tag, $data ) = @_;
578    
579            cmd(
580                    "d6 00  0c  09  $tag $data BEEF", "secure $tag -> $data",
581                    "d6 00  0c  09 00  $tag    BEEF", sub { assert() },
582            );
583    
584            forget_tag $tag;
585  }  }
586    
587  sub secure_tag {  sub secure_tag {
# Line 367  sub secure_tag { Line 590  sub secure_tag {
590          my $path = "$secure_path/$tag";          my $path = "$secure_path/$tag";
591          my $data = substr(read_file( $path ),0,2);          my $data = substr(read_file( $path ),0,2);
592    
593          cmd(          secure_tag_with( $tag, $data );
                 "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",  
                 "d6 00  0c  09 00  $tag  1234", sub { assert() },  
         );  
594    
595          my $to = $path;          my $to = $path;
596          $to .= '.' . time();          $to .= '.' . time();
# Line 419  sub writechunk Line 639  sub writechunk
639  sub as_hex {  sub as_hex {
640          my @out;          my @out;
641          foreach my $str ( @_ ) {          foreach my $str ( @_ ) {
642                  my $hex = unpack( 'H*', $str );                  my $hex = uc unpack( 'H*', $str );
643                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;                  $hex =~ s/(..)/$1 /g if length( $str ) > 2;
644                  $hex =~ s/\s+$//;                  $hex =~ s/\s+$//;
645                  push @out, $hex;                  push @out, $hex;
# Line 433  sub read_bytes { Line 653  sub read_bytes {
653          while ( length( $data ) < $len ) {          while ( length( $data ) < $len ) {
654                  my ( $c, $b ) = $port->read(1);                  my ( $c, $b ) = $port->read(1);
655                  die "no bytes on port: $!" unless defined $b;                  die "no bytes on port: $!" unless defined $b;
656                  #warn "## got $c bytes: ", as_hex($b), "\n";                  warn "## got $c bytes: ", as_hex($b), "\n";
657                  $data .= $b;                  $data .= $b;
658          }          }
659          $desc ||= '?';          $desc ||= '?';
# Line 451  sub skip_assert { Line 671  sub skip_assert {
671  sub assert {  sub assert {
672          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
673    
         return unless $assert->{expect};  
   
674          $from ||= 0;          $from ||= 0;
675          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
676    
# Line 493  sub checksum { Line 711  sub checksum {
711          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;          warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
712    
713          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
714                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  warn "checksum error: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n" if $checksum ne "\xBE\xEF";
715                  return $bytes . $xor;                  return $bytes . $xor;
716          }          }
717          return $bytes . $checksum;          return $bytes . $checksum;
# Line 502  sub checksum { Line 720  sub checksum {
720  our $dispatch;  our $dispatch;
721    
722  sub readchunk {  sub readchunk {
723          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
724    
725          # read header of packet          # read header of packet
726          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 530  sub readchunk { Line 748  sub readchunk {
748          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
749          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
750    
751          if ( defined $to && $payload ) {          if ( defined $to ) {
752                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
753                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
754                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
755          } else {          } else {
756                  print "NO DISPATCH for ",dump( $full ),"\n";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
757          }          }
758    
759          return $data;          return $data;
Legend:
Removed from v.41  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.26