package EVEcommon;

use strict;

use Exporter;
use base qw( Exporter );
use vars qw( @EXPORT $debug );
@EXPORT = qw( prettyisk shortprettyisk
		prettytime prettybyte 
		demacho hexdump );

sub prettybyte {
	my ($byte,) = @_;
	my $st = sprintf "%iB", $byte;
	if ($byte > 1024**3) {
		$st = sprintf "%.2fGB", $byte/(1024**3);
	} elsif ($byte > 1024**2) {
		$st = sprintf "%.2fMB", $byte/(1024**2);
	} elsif ($byte > 1024) {
		$st = sprintf "%.2fkB", $byte/1024;
	}
	return $st;
}

sub prettyisk {
	my ($price,) = @_;
	my $st = $price;
	while ($st =~ s/(\d)(\d\d\d)($|\D)/$1.$2$3/) {  };
	$st .= " ISK";
	if ($price > 1000**2) {
		$st .= " (".&shortprettyisk($price).")";
	}
	return $st;
}

sub shortprettyisk {
	my ($price,) = @_;
	return "n/a" unless defined $price;
	my $short = $price;
	if ($price > 1000**3) {
		$short = sprintf "%.1fG", $price/(1000**3);
	} elsif ($price > 1000**2) {
		$short = sprintf "%.1fM", $price/(1000**2);
	} elsif ($price > 1000) {
		$short = sprintf "%.1fk", $price/(1000);
	} else {
		$short = sprintf "%.2f", $price;
	}
	return $short;
}

sub prettytime {
	my ($sec,$togo,$nulls,) = @_;
	$togo ||= 3;
	$nulls = 1 unless defined $nulls;

	my $st = "";
	if ($sec > 60*60*24*365) {
		$st .= sprintf "%iy", int($sec/(60*60*24*365));
		$sec %= 60*60*24*365;
		$togo--;
	}
	if ($togo && (($st && $nulls) || $sec > 60*60*24*7)) {
		$st .= sprintf "%iw", int($sec/(60*60*24*7));
		$sec %= 60*60*24*7;
		$togo--;
	}
	if ($togo && (($st && $nulls) || $sec > 60*60*24)) {
		$st .= sprintf "%id", int($sec/(60*60*24));
		$sec %= 60*60*24;
		$togo--;
	}
	if ($togo && (($st && $nulls) || $sec > 60*60)) {
		$st .= sprintf "%ih", int($sec/(60*60));
		$sec %= 60*60;
		$togo--;
	}
	if ($togo && (($st && $nulls) || $sec > 60)) {
		$st .= sprintf "%im", int($sec/60);
		$sec %= 60;
		$togo--;
	}
	if ($togo && $sec) {
		$st .= sprintf "%is", int($sec);
		$togo--;
	}

	return $st;
}


# most looked up in sql data, some guessing
my $machostrings = {
	 3 => 'age',
	 4 => 'Asteroid',
	 8 => 'bloodlineID',
	 9 => 'capacity',
	10 => 'categoryID',
	12 => 'characterID',
	13 => 'characterName',
	20 => 'corporationDateTime',
	21 => 'corporationID',
	22 => 'createDateTime',
	24 => 'description', 
	25 => 'divisionID',
	33 => 'gender',
	34 => 'graphicID',
	35 => 'groupID',
	36 => 'header',
	39 => 'itemID',
	40 => 'items',
	41 => 'jumps',
	43 => '?datarows?',
	44 => 'locationID',
	45 => 'locationName',
	54 => '?cacheObject?',
	62 => 'orbitID',
	63 => 'ownerID',
	64 => 'ownerName',
	65 => 'quantity',
	66 => 'raceID',
	67 => '?rowType?',
	72 => 'skillEffect',
	74 => 'typeID',
	75 => 'used',
	81 => '?Rows?',
	116 => 'bid',
	122 => 'corporationID',
	125 => 'damage',
	126 => 'duration',
	127 => 'effects.Laser',
	131 => 'issued',
	135 => 'protocol',
	136 => 'market',
	137 => 'minVolume',
	138 => 'orderID',
	139 => 'price',
	140 => 'range',
	141 => 'regionID',
	142 => 'regionID', # haeh?
	150 => 'solarSystemID',
	155 => 'stationID',
	160 => 'volEntered',
	161 => 'volremain',

	};

