--- 3m-810.pl	2008/09/28 14:05:43	2
+++ 3m-810.pl	2008/09/28 22:15:29	10
@@ -7,6 +7,8 @@
 use Data::Dump qw/dump/;
 use Carp qw/confess/;
 
+my $debug = 0;
+
 my $response = {
 	'd500090400110a0500027250'				=> 'version?',
 	'd60007fe00000500c97b'					=> 'no tag in range',
@@ -75,20 +77,38 @@
 #$port->stty_inpck(1);
 #$port->stty_istrip(1);
 
-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 {
-	my ( $len, $payload, $checksum ) = @_;
-	assert( 0, 3 );
-	print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n";
+# 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 {
+	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
+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  05  FE     00  05  FA40', "XXX scan $_",
-     'D6 00  07  FE  00 00  05  00  C97B -- no tag' ) foreach ( 1 .. 10 );
+# start scanning for tags
 
-#     D6 00  0F  FE  00 00  05  01  E00401003123AA26  941A	 # seen
+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 ) );
+			my $tags = substr( $rest, 1 );
+
+			my $tl = length( $tags );
+			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
+
+			my @tags;
+			push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );
+			warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
+			print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";
+		}
+) }
+
+) foreach ( 1 .. 100 );
 
 cmd( 'D6 00  0D  02      E00401003123AA26   00   03     1CC4', 'read offset: 0 blocks: 3' );
 
@@ -133,7 +153,7 @@
 {
 	my $str=shift;
 	my $count = $port->write($str);
-	print ">> ", as_hex( $str ), "\t[$count]\n";
+	print "#> ", as_hex( $str ), "\t[$count]\n";
 }
 
 sub as_hex {
@@ -141,9 +161,10 @@
 	foreach my $str ( @_ ) {
 		my $hex = unpack( 'H*', $str );
 		$hex =~ s/(..)/$1 /g if length( $str ) > 2;
+		$hex =~ s/\s+$//;
 		push @out, $hex;
 	}
-	return join('  ', @out);
+	return join(' | ', @out);
 }
 
 sub read_bytes {
@@ -155,20 +176,59 @@
 		$data .= $b;
 	}
 	$desc ||= '?';
-	warn "#< ", as_hex($data), "\t$desc\n";
+	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
 	return $data;
 }
 
-my $assert;
+our $assert;
+
+# my $rest = skip_assert( 3 );
+sub skip_assert {
+	assert( 0, shift );
+}
 
 sub assert {
 	my ( $from, $to ) = @_;
 
-	warn "# assert ", dump( $assert );
+	$from ||= 0;
+	$to = length( $assert->{expect} ) if ! defined $to;
 
 	my $p = substr( $assert->{payload}, $from, $to );
 	my $e = substr( $assert->{expect},  $from, $to );
-	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), "\t[$from-$to]\n" if $e ne $p;
+	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
+
+	# return the rest
+	return substr( $assert->{payload}, $to );
+}
+
+our $dispatch;
+sub dispatch {
+	my ( $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;
+	}
+}
+
+# my $checksum = checksum( $bytes );
+# my $checksum = checksum( $bytes, $original_checksum );
+sub checksum {
+	my ( $bytes, $checksum ) = @_;
+
+	my $xor = $checksum; # FIXME
+
+	if ( defined $checksum && $xor ne $checksum ) {
+		print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
+	}
 }
 
 sub readchunk {
@@ -181,32 +241,34 @@
 	my $length = read_bytes( 1, 'length' );
 	my $len = ord($length);
 	my $data = read_bytes( $len, 'data' );
-	my ( $cmd ) = unpack('C', $data );
 
 	my $payload  = substr( $data, 0, -2 );
 	my $payload_len = length($data);
 	warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
+
 	my $checksum = substr( $data, -2, 2 );
-	# FIXME check checksum
+	checksum( $header . $length . $payload, $checksum );
 
-	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), "checksum: ", as_hex( $checksum ),"\n";
+	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";
 
 	$assert->{len}      = $len;
 	$assert->{payload}  = $payload;
-	$assert->{checksum} = $checksum;
 
-	$parser->( $len, $payload, $checksum ) if $parser && ref($parser) eq 'CODE';
+	$parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
 
 	return $data;
 }
 
 sub str2bytes {
 	my $str = shift || confess "no str?";
-	$str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;	# fix checksum
-	$str =~ s/\s+/\\x/g;
-	$str = '"\x' . $str . '"';
-	my $bytes = eval $str;
+	my $b = $str;
+	$b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;	# fix checksum
+	$b =~ s/\s+$//;
+	$b =~ s/\s+/\\x/g;
+	$b = '"\x' . $b . '"';
+	my $bytes = eval $b;
 	die $@ if $@;
+	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
 	return $bytes;
 }