package ObjStore::Peeker;
use strict;
use Carp;
use vars qw($LinePrefix $LineIndent $LineSep
	    $Addr $SummaryWidth $MaxWidth $MaxDepth $MaxInstances
	    $To $All);

$LinePrefix='';
$LineIndent='  ';
$LineSep="\n";
$Addr=0;
$SummaryWidth=3;
$MaxWidth=20;
$MaxDepth=20;
$MaxInstances=3;
$To='string';
$All=0;

sub new {
    my ($class, %cnf) = @_;
    my $o = bless {
	prefix => $LinePrefix,
	indent => $LineIndent,
	sep => $LineSep,
	addr => $Addr,
	summary_width => $SummaryWidth,
	instances => $MaxInstances,
	width => 20,
	depth => 20,
	to => $To,
	all => $All,
    }, $class;
    while (my ($k,$v) = each %cnf) { $o->{$k} = $v; }
    $o;
}

sub Peek {
    my ($o, $top) = @_;
    $o->{output} = '';
    $o->{seen} = {};
    $o->{level} = 0;
    $o->{has_sep} = 0;
    $o->{has_prefix} = 0;
    $o->{coverage} = 0;
    $o->_peek($top);
    $o->{output};
}

sub PercentUnused { die "wildy inaccurate metric unsupported"; }

sub Coverage {
    my ($o) = @_;
    $o->{coverage};
}

sub prefix {
    my ($o) = @_;
    return if $o->{has_prefix};
    $o->o($o->{prefix}, $o->{indent} x $o->{level});
    $o->{has_prefix}=1;
}

sub nl {
    my ($o) = @_;
    return if $o->{has_sep};
    $o->o($o->{sep});
    $o->{has_sep}=1;
}

sub o {
    my $o = shift;
    $o->{has_sep}=0;
    $o->{has_prefix}=0;
    my $t = ref $o->{to};
    if (!$t and $o->{to} eq 'string') {
	$o->{output} .= join('', @_);
    } elsif ($t eq 'CODE') {
	$o->{to}->(@_);
    } elsif ($t->isa('IO::Handle') or $t->isa('FileHandle')) {
	$o->{to}->print(join('',@_));
    } else {
	die "ObjStore::Peeker: Don't know how to write to $o->{to}";
    }
}

sub avg {
    if (@_) {
	my $sum=0;
	for (@_) { $sum += $_ }
	$sum / @_;
    } else { 0 }
}

sub _peek {
    my ($o, $val) = @_;
    my $type = ObjStore::reftype $val;
    my $class = ref $val;

    # Since persistent blessing is likely turned off...
    $class = $val->_ref if ($class and $class->isa('ObjStore::UNIVERSAL'));

    if (!$class) {
	if (!defined $val) {
	    $o->o('undef,');
	} elsif ($val =~ /^-?[1-9]\d{0,8}$/) {
	    $o->o("$val,");
	} else {
	    $val =~ s/([\\\'])/\\$1/g;
	    $o->o("'$val',");
	}
	++ $o->{coverage};
	return;
    }

    my $addr = "$val";
    my $name = $o->{addr} ? $addr : $class;
    $o->{seen}{$class} ||= 0;

    if ($o->{level} > $o->{depth} or defined($o->{seen}{$addr}) or
	($class !~ /^ObjStore::/ and $o->{seen}{$class} > $o->{instances})) {
	if ($type eq 'HASH') {
	    $o->o("$name { ... }");
	} elsif ($type eq 'ARRAY') {
	    $o->o("$name [ ... ]");
	} elsif ($class->isa('ObjStore::Set')) {
	    $o->o("$name [ ... ]");
	} else {
	    $o->o("$class ...");
	}
	++ $o->{coverage};
	return;
    }
    $o->{seen}{$addr}=1;
    ++ $o->{seen}{$class};

    $o->prefix;
    if ($class eq 'ObjStore::Database') {
	for my $r ($val->get_all_roots) {
	    next if (!$o->{all} and $r->get_name eq ObjStore::_PRIVATE_ROOT);

	    $o->prefix;
	    ++$o->{level};
	    my $name = $o->{addr}? "$r" : 'ObjStore::Root';
	    $o->o("$name ",$r->get_name," = ");
	    $o->{has_prefix}=1;
	    $o->_peek($r->get_value);
	    --$o->{level};
	    $o->nl;
	    ++ $o->{coverage};
	}
    } elsif ($class->isa('ObjStore::Set')) {
	my @S;
	my $x=0;
	for (my $v=$val->first; $v; $v=$val->next) {
	    ++ $o->{coverage};
	    last if $x++ > $o->{width}+1;
	    push(@S, $v);
	}
	my $big = @S > $o->{width};
	my $limit = $big ? $o->{summary_width}-1 : @S;

	$o->o($name . " [");
	$o->nl;
	++$o->{level};
	for (my $v=$val->first; $v; $v=$val->next) {
	    last if $limit-- <= 0;
	    $o->prefix;
	    $o->_peek($v);
	    $o->nl;
	}
	if ($big) {
	    $o->prefix;
	    $o->o("...");
	    $o->nl;
	}
	--$o->{level};
	$o->prefix;
	$o->o("],");
	$o->nl;
    } elsif ($type eq 'HASH') {
	my @S;
	my $x=0;
	while (my($k,$v) = each %$val) {
	    ++ $o->{coverage};
	    last if $x++ > $o->{width}+1;
	    push(@S, [$k,$v]);
	}
	@S = sort { $a->[0] cmp $b->[0] } @S;
	my $big = @S > 20;
	my $limit = $big ? $o->{summary_width}-1 : $#S;

	$o->o($name . " {");
	$o->nl;
	++$o->{level};
	for $x (0..$limit) {
	    my ($k,$v) = @{$S[$x]};

	    $o->prefix;
	    $o->o("$k => ");
	    $o->{has_prefix}=1;
	    $o->_peek($v);
	    $o->nl;
	}
	if ($big) {
	    $o->prefix;
	    $o->o("...");
	    $o->nl;
	}
	--$o->{level};
	$o->prefix;
	$o->o("},");
	$o->nl;
    } elsif ($type eq 'ARRAY') {
	my $len = $val->can("_LENGTH")? $val->_LENGTH : @$val;
	$o->{coverage} += $len;
	my $big = $len > $o->{width};
	my $limit = $big? $o->{summary_width} : $len;

	$o->o($name . " [");
	$o->nl;
	++$o->{level};
	for (my $x=0; $x < $limit; $x++) {
	    $o->prefix;
	    $o->_peek($val->[$x]);
	    $o->nl;
	}
	if ($big) {
	    $o->prefix;
	    $o->o("...");
	    $o->nl;
	}
	--$o->{level};
	$o->prefix;
	$o->o("],");
	$o->nl;
    } elsif ($class->isa('ObjStore::Cursor')) {
	++ $o->{coverage};
	$o->o("$name => ");
	$o->{has_prefix}=1;
	++ $o->{level};
	my $at = $val->focus;
	$o->_peek($at);
	-- $o->{level};
	$o->nl;
    } elsif ($type eq 'SCALAR') {
	++ $o->{coverage};
	$o->o($name);
    } else {
	die "Unknown type '$type'";
    }
}

1;
