;;;;;;;;;;;
sub ok {
my ($num, $ok) = @_;
print "not " unless $ok;
print "ok $num\n";
}
package dump;
use Carp;
%dump = (
'SCALAR' => 'dump_scalar',
'ARRAY' => 'dump_array',
'HASH' => 'dump_hash',
'REF' => 'dump_ref',
'CODE' => 'dump_code',
);
sub main'dump {
my ($object) = @_;
croak "Not a reference!" unless ref($object);
local %dumped;
local %object;
local $count = 0;
local $dumped = '';
&recursive_dump($object, 1);
return $dumped;
}
# This is the root recursive dumping routine that may indirectly be
# called by one of the routine it calls...
# The link parameter is set to false when the reference passed to
# the routine is an internal temporay variable, implying the object's
sub recursive_dump {
my ($object, $link) = @_;
my $what = "$object"; my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
$ref = 'REF' if ref($object) eq 'REF';
if ($link && $dumped{$addr}++) {
my $num = $object{$addr};
$dumped .= "OBJECT #$num seen\n";
return;
}
my $objcount = $count++;
$object{$addr} = $objcount;
croak "Unknown simple type '$ref'" unless defined $dump{$ref};
&{$dump{$ref}}($object); &bless($bless) if $bless;
$dumped .= "OBJECT $objcount\n";
}
sub bless {
my ($class) = @_;
$dumped .= "BLESS $class\n";
}
sub dump_scalar {
my ($sref) = @_;
my $scalar = $$sref;
unless (defined $scalar) {
$dumped .= "UNDEF\n";
return;
}
my $len = length($scalar);
$dumped .= "SCALAR len=$len $scalar\n";
}
sub dump_array {
my ($aref) = @_;
my $items = 0 + @{$aref};
$dumped .= "ARRAY items=$items\n";
foreach $item (@{$aref}) {
unless (defined $item) {
$dumped .= 'ITEM_UNDEF' . "\n";
next;
}
$dumped .= 'ITEM ';
&recursive_dump(\$item, 1);
}
}
sub dump_hash {
my ($href) = @_;
my $items = scalar(keys %{$href});
$dumped .= "HASH items=$items\n";
foreach $key (sort keys %{$href}) {
$dumped .= 'KEY ';
&recursive_dump(\$key, undef);
unless (defined $href->{$key}) {
$dumped .= 'VALUE_UNDEF' . "\n";
next;
}
$dumped .= 'VALUE ';
&recursive_dump(\$href->{$key}, 1);
}
}
sub dump_ref {
my ($rref) = @_;
my $deref = $$rref; $dumped .= 'REF ';
&recursive_dump($deref, 1); }
sub dump_code {
my ($sref) = @_;
$dumped .= "CODE\n";
}
1;