my $rowdescr;
my $sharedobj;
my $sharedtab;
sub demacho ($$$) {
	my ($dd,$offs,$depth,) = @_;
	die "dd no ref" unless ref $dd eq 'SCALAR';
	$depth++ if defined $depth;
	$offs = 0 unless defined $offs;
	die "cant decode empty string" unless 
		defined $$dd && 
		length $$dd;
	use Carp;
	confess "offs $offs > string ".length($$dd) unless length $$dd > $offs;

	my $type = unpack "C", substr $$dd, $offs, 1;
	my ($shared, $sharedslot,) = (0,0,);
	unless ($type == 0x7e || $type == 0x7d) {
		$shared = $type & 0x40;
		if ($shared) {
			$type &= 0xbf;
			die "no shared index left" unless @$sharedtab;
			$sharedslot = shift @$sharedtab;
			die "shareslot $sharedslot already used" if defined $sharedobj->{$sharedslot};
			die "shareslot $sharedslot already exists" if exists $sharedobj->{$sharedslot};
			$sharedobj->{$sharedslot} = undef;
		}
	}
printf "TYPE %02x at OFFS %06x%s\n", $type, $offs, ($shared ? (" is SHARED($sharedslot)") : "");

	my ($data, $typename, $size, $repr,);
	if (0x00 == $type) {
		my $l = length($$dd) - $offs;
		die "nullbyte with $l left" unless $l < 4;
		my $s = substr $$dd, $offs;
		my $n = chr(0);
		die "late non nullbyte: $1" if $s =~ /([^$n])/;
		$data = undef;
		$typename = "nullbytes ($l)";
		$repr = "UNDEF";
		$size = $l-1;
	} elsif (0x01 == $type) {
		$data = undef;
		$typename = "0bit NULL";
		$repr = "UNDEF";
		$size = 0;
	} elsif (0x04 == $type) {
		$data = unpack "l", substr $$dd, $offs+1, 4;
		$typename = "32bit signed integer";
		$repr = $data;
		$size = 4;
	} elsif ($type == 0x05) {
		$data = unpack "s", substr $$dd, $offs+1, 2;
		$typename = "16bit signed integer";
		$repr = $data;
		$size = 2;
	} elsif ($type == 0x06) {
		$data = unpack "c", substr $$dd, $offs+1, 1;
		$typename = "8bit signed integer";
		$repr = $data;
		$size = 1;
	} elsif ($type == 0x09) {
		$data = 1;
		$repr = $data;
		$typename = "0bit 1 integer";
		$size = 0;
	} elsif ($type == 0x07) {
		$data = -1;
		$repr = $data;
		$typename = "0bit -1 integer";
		$size = 0;
	} elsif ($type == 0x08) {
		$data = 0;
		$repr = $data;
		$typename = "0bit 0 integer";
		$size = 0;
	} elsif ($type == 0x0a) {
		$data = unpack "d", substr $$dd, $offs+1, 8;
		$typename = "64bit float";
		$repr = $data;
		$size = 8;
	} elsif ($type == 0x0b) {
		$data = 0.0;
		$typename = "0bit float";
		$repr = $data;
		$size = 0;
	} elsif ($type == 0x1f) {
		$data = (1==1);
		$typename = "0bit true bool";
		$repr = "true";
		$size = 0;
	} elsif ($type == 0x20) {
		$data = (1==0);
		$typename = "0bit false bool";
		$repr = "false";
		$size = 0;
	} elsif (0x0d == $type || 0x13 == $type) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$data = substr $$dd, $offs+$s+1, $len;
		if ($data =~ /^[-\w ,.]+$/) {
			$typename = "";
			$repr = $data;
		} else {
			$typename = "binary ";
		}
		$typename .= "data (len:$len)";
		$size = $s+$len;
	} elsif ($type == 0x10 || $type == 0x02 || $type == 0x2e) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$data = substr $$dd, $offs+$s+1, $len;
		$typename = "string ($len)";
		$repr = $data; $repr =~ s/[^-\w. ]/./g;
		$size = $s+$len;
	} elsif ($type == 0x0f) {
		$typename = "string1";
		$data = substr $$dd, $offs+1, 1;
		$repr = $data; $repr =~ s/[^-\w. ]/./g;
		$size = 1;
	} elsif ($type == 0x29) {
		$typename = "ustring1";
		$data = substr $$dd, $offs+1, 2;
		$repr = $data; $repr =~ s/[^-\w. ]/./g;
		$size = 2;
	} elsif ($type == 0x12) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$data = substr $$dd, $offs+$s+1, ($len*2);
		$typename = "ustring ($len)";
		$repr = $data; $repr =~ s/[^-\w. ]/./g;
		$size = $s+($len*2);
	} elsif ($type == 0x11) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$typename = "machostring (id:$len)";
		$data = $machostrings->{$len};
		unless (defined($data)) {
			$data = $typename;
		}
		$repr = $data;
		$size = $s;
	} elsif ($type == 0x16) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$typename = "dict (len:$len)";
		$size = $s;
		$data = {};
		while ($$dd && scalar keys %$data < $len) {
			printf STDERR "RECURSE: dict %i < %i\n", scalar keys %$data, $len;
			my ($vd, $vc,) = &demacho($dd, $offs+$size+1, $depth);
			$size += $vc;
			my ($kd, $kc,) = &demacho($dd, $offs+$size+1, $depth);
			$size += $kc;
			if (ref $kd) {
				#die "complex key _and_ complex value" if ref $vd;
				if (ref $vd || exists $data->{$vd}) {
					my $nk = sprintf "doublecomplex %s", $kd;
					warn "complex key _and_ complex value: $nk";
					$typename .= " $nk";
					$vd = [$kd, $vd,];
					$kd = $nk;
				} else {
					warn "swapping complex kv pair";
					$typename .= " swapped KV";
					($kd, $vd,) = ($vd, $kd,);
				}
			}
			warn "undef kd for $vd" unless defined $kd;
			warn "undef vd for $kd" unless defined $vd;
			die "key '$kd' exists" if exists $data->{$kd};
			$data->{$kd} = $vd;
		}
	} elsif ($type == 0x14 || $type == 0x15) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$typename = ($type == 0x14 ? "tuple" : "list");
		$typename .= " (len:$len)";
		$size = $s;
		$data = [];
		while (length($$dd) > $offs+$size && scalar @$data < $len) {
#printf "DEB-ARRAY: want %i, have %i\n", $len, scalar @$data;
			printf STDERR "RECURSE: %s %i < %i\n", $typename, scalar @$data, $len;
			my ($sd, $sc,) = &demacho($dd, $offs+$size+1, $depth);
			push @$data, $sd;
			$size += $sc;
		}
	} elsif ($type == 0x1c) {
		$data = unpack "S", substr $$dd, $offs+1, 2;
		$typename = "unknown1c: $data";
		$size = 2;
		my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
		$data = $sd;
		$size += $sc;
	} elsif ($type == 0x17) {
		my ($cd, $cc,) = &demacho($dd, $offs+1, $depth);
		$typename = "object (type:$cd)";
		my ($sd, $sc,) = &demacho($dd, $offs+1+$cc, $depth);
		$data = { class => $cd,  data => $sd, };
		$size = $cc+$sc;
	} elsif ($type == 0x2d) {
		my $unk = unpack "C", substr $$dd, $offs+1, 1;
#printf "UNK: %02x at %06x\n", $unk, $offs+1;
#&hexdump($$dd);
		unless (1|| $unk == 0x2d || $unk == 0x01 || $unk == 0x06 || $unk == 0x09 || $unk == 0x10) {
			&hexdump(substr $$dd, $offs+1, 0x40);
			warn "unexpected type2d mystery byte: $unk";
			confess "testy";
			&hexdump($$dd);
			die;
		}
		my $us = $unk;
		$size = 0;

		if ($unk == 0x2d) {
			$size = 1;
		}# else {
		#	my ($sd, $sc,) = &demacho($dd, $offs+1, $depth);
		#		$size += $sc;
		#}

#		my $unk2 = unpack "C", substr $$dd, $offs+2, 1;
#		if ($unk2 == 0) {
#			$us .= " $unk2";
#			$size++;
#		}
		$typename = "empty unknown ($us)";
		$data = undef;

#		if ($unk == 0x06) {
#			&hexdump(substr $$dd, $offs, 0x40);
#			confess "is this still needed?";
#			$size++;
#		}
#confess "testy";
	} elsif ($type == 0x2a) {
		my $unk = unpack "C", substr $$dd, $offs+1, 1;
		unless ($unk == 0x1b || $unk == 0x62 || $unk == 0x22) {
			die "unexpected type2a mystery byte: $unk";
		}
		$typename = "datarow ($unk)";
		$size = 0;
		$data = {};
		# row description?
#		if($rowdescr) {
#			warn "ROWCOUNT: ".$rowdescr->{rowcount};
#		} else {
#			warn "NO ROWDESCR";
		#my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
			my ($sd, $sc,) = &demacho($dd, $offs+1, $depth);
#			$data->{_descr} = $sd;
			$size += $sc;
			# setup row descriptor
			if ($sd && (!$rowdescr || $rowdescr->{setup} != $sd)) {
				if (ref $sd eq 'HASH') {
					$data = $sd;
					warn "early break 2a";
					goto DEMACHOBREAK;
				}
				warn "setup1";
				$rowdescr = &setup_rowdescr($sd);
			}
#		}
		die "lacking row descriptor" unless $rowdescr;
		# wtf optional empty something?
		my $opt = unpack "C", substr $$dd, $offs+1+$size, 1;
		if ($rowdescr->{rowcount} == 0 && $opt == 0x2d) {
			my ($od, $oc,) = eval { &demacho($dd, $offs+1+$size, $depth); };
			if ($@) {
				warn "exception while trying to skip optional something: ".
						substr($@, 0, 30);
			} else {
				warn "skipped $oc bytes of wtf";
				$size += $oc;
			}
		}
		$rowdescr->{rowcount}++;
		# TODO
		my $bl = unpack "C", substr $$dd, $offs+1+$size, 1;
		my $rblob = substr $$dd, $offs+1+$size+1, $bl;
		my $blob = "";
#my $r = unpack "H*", $rblob;
#$r =~ s/(..)/$1 /g;
#printf "  RLOB(%i): %-40s == ", $bl, $r;

		while ($rblob) {
			my $rc = substr $rblob, 0, 1, "";
#printf "R:".unpack("H*",$rc)." "; 
			for (vec($rc, 0, 4), vec($rc, 1, 4),) {
				my $c = $_-8;
#printf "N:$_=";
				if ($c < 0) {
#printf "C:".abs($c)." ";
#				substr $blob, -1, 1, "";
					$blob .= substr $rblob, 0, abs($c), "";
				} else {
#printf "P:".$c." ";

					$blob .= chr(0)x($c+1);
				}
			}
		}

		#$blob = (chr(0)x(16-length($blob))).$blob; 
		my $delta = $rowdescr->{blobsize} - length($blob);
		if ($delta < -4 &&
			substr($blob, $rowdescr->{blobsize}) ne chr(0)) {
#my $b = unpack "H*", $blob;
#$b =~ s/(..)/$1 /g;
#printf "\n  BLOB: %s\n", $b;
			confess "oversized blob, want ".$rowdescr->{blobsize}.
				", have ".length($blob).
				", patt ".$rowdescr->{blobpatt};
		}
		$blob .= chr(0)x($rowdescr->{blobsize}-length($blob));
#		$data->{_blob} = $blob;
#		$data->{blob} = substr $$dd, $offs+1+$size+1, $bl;
printf "BLOB: size %i, patt %s, blob %i ... ", $rowdescr->{blobsize}, $rowdescr->{blobpatt}, length $blob;
&hexdump($blob);
		
		my @bd = unpack $rowdescr->{blobpatt}, $blob;
		unless (scalar(@{$rowdescr->{blobnames}}) == scalar @bd) {
			my $nc = scalar @{$rowdescr->{blobnames}};
			my $dc = scalar @bd;
			print "PATT: ".$rowdescr->{blobpatt}."\n";
			print Dumper(@bd);
			die "row count mismatch: $nc names, $dc data";
		}
		for (0..$#bd) {
			my $k = $rowdescr->{blobnames}->[$_];
			my $v = $bd[$_];
#printf "BLOBDATA: %s => %s\n", $k, $v;
			die "redefining key $k" if defined $data->{$k};
			$data->{$k} = $v;
		}

		my $bits = delete $data->{_fixbits};
		for my $bn (@{$rowdescr->{fixbits}}) {
			die "no bits" unless length($bits);
			my $bit = substr $bits, 0, 1, "";
			$data->{$bn} = $bit;
		}

		for my $rn (keys %{$rowdescr->{fix64}}) {
			my $rt = $rowdescr->{fix64}->{$rn};
			die "bad fix64 type: '$rt' for '$rn'" unless $rt =~ /^(int64|currency|time)$/;

			my $s = $data->{$rn};
			die "no data for $rn" unless length($s); 
			die "unexpexted size of data for $rn" unless length($s) == 8; 

			my ($l, $h,) = unpack "Ll", $s;

			my $v = ($h*(2**32))+$l;
#printf "FIX64: %s == h %s + l %s == ", $v, $h, $l;
#&hexdump($s);

			if ($rt eq 'currency') {
				$v /= 10000;
			} elsif ($rt eq 'time') {
				$v = ($v/10000000)-11644473600;
			} else {
				die "unhandled rt: $rt" unless $rt eq 'int64';
			}
			$data->{$rn} = $v;
		}
		
#		die "enuf" if $offs > 500;
		$typename .= " (blob:$bl:".length($blob).")";
		$size += 1+$bl;

		for (@{$rowdescr->{stringnames}}) {
			my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
#&hexdump(substr $$dd, $offs+1+$size, 100);
			warn "string $_ undef" unless defined $sd;
			die "ref for string $_" if ref $sd;
			$data->{$_} = $sd;
			$size += $sc;
		}

	} elsif ($type == 0x1b) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$typename = "subthing1b: $len";
		$size = $s;
		my $so = $sharedobj->{$len};
		die "so $len undef" unless defined $so;
		$data = $so;
		$repr = $so;
	} elsif ($type == 0x23 || $type == 0x22) {
		$typename = sprintf "subthing 0x%02x", $type;
		my ($sd, $sc,) = &demacho($dd, $offs+1, $depth);
		$data = undef;
		$size += $sc;

#print Dumper($sd);
		my $recurse = 0;
		die "unexpected type23: $sd" unless ref $sd eq 'ARRAY';
		if (ref $sd->[0] eq 'ARRAY' &&
		    $sd->[1]->{''}) {
#		    $sd->[0]->[0] eq 'dbutil.CRowset') {
			$typename .= ": ".$sd->[0]->[0];
			$data = $sd->[1]->{''};
#			$data = {
#				type => $sd->[0]->[0],
#				opts => [],
#				data => $sd->[1]->{''},
#				};
		} elsif (ref $sd->[0] eq 'ARRAY' &&
			$sd->[0]->[0] eq 'dbutil.RowList' &&
			ref $sd->[1] eq 'HASH' &&
			($sd->[1]->{header}||$sd->[1]->{columns})) {

			$rowdescr = undef;
			$typename .= ": resumed rowList";
			$data = $sd->[1]->{header}||$sd->[1]->{columns};
			#$recurse = 1;
		} elsif (ref $sd->[0] eq 'ARRAY' &&
		    $sd->[0]->[0] eq 'dbutil.CIndexedRowset') {
			$typename .= ": ".$sd->[0]->[0];
			my $h = $sd->[1];
			die "indexed inner not hash?" unless ref $h eq 'HASH';
			my @k = grep {/doublecomplex|^$/} keys %$h;
			die "no initial doublecomplex or empty" unless @k;
			die "more than one initial doublecomplex or empty" if scalar @k > 1;
			my $k = $k[0];
			my $dk = delete $h->{$k};
			die "dk not array" unless ref $dk eq 'ARRAY';
			$data = $dk->[1];

			die "missing aux" unless exists $data->{aux};
			die "aux0 not header" unless $data->{aux}->[0] eq 'header';
			die "aux2 not columnName" unless $data->{aux}->[2] eq 'columnName';
			my $idx = $data->{aux}->[1];
			$data->{idx} = $idx;

			die "missing data" unless exists $data->{data};
			die "have data" if @{$data->{data}};
			die "data not arrayref" unless ref $data->{data} eq 'ARRAY';

			my $d = $dk->[0];
			die "init data not hash" unless ref $d eq 'HASH';
			die "no $idx in init data" unless $d->{$idx};
			my $i = $d->{$idx};
			push @{$data->{data}}, $d;

			@k = keys %$h;
			die "no initial keys" unless @k;
			die "more than one initial key" if scalar @k > 1;
			for (@k) {
				die "no index" unless exists $h->{$_}->{$idx};
				die "key mismatch" unless $_ eq $h->{$_}->{$idx};
				push @{$data->{data}}, delete $h->{$_};
			}
			$recurse = 1;
		} elsif (($sd->[0] eq 'blue.DBRowDescriptor' ||
			  $sd->[0] eq 'exceptions.GPSTransportClosed') &&
		 	 ref $sd->[1] eq 'ARRAY') {
			$typename .= ": ".$sd->[0];
			$data = $sd; 
#			$data = {
#				type => $sd->[0],
#				opts => $sd,
#				data => [],
#				};
#			$recurse = 0;
#			confess "testy";
		} else {
			use Data::Dumper;
			print Dumper($sd);
			die "unhandled type23: ".$sd;# unless $sd->[0] eq 'blue.DBRowDescriptor';
		}
		die "no data!" unless $data;	

		if (!$recurse &&
			ref $sd->[0] eq 'ARRAY' &&
			$sd->[0]->[0] =~ /Row(set|Dict|List)$/) {
			#$sd->[0]->[0] eq 'dbutil.CIndexedRowset') {
			warn "late recurse decision for indexed rowset";
			$recurse = 1;
			$data = {
				opts => $data,
				data => [],
				};

			if ($sd->[0]->[0] =~ /index|dict/i) {
				$data->{_has_idx} = 1;
			}
		}
		

		if ($data && $recurse) {
			warn "DADA";
			print Dumper($data);

			unless (ref $data->{opts} eq 'ARRAY') {
				warn "setup2";
				use Data::Dumper;
				print Dumper($data);
				die "rowset descr bad";
			}
			$rowdescr = &setup_rowdescr($data->{opts});

			unless (@{$data->{data}}) {
				while (0x2a != unpack "C", substr $$dd, $offs+1+$size, 1) {
					printf "SKIPPING ";
					my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
					$size += $sc;
				}
			}

			if (0) {
				my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
				$size += $sc;
				if (0 && defined $sd && $sd =~ /^column(Name|s)$/) {
					($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
					$size += $sc;
				}
				
				if (defined $sd && $sd =~ /^(header|columns)$/) {
					#
				} else {
					print Dumper($sd);
					die "unexpected first row: $sd" if defined $sd;
				}
			}

			my $go = 1;
			while ($go) {
				my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
				$size += $sc;
				warn "sd undef" unless defined $sd;

				if ($data->{_has_idx} && ref $sd) {
					warn "sd undef neverhere1" unless defined $sd;
					my ($dsd, $dsc,) = &demacho($dd, $offs+1+$size, $depth);
					die "index is ref: $dsd" if ref $dsd;
					if (defined $dsd) {
						$size += $dsc;
					}
				}

				if ($data->{idx} && defined $sd) {
					warn "sd undef neverhere2" unless defined $sd;
					die "idx bad" if ref $sd;

					my ($isd, $isc,) = &demacho($dd, $offs+1+$size, $depth);
					$size += $isc;
					die "isd row not hash: $isd" unless ref $isd eq 'HASH';
					die "idx missing" unless $isd->{$data->{idx}};
					die "idx mismatch" unless $isd->{$data->{idx}} eq $sd;

					$sd = $isd;
				}

				if (ref $sd eq 'HASH') {
					push @{$data->{data}}, $sd;
				} elsif (ref $sd eq 'ARRAY') {
					push @{$data->{data}}, @$sd;
				} elsif (!defined $sd) {
					warn "sd undef go0" unless defined $sd;
					$go = 0;
				} elsif (!@{$data->{data}} && !ref $sd) {
					$data->{aux} ||= [];
					push @{$data->{aux}}, $sd;
				} else {
					print Dumper($sd);
					die "unexpected row: $sd";
				}
			}
			delete $data->{_has_idx};
		}

	} elsif ($type == 0x2b) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$typename = "subthing2b (len:$len)";
		$size = $s + $len;
		my $D = substr $$dd, $offs+1+$s, $len;
		printf "dumping %i byte of subthing2b\n", length($D);
		open IMO, ">", "2b.inner";
		print IMO $D;
		close IMO;
		printf STDERR "RECURSE: substhing\n";
		my ($sd, $sc,) = &demacho(\$D, 0, $depth);
		$data = $sd;
		warn "subthing size mismatch: $sc vs $len" unless $sc == $len;
	} elsif ($type == 0x24 || $type == 0x26) {
		$typename = ($type == 0x24 ? "tuple0" : "list0");
		$data = [];
		$size = 0;
	} elsif ($type == 0x25 || $type == 0x27) {
		$typename = ($type == 0x25 ? "tuple1" : "list1");
		printf STDERR "RECURSE: %s\n", $typename;
		my ($sd, $sc,) = &demacho($dd, $offs+1, $depth);
		$data = [$sd,];
		$size = $sc;
	} elsif ($type == 0x0e || $type == 0x28) {
		$typename = "empty string";
		$data = "";
		$size = 0;
	} elsif ($type == 0x2c) {
		$typename = "tuple2";
		$size = 0;
		$data = [];
		while ($$dd && scalar @$data < 2) {
#		while ($size+1 < length($$dd)) {
			printf STDERR "RECURSE: %s\n", $typename;
			my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
			push @$data, $sd;
			$size += $sc;
		}
	} elsif ($type == 0x2f) {
		my ($len, $s,) = &getlen($dd, $offs+1);
		$typename = "variable sized integer ($len)";
		$size = $s + $len;
		my $str = substr $$dd, $offs+1+$s, $len;
		if ($len == 8) {
			my ($l, $h,) = unpack "Ll", $str;
			$data = ($h*(2**32))+$l;
		} elsif ($len == 4) {
			my ($l,) = unpack "l", $str;
			$data = $l;
		} elsif ($len == 2) {
			my ($s,) = unpack "s", $str;
			$data = $s;
		} elsif ($len == 1) {
			my ($b,) = unpack "c", $str;
			$data = $b;
		} else {
			die "unsupported 0x2f length $len";
		}
		$repr = $data;
	} elsif ($type == 0x7e || $type == 0x3e || $type == 0x7d) {
		$typename = "machothing";
		$shared = 0;
		my ($ord, $oso, $ost,) = ($rowdescr, $sharedobj, $sharedtab,);
		($rowdescr, $sharedobj, $sharedtab,) = (undef,undef,undef,);

		my $ssize = 0;
		my $lc = 0;

		if ($type == 0x7d) {
			$lc = unpack "c", substr $$dd, $offs+1, 1;
			$size = 1;
			$typename .= " 7d ($lc shared)";
			$sharedobj = {};
			$sharedtab = [ 0..500 ];
		} else {

			$lc = unpack "L", substr $$dd, $offs+1, 4;
			$size = 4;
			if ($lc) {
				die "have sharetab" if $sharedtab && @$sharedtab;
				$typename .= " ($lc shared)";
#			if ($sharedtab && @$sharedtab) {
#printf "SHARETAB-INNER(%i): %s\n", $lc, join(", ", @$sharedtab);
#
#				if ($lc > scalar @$sharedtab) {
#					my $sl = scalar @$sharedtab;
#					die "sharedtab size mismatch $lc vs $sl";
#				}
#			} else {
					my $sts = substr $$dd, $lc*-4;
					my @st = unpack "L*", $sts;
printf "SHARETAB(%i/%i): %s\n", $lc, length($sts), join(", ", @st);
					$sharedobj = {};
					$sharedtab = \@st;
#					unless ($ost && @$ost) {
						$ssize += $lc * 4;
#					}
#				}
			}

		}

		my ($sd, $sc,) = &demacho($dd, $offs+1+$size, $depth);
		$size += $sc;
		$data = $sd;

		my $so = scalar keys %$sharedobj;
		if ($type == 0x7e && ($so || $lc) && $so != $lc) {
			die "lc $lc != so $so";
		}	
		$size += $ssize;
		($rowdescr, $sharedobj, $sharedtab,) = ($ord, $oso, $ost,);
	} else {
		printf "unknown type 0x%02x / %i\n", $type, $type;
		&hexdump(substr $$dd, $offs, 0x40);
		#&hexdump(substr $$dd, $offs);
		&hexdump($$dd);
		confess "demacho failed";
	}

