/[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 43 by dpavlin, Tue Jun 23 12:19:30 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;
   
         if ( ! defined $meteor_fh ) {  
                 if ( $meteor_fh =  
                                 IO::Socket::INET->new(  
                                         PeerAddr => $meteor_server,  
                                         Timeout => 1,  
                                 )  
                 ) {  
                         warn "# meteor connected to $meteor_server";  
                 } else {  
                         warn "can't connect to meteor $meteor_server: $!";  
                         $meteor_fh = 0;  
                 }  
         }  
   
         if ( $meteor_fh ) {  
                 warn ">> meteor ",dump( @a );  
                 print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"  
         }  
 }  
21    
22  my $listen_port = 9000;                  # pick something not in use  my $listen_port = 9000;                  # pick something not in use
23    my $server_url  = "http://localhost:$listen_port";
24    
25  sub http_server {  sub http_server {
26    
27          my $server = IO::Socket::INET->new(          my $server = IO::Socket::INET->new(
# Line 48  sub http_server { Line 31  sub http_server {
31                  Reuse     => 1                  Reuse     => 1
32          );          );
33                                                                                                                                        
34          die "can't setup server" unless $server;          die "can't setup server: $!" unless $server;
35    
36          print "Server $0 accepting clients at http://localhost:$listen_port/\n";          print "Server $0 ready at $server_url\n";
37    
38          sub static {          sub static {
39                  my ($client,$path) = @_;                  my ($client,$path) = @_;
40    
41                  $path = "www/$path";                  $path = "www/$path";
42                    $path .= 'rfid.html' if $path =~ m{/$};
43    
44                  return unless -e $path;                  return unless -e $path;
45    
# Line 77  sub http_server { Line 61  sub http_server {
61                  $client->autoflush(1);                  $client->autoflush(1);
62                  my $request = <$client>;                  my $request = <$client>;
63    
64                  warn "<< $request\n";                  warn "WEB << $request\n" if $debug;
65    
66                  if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {                  if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                          my $method = $1;                          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 ) ) {                          if ( my $path = static( $client,$1 ) ) {
77                                  warn ">> $path";                                  warn "WEB >> $path" if $debug;
78                          } elsif ( $method =~ m{/scan} ) {                          } elsif ( $method =~ m{/scan} ) {
                                 print $client "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\n";  
79                                  my $tags = scan_for_tags();                                  my $tags = scan_for_tags();
80                                  print $client "tags: ",dump($tags);                                  my $json = { time => time() };
81                                  my $json;                                  map {
82                                  map { $json->{$_} = decode_tag($_) } keys %$tags;                                          my $d = decode_tag($_);
83                                  print $client "decoded: ",dump( $json );                                          $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 {                          } else {
131                                  print $client "HTTP/1.0 404 Unkown method\r\n";                                  print $client "HTTP/1.0 404 Unkown method\r\n\r\n";
132                          }                          }
133                  } else {                  } else {
134                          print $client "HTTP/1.0 500 No method\r\n";                          print $client "HTTP/1.0 500 No method\r\n\r\n";
135                  }                  }
136                  close $client;                  close $client;
137          }          }
# Line 102  sub http_server { Line 139  sub http_server {
139          die "server died";          die "server died";
140  }  }
141    
142  my $debug = 0;  
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    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    
# Line 118  my $secure_path = './secure/'; Line 168  my $secure_path = './secure/';
168  my $http_server = 1;  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 141  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 177  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 205  $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 216  $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?',
# Line 232  sub scan_for_tags { Line 320  sub scan_for_tags {
320    
321          my @tags;          my @tags;
322    
323          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          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                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
325                          my $rest = shift || die "no rest?";                          my $rest = shift || die "no rest?";
326                          my $nr = ord( substr( $rest, 0, 1 ) );                          my $nr = ord( substr( $rest, 0, 1 ) );
327    
328                          if ( ! $nr ) {                          if ( ! $nr ) {
329                                  print "no tags in range\n";                                  _log "no tags in range\n";
330                                  update_visible_tags();                                  update_visible_tags();
                                 meteor( 'info-none-in-range' );  
331                                  $tags_data = {};                                  $tags_data = {};
332                          } else {                          } else {
333    
334                                  my $tags = substr( $rest, 1 );                                  my $tags = substr( $rest, 1 );
   
335                                  my $tl = length( $tags );                                  my $tl = length( $tags );
336                                  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;
337    
338                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
339                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
340                                  print "$nr tags in range: ", join(',', @tags ) , "\n";                                  _log "$nr tags in range: ", join(',', @tags ) , "\n";
   
                                 meteor( 'info-in-range', join(' ',@tags));  
341    
342                                  update_visible_tags( @tags );                                  update_visible_tags( @tags );
343                          }                          }
344                  }                  }
345          );          );
346    
347          warn "## tags: ",dump( @tags );          diag "tags: ",dump( @tags );
348          return $tags_data;          return $tags_data;
349    
350  }  }
# Line 270  sub scan_for_tags { Line 354  sub scan_for_tags {
354  if ( $http_server ) {  if ( $http_server ) {
355          http_server;          http_server;
356  } else {  } else {
357          scan_for_tags while 1;          while (1) {
358                    scan_for_tags;
359                    sleep 1;
360            }
361  }  }
362    
363  die "over and out";  die "over and out";
# Line 282  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 346  sub read_tag_data { Line 429  sub read_tag_data {
429          return $last_block + 1;          return $last_block + 1;
430  }  }
431    
432    my $saved_in_log;
433    
434  sub decode_tag {  sub decode_tag {
435          my $tag = shift;          my $tag = shift;
436    
437          my $data = $tags_data->{$tag} || die "no data for $tag";          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);          my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
444          my $hash = {          my $hash = {
# Line 367  sub decode_tag { Line 456  sub decode_tag {
456                  custom => $custom,                  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;          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 {
475          my ( $tag ) = @_;          my ( $tag ) = @_;
476    
# Line 382  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 398  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          print "TAG $tag ", dump(decode_tag( $tag ));          print "TAG $tag ", dump(decode_tag( $tag ));
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 445  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 455  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 464  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 516  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 530  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 588  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 630  sub readchunk { Line 753  sub readchunk {
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.43  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.26