--- 3m-810.pl 2008/10/03 15:38:08 19 +++ 3m-810.pl 2008/10/03 21:25:02 20 @@ -91,23 +91,30 @@ # initial hand-shake with device -cmd( 'D5 00 05 04 00 11 8C66', 'hw version?', - 'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub { +cmd( 'D5 00 05 04 00 11 8C66', 'hw version', + 'D5 00 09 04 00 11 0A 05 00 02 7250', sub { print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n"; }); -cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?', - 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert() } ); +cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?', + 'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } ); # start scanning for tags -cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_", - 'D6 00 07 FE 00 00 05 00 C97B', 'no tag', sub { -dispatch( - 'D6 00 0F FE 00 00 05 ',# 01 E00401003123AA26 941A # seen, serial length: 8 - sub { - my $rest = shift || die "no rest?"; - my $nr = ord( substr( $rest, 0, 1 ) ); +cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags, retry $_", + 'D6 00 07 FE 00 00 05 00 C97B', sub { + assert(); + print "no tag in range\n"; + + }, + '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"; + } else { + my $tags = substr( $rest, 1 ); my $tl = length( $tags ); @@ -122,8 +129,7 @@ read_tag( $_ ) foreach @tags; } -) } - + } ) foreach ( 1 .. 100 ); my $read_cached; @@ -131,18 +137,24 @@ sub read_tag { my ( $tag ) = @_; - print "read_tag $tag\n"; return if $read_cached->{ $tag }++; + + print "read_tag $tag\n"; - cmd( "D6 00 0D 02 $tag 00 03 1CC4", 'read $tag offset: 0 blocks: 3', - "D6 00 0F FE 00 00 05 01 $tag 941A", "$tag ready?", sub { -dispatch( "D6 00 1F 02 00 $tag ", sub { # 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n"; + cmd( + "D6 00 0D 02 $tag 00 03 1CC4", 'read $tag offset: 0 blocks: 3', + "D6 00 0F FE 00 00 05 01 $tag 941A", sub { + print "FIXME: tag $tag ready?\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"; my $rest = shift || die "no rest?"; warn "## DATA ", dump( $rest ) if $debug; - my $blocks = ord(substr($rest,0,1)); + my $tag = uc(unpack('H16',substr( $rest, 0, 8 ))); + my $blocks = ord(substr($rest,8,1)); + $rest = substr($rest,9); # leave just data blocks my @data; foreach my $nr ( 0 .. $blocks - 1 ) { - my $block = substr( $rest, 1 + $nr * 6, 6 ); + my $block = substr( $rest, $nr * 6, 6 ); warn "## block ",as_hex( $block ) if $debug; my $ord = unpack('v',substr( $block, 0, 2 )); die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr; @@ -152,9 +164,9 @@ $data[ $ord ] = $data; } $read_cached->{ $tag } = join('', @data); - print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n"; - }) - }); + print "DATA $tag ",dump( $read_cached ), "\n"; + } + ); # D6 00 1F 02 00 $tag 03 00 00 04 11 00 01 01 00 30 30 30 30 02 00 30 30 30 30 E5F4 if (0) { @@ -248,27 +260,6 @@ return substr( $assert->{payload}, $to ); } -our $dispatch; -sub dispatch { - my ( $pattern, $coderef ) = @_; - - $dispatch->{ $pattern } = $coderef; - - my $patt = substr( str2bytes($pattern), 3 ); # just payload - my $l = length($patt); - my $p = substr( $assert->{payload}, 0, $l ); - warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug; - - if ( $assert->{payload} eq $assert->{expect} ) { - warn "## no dispatch, payload expected" if $debug; - } elsif ( $p eq $patt ) { - # if matched call with rest of payload - $coderef->( substr( $assert->{payload}, $l ) ); - } else { - warn "## dispatch ignored" if $debug; - } -} - use Digest::CRC; sub crcccitt { @@ -304,9 +295,9 @@ return $bytes . $checksum; } -sub readchunk { - my ( $parser ) = @_; +our $dispatch; +sub readchunk { sleep 1; # FIXME remove # read header of packet @@ -320,14 +311,28 @@ warn "## payload too short $payload_len != $len\n" if $payload_len != $len; my $checksum = substr( $data, -2, 2 ); - checksum( $header . $length . $payload, $checksum ); + checksum( $header . $length . $payload , $checksum ); print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n"; $assert->{len} = $len; $assert->{payload} = $payload; - $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE'; + my $full = $header . $length . $data; # full + # find longest match for incomming data + my ($to) = grep { + my $match = substr($payload,0,length($_)); + m/^\Q$match\E/ + } sort { length($a) <=> length($b) } keys %$dispatch; + warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug; + + if ( defined $to ) { + my $rest = substr( $payload, length($to) ); + warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug; + $dispatch->{ $to }->( $rest ); + } else { + print "NO DISPATCH for ",dump( $full ),"\n"; + } return $data; } @@ -345,7 +350,10 @@ } sub cmd { - my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_; + my $cmd = shift || confess "no cmd?"; + my $cmd_desc = shift || confess "no description?"; + my @expect = @_; + my $bytes = str2bytes( $cmd ); # fix checksum if needed @@ -355,10 +363,17 @@ $assert->{send} = $cmd; writechunk( $bytes ); - if ( $expect ) { - warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n"; - $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload - readchunk( $coderef ); + while ( @expect ) { + my $pattern = str2bytes( shift @expect ) || confess "no pattern?"; + my $coderef = shift @expect || confess "no coderef?"; + confess "not coderef" unless ref $coderef eq 'CODE'; + + next if defined $dispatch->{ $pattern }; + + $dispatch->{ substr($pattern,3) } = $coderef; + warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug; } + + readchunk; }