DEMACHOBREAK:
	if (ref $data eq 'HASH') {
		for (sort keys %$data) {
			if (/^_/) {
				confess "leaking private attr $_";
			}
		}
	}
	if ($shared) {
		die "SHARESLOT($sharedslot) doesnt exist" unless exists $sharedobj->{$sharedslot};
		die "SHARESLOT($sharedslot) already used" if defined $sharedobj->{$sharedslot};
		$sharedobj->{$sharedslot} = $data;
#printf "SHARED: added %i: %s\n", $sharedslot, $data;
	}
	if (defined $depth) {
		printf STDERR "DEMACHO(%02x):%s %i byte %s: '%s'\n", $type, " "x$depth, 
			$size, $typename,
			defined $repr ? $repr : "<NULL>";
	}
	return ($data, $size + 1,);
}

sub getlen ($) {
	my ($dd, $offs,) = @_;
	die "getlen dd no ref" unless ref $dd eq 'SCALAR';
	die "getlen without offs" unless defined $offs;
	my $ld = substr $$dd, $offs, 1;
	my $len = unpack "C", $ld;
	return ($len, 1,) if ($len < 255);
	die "long-len but less than 5 byte data" if length($$dd) < 5;
	return (unpack("L", substr $$dd, $offs+1, 4), 5);
}

