--- 3m-810.pl	2009/04/08 15:03:49	34
+++ 3m-810.pl	2009/06/01 21:07:11	39
@@ -19,16 +19,23 @@
 	push @a, scalar localtime() if $a[0] =~ m{^info};
 
 	if ( ! defined $meteor_fh ) {
-		warn "# open connection to $meteor_server";
-		$meteor_fh = IO::Socket::INET->new(
-				PeerAddr => $meteor_server,
-				Timeout => 1,
-		) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
-		$meteor_fh = 0; # don't try again
+		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;
+		}
 	}
 
-	warn ">> meteor ",dump( @a );
-	print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
+	if ( $meteor_fh ) {
+		warn ">> meteor ",dump( @a );
+		print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
+	}
 }
 
 my $debug = 0;
@@ -293,7 +300,7 @@
 	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' branch: $branch library: $library custom: $custom security: $security\n";
+	print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' library: $library branch: $branch custom: $custom security: $security\n";
 
 }
 
@@ -303,16 +310,34 @@
 	my $path = "$program_path/$tag";
 
 	my $data = read_file( $path );
+	my $hex_data;
+
+	if ( $data =~ s{^hex\s+}{} ) {
+		$hex_data = $data;
+		$hex_data =~ s{\s+}{}g;
+	} else {
+
+		# pad to block size
+		$data .= "\0" x ( 4 - ( length($data) % 4 ) );
+
+		my $max_len = 7 * 4;
+
+		if ( length($data) > $max_len ) {
+			$data = substr($data,0,$max_len);
+			warn "strip content to $max_len bytes\n";
+		}
 
-	$data = substr($data,0,16);
+		$hex_data = unpack('H*', $data);
+	}
 
-	my $hex_data = unpack('h*', $data) . ' 00' x ( 16 - length($data) );
+	my $len = length($hex_data) / 2;
+	my $blocks = sprintf('%02x', $len / 4);
 
-	print "write_tag $tag = $data ",dump( $hex_data );
+	print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
 
 	cmd(
-		"d6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  fd3b", "write $tag",
-		"d6 00  0d  04 00  $tag  06  afb1", sub { assert() },
+		"d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
+		"d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
 	) foreach ( 1 .. 3 ); # xxx 3m software does this three times!
 
 	my $to = $path;
@@ -374,6 +399,8 @@
 {
 	my $str=shift;
 	my $count = $port->write($str);
+	my $len = length($str);
+	die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
 	print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
 }
 
@@ -412,6 +439,8 @@
 sub assert {
 	my ( $from, $to ) = @_;
 
+	return unless $assert->{expect};
+
 	$from ||= 0;
 	$to = length( $assert->{expect} ) if ! defined $to;
 
@@ -440,17 +469,17 @@
 sub checksum {
 	my ( $bytes, $checksum ) = @_;
 
-	my $xor = crcccitt( substr($bytes,1) );	# skip D6
-	warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
-
 	my $len = ord(substr($bytes,2,1));
 	my $len_real = length($bytes) - 1;
 
 	if ( $len_real != $len ) {
 		print "length wrong: $len_real != $len\n";
-		$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
+		$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
 	}
 
+	my $xor = crcccitt( substr($bytes,1) );	# skip D6
+	warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
+
 	if ( defined $checksum && $xor ne $checksum ) {
 		print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
 		return $bytes . $xor;
@@ -489,7 +518,7 @@
 	} sort { length($a) <=> length($b) } keys %$dispatch;
 	warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
 
-	if ( defined $to ) {
+	if ( defined $to && $payload ) {
 		my $rest = substr( $payload, length($to) );
 		warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
 		$dispatch->{ $to }->( $rest );