| 1 |
#!/usr/bin/perl |
| 2 |
|
| 3 |
use Device::SerialPort qw (:STAT); |
| 4 |
use strict; |
| 5 |
use warnings; |
| 6 |
|
| 7 |
use Data::Dump qw/dump/; |
| 8 |
use Carp qw/confess/; |
| 9 |
use Getopt::Long; |
| 10 |
use File::Slurp; |
| 11 |
|
| 12 |
use IO::Socket::INET; |
| 13 |
|
| 14 |
my $meteor_server = '192.168.1.13:4671'; |
| 15 |
my $meteor_fh; |
| 16 |
|
| 17 |
sub meteor { |
| 18 |
my @a = @_; |
| 19 |
push @a, scalar localtime() if $a[0] =~ m{^info}; |
| 20 |
|
| 21 |
if ( ! defined $meteor_fh ) { |
| 22 |
warn "# open connection to $meteor_server"; |
| 23 |
$meteor_fh = IO::Socket::INET->new( |
| 24 |
PeerAddr => $meteor_server, |
| 25 |
Timeout => 1, |
| 26 |
) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production |
| 27 |
$meteor_fh = 0; # don't try again |
| 28 |
} |
| 29 |
|
| 30 |
warn ">> meteor ",dump( @a ); |
| 31 |
print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh; |
| 32 |
} |
| 33 |
|
| 34 |
my $debug = 0; |
| 35 |
|
| 36 |
my $device = "/dev/ttyUSB0"; |
| 37 |
my $baudrate = "19200"; |
| 38 |
my $databits = "8"; |
| 39 |
my $parity = "none"; |
| 40 |
my $stopbits = "1"; |
| 41 |
my $handshake = "none"; |
| 42 |
|
| 43 |
my $program_path = './program/'; |
| 44 |
my $secure_path = './secure/'; |
| 45 |
|
| 46 |
my $response = { |
| 47 |
'd500090400110a0500027250' => 'version?', |
| 48 |
'd60007fe00000500c97b' => 'no tag in range', |
| 49 |
|
| 50 |
'd6000ffe00000501e00401003123aa26941a' => 'tag #1', |
| 51 |
'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card', |
| 52 |
'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe', |
| 53 |
|
| 54 |
'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card', |
| 55 |
'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe', |
| 56 |
}; |
| 57 |
|
| 58 |
GetOptions( |
| 59 |
'd|debug+' => \$debug, |
| 60 |
'device=s' => \$device, |
| 61 |
'baudrate=i' => \$baudrate, |
| 62 |
'databits=i' => \$databits, |
| 63 |
'parity=s' => \$parity, |
| 64 |
'stopbits=i' => \$stopbits, |
| 65 |
'handshake=s' => \$handshake, |
| 66 |
'meteor=s' => \$meteor_server, |
| 67 |
) or die $!; |
| 68 |
|
| 69 |
my $verbose = $debug > 0 ? $debug-- : 0; |
| 70 |
|
| 71 |
=head1 NAME |
| 72 |
|
| 73 |
3m-810 - support for 3M 810 RFID reader |
| 74 |
|
| 75 |
=head1 SYNOPSIS |
| 76 |
|
| 77 |
3m-810.pl --device /dev/ttyUSB0 |
| 78 |
|
| 79 |
=head1 DESCRIPTION |
| 80 |
|
| 81 |
Communicate with 3M 810 RFID reader and document it's protocol |
| 82 |
|
| 83 |
=head1 SEE ALSO |
| 84 |
|
| 85 |
L<Device::SerialPort(3)> |
| 86 |
|
| 87 |
L<perl(1)> |
| 88 |
|
| 89 |
L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm> |
| 90 |
|
| 91 |
=head1 AUTHOR |
| 92 |
|
| 93 |
Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/> |
| 94 |
|
| 95 |
=head1 COPYRIGHT AND LICENSE |
| 96 |
|
| 97 |
This program is free software; you may redistribute it and/or modify |
| 98 |
it under the same terms ans Perl itself. |
| 99 |
|
| 100 |
=cut |
| 101 |
|
| 102 |
my $tags_data; |
| 103 |
my $visible_tags; |
| 104 |
|
| 105 |
my $item_type = { |
| 106 |
1 => 'Book', |
| 107 |
6 => 'CD/CD ROM', |
| 108 |
2 => 'Magazine', |
| 109 |
13 => 'Book with Audio Tape', |
| 110 |
9 => 'Book with CD/CD ROM', |
| 111 |
0 => 'Other', |
| 112 |
|
| 113 |
5 => 'Video', |
| 114 |
4 => 'Audio Tape', |
| 115 |
3 => 'Bound Journal', |
| 116 |
8 => 'Book with Diskette', |
| 117 |
7 => 'Diskette', |
| 118 |
}; |
| 119 |
|
| 120 |
warn "## known item type: ",dump( $item_type ) if $debug; |
| 121 |
|
| 122 |
my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n"; |
| 123 |
warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug; |
| 124 |
$handshake=$port->handshake($handshake); |
| 125 |
$baudrate=$port->baudrate($baudrate); |
| 126 |
$databits=$port->databits($databits); |
| 127 |
$parity=$port->parity($parity); |
| 128 |
$stopbits=$port->stopbits($stopbits); |
| 129 |
|
| 130 |
print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n"; |
| 131 |
|
| 132 |
# Just in case: reset our timing and buffers |
| 133 |
$port->lookclear(); |
| 134 |
$port->read_const_time(100); |
| 135 |
$port->read_char_time(5); |
| 136 |
|
| 137 |
# Turn on parity checking: |
| 138 |
#$port->stty_inpck(1); |
| 139 |
#$port->stty_istrip(1); |
| 140 |
|
| 141 |
# initial hand-shake with device |
| 142 |
|
| 143 |
cmd( 'D5 00 05 04 00 11 8C66', 'hw version', |
| 144 |
'D5 00 09 04 00 11 0A 05 00 02 7250', sub { |
| 145 |
my $hw_ver = join('.', unpack('CCCC', skip_assert(3) )); |
| 146 |
print "hardware version $hw_ver\n"; |
| 147 |
meteor( 'info', "Found reader hardware $hw_ver" ); |
| 148 |
}); |
| 149 |
|
| 150 |
cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?', |
| 151 |
'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } ); |
| 152 |
|
| 153 |
# start scanning for tags |
| 154 |
|
| 155 |
cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags, retry $_", |
| 156 |
'D6 00 0F FE 00 00 05 ', sub { # 01 E00401003123AA26 941A # seen, serial length: 8 |
| 157 |
my $rest = shift || die "no rest?"; |
| 158 |
my $nr = ord( substr( $rest, 0, 1 ) ); |
| 159 |
|
| 160 |
if ( ! $nr ) { |
| 161 |
print "no tags in range\n"; |
| 162 |
update_visible_tags(); |
| 163 |
meteor( 'info-none-in-range' ); |
| 164 |
$tags_data = {}; |
| 165 |
} else { |
| 166 |
|
| 167 |
my $tags = substr( $rest, 1 ); |
| 168 |
|
| 169 |
my $tl = length( $tags ); |
| 170 |
die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8; |
| 171 |
|
| 172 |
my @tags; |
| 173 |
push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 ); |
| 174 |
warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug; |
| 175 |
print "$nr tags in range: ", join(',', @tags ) , "\n"; |
| 176 |
|
| 177 |
meteor( 'info-in-range', join(' ',@tags)); |
| 178 |
|
| 179 |
update_visible_tags( @tags ); |
| 180 |
} |
| 181 |
} |
| 182 |
) while(1); |
| 183 |
#) foreach ( 1 .. 100 ); |
| 184 |
|
| 185 |
|
| 186 |
|
| 187 |
sub update_visible_tags { |
| 188 |
my @tags = @_; |
| 189 |
|
| 190 |
my $last_visible_tags = $visible_tags; |
| 191 |
$visible_tags = {}; |
| 192 |
|
| 193 |
foreach my $tag ( @tags ) { |
| 194 |
if ( ! defined $last_visible_tags->{$tag} ) { |
| 195 |
if ( defined $tags_data->{$tag} ) { |
| 196 |
# meteor( 'in-range', $tag ); |
| 197 |
} else { |
| 198 |
meteor( 'read', $tag ); |
| 199 |
read_tag( $tag ); |
| 200 |
} |
| 201 |
$visible_tags->{$tag}++; |
| 202 |
} else { |
| 203 |
warn "## using cached data for $tag" if $debug; |
| 204 |
} |
| 205 |
delete $last_visible_tags->{$tag}; # leave just missing tags |
| 206 |
|
| 207 |
if ( -e "$program_path/$tag" ) { |
| 208 |
meteor( 'write', $tag ); |
| 209 |
write_tag( $tag ); |
| 210 |
} |
| 211 |
if ( -e "$secure_path/$tag" ) { |
| 212 |
meteor( 'secure', $tag ); |
| 213 |
secure_tag( $tag ); |
| 214 |
} |
| 215 |
} |
| 216 |
|
| 217 |
foreach my $tag ( keys %$last_visible_tags ) { |
| 218 |
my $data = delete $tags_data->{$tag}; |
| 219 |
print "removed tag $tag with data ",dump( $data ),"\n"; |
| 220 |
meteor( 'removed', $tag ); |
| 221 |
} |
| 222 |
|
| 223 |
warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug; |
| 224 |
} |
| 225 |
|
| 226 |
my $tag_data_block; |
| 227 |
|
| 228 |
sub read_tag_data { |
| 229 |
my ($start_block,$rest) = @_; |
| 230 |
die "no rest?" unless $rest; |
| 231 |
warn "## DATA [$start_block] ", dump( $rest ) if $debug; |
| 232 |
my $tag = uc(unpack('H16',substr( $rest, 0, 8 ))); |
| 233 |
my $blocks = ord(substr($rest,8,1)); |
| 234 |
$rest = substr($rest,9); # leave just data blocks |
| 235 |
foreach my $nr ( 0 .. $blocks - 1 ) { |
| 236 |
my $block = substr( $rest, $nr * 6, 6 ); |
| 237 |
warn "## block ",as_hex( $block ) if $debug; |
| 238 |
my $ord = unpack('v',substr( $block, 0, 2 )); |
| 239 |
my $expected_ord = $nr + $start_block; |
| 240 |
die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord; |
| 241 |
my $data = substr( $block, 2 ); |
| 242 |
die "data payload should be 4 bytes" if length($data) != 4; |
| 243 |
warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data; |
| 244 |
$tag_data_block->{$tag}->[ $ord ] = $data; |
| 245 |
} |
| 246 |
$tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} }); |
| 247 |
|
| 248 |
my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 )); |
| 249 |
print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n"; |
| 250 |
} |
| 251 |
|
| 252 |
sub read_tag { |
| 253 |
my ( $tag ) = @_; |
| 254 |
|
| 255 |
confess "no tag?" unless $tag; |
| 256 |
|
| 257 |
print "read_tag $tag\n"; |
| 258 |
|
| 259 |
cmd( |
| 260 |
"D6 00 0D 02 $tag 00 03 1CC4", "read $tag offset: 0 blocks: 3", |
| 261 |
"D6 00 0F FE 00 00 05 01 $tag 941A", sub { |
| 262 |
print "FIXME: tag $tag ready?\n"; |
| 263 |
}, |
| 264 |
"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"; |
| 265 |
read_tag_data( 0, @_ ); |
| 266 |
}, |
| 267 |
); |
| 268 |
|
| 269 |
cmd( |
| 270 |
"D6 00 0D 02 $tag 03 04 3970", "read $tag offset: 3 blocks: 4", |
| 271 |
"D6 00 25 02 00", sub { # $tag 04 03 00 30 30 00 00 04 00 00 00 00 00 |
| 272 |
read_tag_data( 3, @_ ); |
| 273 |
} |
| 274 |
); |
| 275 |
|
| 276 |
my $security; |
| 277 |
|
| 278 |
cmd( |
| 279 |
"D6 00 0B 0A $tag 1234", "check security $tag", |
| 280 |
"D6 00 0D 0A 00", sub { |
| 281 |
my $rest = shift; |
| 282 |
my $from_tag; |
| 283 |
( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) ); |
| 284 |
die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag ); |
| 285 |
$security = as_hex( $security ); |
| 286 |
warn "# SECURITY $tag = $security\n"; |
| 287 |
} |
| 288 |
); |
| 289 |
|
| 290 |
my $data = $tags_data->{$tag} || die "no data for $tag"; |
| 291 |
my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data); |
| 292 |
my $set = ( $set_item & 0xf0 ) >> 4; |
| 293 |
my $total = ( $set_item & 0x0f ); |
| 294 |
my $branch = $br_lib >> 20; |
| 295 |
my $library = $br_lib & 0x000fffff; |
| 296 |
print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n"; |
| 297 |
|
| 298 |
} |
| 299 |
|
| 300 |
sub write_tag { |
| 301 |
my ($tag) = @_; |
| 302 |
|
| 303 |
my $path = "$program_path/$tag"; |
| 304 |
|
| 305 |
my $data = read_file( $path ); |
| 306 |
|
| 307 |
$data = substr($data,0,16); |
| 308 |
|
| 309 |
my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) ); |
| 310 |
|
| 311 |
print "write_tag $tag = $data ",dump( $hex_data ); |
| 312 |
|
| 313 |
cmd( |
| 314 |
"d6 00 26 04 $tag 00 06 00 04 11 00 01 $hex_data 00 00 00 00 fd3b", "write $tag", |
| 315 |
"d6 00 0d 04 00 $tag 06 afb1", sub { assert() }, |
| 316 |
) foreach ( 1 .. 3 ); # xxx 3m software does this three times! |
| 317 |
|
| 318 |
my $to = $path; |
| 319 |
$to .= '.' . time(); |
| 320 |
|
| 321 |
rename $path, $to; |
| 322 |
print ">> $to\n"; |
| 323 |
|
| 324 |
delete $tags_data->{$tag}; # force re-read of tag |
| 325 |
} |
| 326 |
|
| 327 |
sub secure_tag { |
| 328 |
my ($tag) = @_; |
| 329 |
|
| 330 |
my $path = "$secure_path/$tag"; |
| 331 |
my $data = substr(read_file( $path ),0,2); |
| 332 |
|
| 333 |
cmd( |
| 334 |
"d6 00 0c 09 $tag $data 1234", "secure $tag -> $data", |
| 335 |
"d6 00 0c 09 00 $tag 1234", sub { assert() }, |
| 336 |
); |
| 337 |
|
| 338 |
my $to = $path; |
| 339 |
$to .= '.' . time(); |
| 340 |
|
| 341 |
rename $path, $to; |
| 342 |
print ">> $to\n"; |
| 343 |
} |
| 344 |
|
| 345 |
exit; |
| 346 |
|
| 347 |
for ( 1 .. 3 ) { |
| 348 |
|
| 349 |
# ++-->type 00-0a |
| 350 |
# D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4 |
| 351 |
# D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7 |
| 352 |
# D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F |
| 353 |
|
| 354 |
cmd(' D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00 8843', "write offset 0, block: 7 -- 0000000000 $_" ); |
| 355 |
warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n"; |
| 356 |
|
| 357 |
} |
| 358 |
warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n"; |
| 359 |
|
| 360 |
cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 ); |
| 361 |
|
| 362 |
cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?', |
| 363 |
'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' ); |
| 364 |
cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?', |
| 365 |
'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' ); |
| 366 |
|
| 367 |
cmd('D6 00 26 04 E00401003123AA26 00 06 00 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 A98B', 'blank offset: 0 blocks: 6', |
| 368 |
'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 ); |
| 369 |
|
| 370 |
undef $port; |
| 371 |
print "Port closed\n"; |
| 372 |
|
| 373 |
sub writechunk |
| 374 |
{ |
| 375 |
my $str=shift; |
| 376 |
my $count = $port->write($str); |
| 377 |
print "#> ", as_hex( $str ), "\t[$count]\n" if $debug; |
| 378 |
} |
| 379 |
|
| 380 |
sub as_hex { |
| 381 |
my @out; |
| 382 |
foreach my $str ( @_ ) { |
| 383 |
my $hex = unpack( 'H*', $str ); |
| 384 |
$hex =~ s/(..)/$1 /g if length( $str ) > 2; |
| 385 |
$hex =~ s/\s+$//; |
| 386 |
push @out, $hex; |
| 387 |
} |
| 388 |
return join(' | ', @out); |
| 389 |
} |
| 390 |
|
| 391 |
sub read_bytes { |
| 392 |
my ( $len, $desc ) = @_; |
| 393 |
my $data = ''; |
| 394 |
while ( length( $data ) < $len ) { |
| 395 |
my ( $c, $b ) = $port->read(1); |
| 396 |
die "no bytes on port: $!" unless defined $b; |
| 397 |
#warn "## got $c bytes: ", as_hex($b), "\n"; |
| 398 |
$data .= $b; |
| 399 |
} |
| 400 |
$desc ||= '?'; |
| 401 |
warn "#< ", as_hex($data), "\t$desc\n" if $debug; |
| 402 |
return $data; |
| 403 |
} |
| 404 |
|
| 405 |
our $assert; |
| 406 |
|
| 407 |
# my $rest = skip_assert( 3 ); |
| 408 |
sub skip_assert { |
| 409 |
assert( 0, shift ); |
| 410 |
} |
| 411 |
|
| 412 |
sub assert { |
| 413 |
my ( $from, $to ) = @_; |
| 414 |
|
| 415 |
$from ||= 0; |
| 416 |
$to = length( $assert->{expect} ) if ! defined $to; |
| 417 |
|
| 418 |
my $p = substr( $assert->{payload}, $from, $to ); |
| 419 |
my $e = substr( $assert->{expect}, $from, $to ); |
| 420 |
warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p; |
| 421 |
|
| 422 |
# return the rest |
| 423 |
return substr( $assert->{payload}, $to ); |
| 424 |
} |
| 425 |
|
| 426 |
use Digest::CRC; |
| 427 |
|
| 428 |
sub crcccitt { |
| 429 |
my $bytes = shift; |
| 430 |
my $crc = Digest::CRC->new( |
| 431 |
# midified CCITT to xor with 0xffff instead of 0x0000 |
| 432 |
width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0, |
| 433 |
) or die $!; |
| 434 |
$crc->add( $bytes ); |
| 435 |
pack('n', $crc->digest); |
| 436 |
} |
| 437 |
|
| 438 |
# my $checksum = checksum( $bytes ); |
| 439 |
# my $checksum = checksum( $bytes, $original_checksum ); |
| 440 |
sub checksum { |
| 441 |
my ( $bytes, $checksum ) = @_; |
| 442 |
|
| 443 |
my $xor = crcccitt( substr($bytes,1) ); # skip D6 |
| 444 |
warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug; |
| 445 |
|
| 446 |
my $len = ord(substr($bytes,2,1)); |
| 447 |
my $len_real = length($bytes) - 1; |
| 448 |
|
| 449 |
if ( $len_real != $len ) { |
| 450 |
print "length wrong: $len_real != $len\n"; |
| 451 |
$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4); |
| 452 |
} |
| 453 |
|
| 454 |
if ( defined $checksum && $xor ne $checksum ) { |
| 455 |
print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n"; |
| 456 |
return $bytes . $xor; |
| 457 |
} |
| 458 |
return $bytes . $checksum; |
| 459 |
} |
| 460 |
|
| 461 |
our $dispatch; |
| 462 |
|
| 463 |
sub readchunk { |
| 464 |
sleep 1; # FIXME remove |
| 465 |
|
| 466 |
# read header of packet |
| 467 |
my $header = read_bytes( 2, 'header' ); |
| 468 |
my $length = read_bytes( 1, 'length' ); |
| 469 |
my $len = ord($length); |
| 470 |
my $data = read_bytes( $len, 'data' ); |
| 471 |
|
| 472 |
my $payload = substr( $data, 0, -2 ); |
| 473 |
my $payload_len = length($data); |
| 474 |
warn "## payload too short $payload_len != $len\n" if $payload_len != $len; |
| 475 |
|
| 476 |
my $checksum = substr( $data, -2, 2 ); |
| 477 |
checksum( $header . $length . $payload , $checksum ); |
| 478 |
|
| 479 |
print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose; |
| 480 |
|
| 481 |
$assert->{len} = $len; |
| 482 |
$assert->{payload} = $payload; |
| 483 |
|
| 484 |
my $full = $header . $length . $data; # full |
| 485 |
# find longest match for incomming data |
| 486 |
my ($to) = grep { |
| 487 |
my $match = substr($payload,0,length($_)); |
| 488 |
m/^\Q$match\E/ |
| 489 |
} sort { length($a) <=> length($b) } keys %$dispatch; |
| 490 |
warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug; |
| 491 |
|
| 492 |
if ( defined $to ) { |
| 493 |
my $rest = substr( $payload, length($to) ); |
| 494 |
warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug; |
| 495 |
$dispatch->{ $to }->( $rest ); |
| 496 |
} else { |
| 497 |
print "NO DISPATCH for ",dump( $full ),"\n"; |
| 498 |
} |
| 499 |
|
| 500 |
return $data; |
| 501 |
} |
| 502 |
|
| 503 |
sub str2bytes { |
| 504 |
my $str = shift || confess "no str?"; |
| 505 |
my $b = $str; |
| 506 |
$b =~ s/\s+//g; |
| 507 |
$b =~ s/(..)/\\x$1/g; |
| 508 |
$b = "\"$b\""; |
| 509 |
my $bytes = eval $b; |
| 510 |
die $@ if $@; |
| 511 |
warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug; |
| 512 |
return $bytes; |
| 513 |
} |
| 514 |
|
| 515 |
sub cmd { |
| 516 |
my $cmd = shift || confess "no cmd?"; |
| 517 |
my $cmd_desc = shift || confess "no description?"; |
| 518 |
my @expect = @_; |
| 519 |
|
| 520 |
my $bytes = str2bytes( $cmd ); |
| 521 |
|
| 522 |
# fix checksum if needed |
| 523 |
$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) ); |
| 524 |
|
| 525 |
warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose; |
| 526 |
$assert->{send} = $cmd; |
| 527 |
writechunk( $bytes ); |
| 528 |
|
| 529 |
while ( @expect ) { |
| 530 |
my $pattern = str2bytes( shift @expect ) || confess "no pattern?"; |
| 531 |
my $coderef = shift @expect || confess "no coderef?"; |
| 532 |
confess "not coderef" unless ref $coderef eq 'CODE'; |
| 533 |
|
| 534 |
next if defined $dispatch->{ $pattern }; |
| 535 |
|
| 536 |
$dispatch->{ substr($pattern,3) } = $coderef; |
| 537 |
warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug; |
| 538 |
} |
| 539 |
|
| 540 |
readchunk; |
| 541 |
} |
| 542 |
|
Parent Directory
| 
Revision Log