sub setup_rowdescr ($) {
	my ($sd,) = @_;
	if ($rowdescr) {
		die "rowdescr without setup" unless $rowdescr->{setup};
		if ($rowdescr->{setup} == $sd) {
			confess "trying to reset rowdescr";
		}
	}
	unless (ref $sd eq 'ARRAY') {
		if (defined $sd) {
			use Data::Dumper;
			print Dumper($sd);
		} else {
			$sd = "UNDEF";
		}
		confess "descr not arrayref: ".$sd;
	}
	die "bad descr type: ".$sd->[0] 
		unless $sd->[0] eq 'blue.DBRowDescriptor';
	my @rows = @{$sd->[1][0]};
	my (@t64, @int32, @int16, @int8, @string, @bool,) = ((),(),(),(),(),(),(),);
	my %t64 = ();
	for (@rows) {
		my ($rn, $rt,) = @$_;
#		printf "ROWDE: %i %s\n", $rt, $rn;
		if (20 == $rt) {
			push @t64, $rn;
			$t64{$rn} = 'int64';
		} elsif (64 == $rt) {
			push @t64, $rn;
			$t64{$rn} = 'time';
		} elsif (6 == $rt) { ## fake
			push @t64, $rn;
			$t64{$rn} = 'currency';
#		} elsif (64 == $rt) { ## fake
#			push @int64, $rn;
		} elsif (3 == $rt) {
			push @int32, $rn;
		} elsif (2 == $rt) {
			push @int16, $rn;
		} elsif (17 == $rt) {
			push @int8, $rn;
		} elsif (5 == $rt) {
			push @t64, $rn;
			$t64{$rn} = 'double';
		} elsif (11 == $rt) {
			push @bool, $rn;
		} elsif (129 == $rt) {
			push @string, $rn;
		} elsif (130 == $rt) {
			push @string, $rn;
		} else {
			die "unknown OLEtype $rt for $rn";
		}
	}

	my $blobsize = 0;
	my $blobpatt = "";
	my @blobnames = ();

	for my $rn (@t64) {
		my $t = $t64{$rn};
		if ($t eq 'double') {
			$blobpatt .= "d";
			delete $t64{$rn};
		} elsif ($t =~ /^(currency|int64|time)/) {
			$blobpatt .= "a8";
		} else {
			die "bad t64 $t";
		}
		$blobsize += 8;
		push @blobnames, $rn;
	}

#	printf "BLOBDEF0: %i %s\n", $blobsize, $blobpatt;
#	$blobsize += 8 * scalar(@float);
#	$blobpatt .= "d" x scalar(@float);
#	push @blobnames, @float;
			
#	printf "BLOBDEF1: %i %s\n", $blobsize, $blobpatt;
#	$blobsize += 8 * scalar(@int64);
#	$blobpatt .= "a8" x scalar(@int64);
#	push @blobnames, @int64;
#	printf "BLOBDEF: %i %s\n", $blobsize, $blobpatt;

#	printf "BLOBDEF1: %i %s\n", $blobsize, $blobpatt;
	$blobsize += 4 * scalar(@int32);
	$blobpatt .= "l" x scalar(@int32);
	push @blobnames, @int32;
#	printf "BLOBDEF: %i %s\n", $blobsize, $blobpatt;

#	printf "BLOBDEF1: %i %s\n", $blobsize, $blobpatt;
	$blobsize += 2 * scalar(@int16);
	$blobpatt .= "s" x scalar(@int16);
	push @blobnames, @int16;
#	printf "BLOBDEF: %i %s\n", $blobsize, $blobpatt;

#	printf "BLOBDEF1: %i %s\n", $blobsize, $blobpatt;
	$blobsize += scalar(@int8);
	$blobpatt .= "C" x scalar(@int8);
	push @blobnames, @int8;
#	printf "BLOBDEF: %i %s\n", $blobsize, $blobpatt;

#	printf "BLOBDEF1: %i %s\n", $blobsize, $blobpatt;
	if ( @bool ) {
		my $bc = scalar(@bool);
		$blobsize += 1 + int ($bc / 8);
		$blobpatt .= "b".$bc;
		push @blobnames, "_fixbits";
	}
#	printf "BLOBDEF: %i %s\n", $blobsize, $blobpatt;

	

	return {
		blobsize => $blobsize,
		blobpatt => $blobpatt,
		blobnames => \@blobnames,
		stringnames => \@string,
		fix64 => \%t64,
		fixbits => \@bool,
		rowcount => 0,
		setup => $sd,
		};
}


sub hexdump {
  my ($data,) = @_;
  	$data = $$data if ref $data eq 'SCALAR';
	printf "\ndumping %i byte:\n", length($data);
	#my $hd = substr $data, 0, 16*20;
	my $hd = $data;
	while ($hd) {
		my $hb = substr $hd, 0, 16, "";
		my $hh = unpack "H*", $hb;
		$hb =~ s/[^-A-Z0-9@=*]/./ig;
		$hb =~ s/^(.{8})/$1 /;
		$hh =~ s/^(.{16})/$1  /;
		$hh =~ s/(..)/$1 /g;
		printf "  %-52s  %s\n", $hh, $hb;
	}
}


1;