|
Packit |
14c646 |
#
|
|
Packit |
14c646 |
# Copyright (c) 1995-2000, Raphael Manfredi
|
|
Packit |
14c646 |
#
|
|
Packit |
14c646 |
# You may redistribute only under the same terms as Perl 5, as specified
|
|
Packit |
14c646 |
# in the README file that comes with the distribution.
|
|
Packit |
14c646 |
#
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
package dump;
|
|
Packit |
14c646 |
use Carp;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
%dump = (
|
|
Packit |
14c646 |
'SCALAR' => 'dump_scalar',
|
|
Packit |
14c646 |
'LVALUE' => 'dump_scalar',
|
|
Packit |
14c646 |
'ARRAY' => 'dump_array',
|
|
Packit |
14c646 |
'HASH' => 'dump_hash',
|
|
Packit |
14c646 |
'REF' => 'dump_ref',
|
|
Packit |
14c646 |
);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Given an object, dump its transitive data closure
|
|
Packit |
14c646 |
sub main::dump {
|
|
Packit |
14c646 |
my ($object) = @_;
|
|
Packit |
14c646 |
croak "Not a reference!" unless ref($object);
|
|
Packit |
14c646 |
local %dumped;
|
|
Packit |
14c646 |
local %object;
|
|
Packit |
14c646 |
local $count = 0;
|
|
Packit |
14c646 |
local $dumped = '';
|
|
Packit |
14c646 |
&recursive_dump($object, 1);
|
|
Packit |
14c646 |
return $dumped;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# This is the root recursive dumping routine that may indirectly be
|
|
Packit |
14c646 |
# called by one of the routine it calls...
|
|
Packit |
14c646 |
# The link parameter is set to false when the reference passed to
|
|
Packit |
14c646 |
# the routine is an internal temporary variable, implying the object's
|
|
Packit |
14c646 |
# address is not to be dumped in the %dumped table since it's not a
|
|
Packit |
14c646 |
# user-visible object.
|
|
Packit |
14c646 |
sub recursive_dump {
|
|
Packit |
14c646 |
my ($object, $link) = @_;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
|
|
Packit |
14c646 |
# Then extract the bless, ref and address parts of that string.
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $what = "$object"; # Stringify
|
|
Packit |
14c646 |
my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
|
|
Packit |
14c646 |
($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Special case for references to references. When stringified,
|
|
Packit |
14c646 |
# they appear as being scalars. However, ref() correctly pinpoints
|
|
Packit |
14c646 |
# them as being references indirections. And that's it.
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
$ref = 'REF' if ref($object) eq 'REF';
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Make sure the object has not been already dumped before.
|
|
Packit |
14c646 |
# We don't want to duplicate data. Retrieval will know how to
|
|
Packit |
14c646 |
# relink from the previously seen object.
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
if ($link && $dumped{$addr}++) {
|
|
Packit |
14c646 |
my $num = $object{$addr};
|
|
Packit |
14c646 |
$dumped .= "OBJECT #$num seen\n";
|
|
Packit |
14c646 |
return;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $objcount = $count++;
|
|
Packit |
14c646 |
$object{$addr} = $objcount;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Call the appropriate dumping routine based on the reference type.
|
|
Packit |
14c646 |
# If the referenced was blessed, we bless it once the object is dumped.
|
|
Packit |
14c646 |
# The retrieval code will perform the same on the last object retrieved.
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
croak "Unknown simple type '$ref'" unless defined $dump{$ref};
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
&{$dump{$ref}}($object); # Dump object
|
|
Packit |
14c646 |
&bless($bless) if $bless; # Mark it as blessed, if necessary
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
$dumped .= "OBJECT $objcount\n";
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Indicate that current object is blessed
|
|
Packit |
14c646 |
sub bless {
|
|
Packit |
14c646 |
my ($class) = @_;
|
|
Packit |
14c646 |
$dumped .= "BLESS $class\n";
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Dump single scalar
|
|
Packit |
14c646 |
sub dump_scalar {
|
|
Packit |
14c646 |
my ($sref) = @_;
|
|
Packit |
14c646 |
my $scalar = $$sref;
|
|
Packit |
14c646 |
unless (defined $scalar) {
|
|
Packit |
14c646 |
$dumped .= "UNDEF\n";
|
|
Packit |
14c646 |
return;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
my $len = length($scalar);
|
|
Packit |
14c646 |
$dumped .= "SCALAR len=$len $scalar\n";
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Dump array
|
|
Packit |
14c646 |
sub dump_array {
|
|
Packit |
14c646 |
my ($aref) = @_;
|
|
Packit |
14c646 |
my $items = 0 + @{$aref};
|
|
Packit |
14c646 |
$dumped .= "ARRAY items=$items\n";
|
|
Packit |
14c646 |
foreach $item (@{$aref}) {
|
|
Packit |
14c646 |
unless (defined $item) {
|
|
Packit |
14c646 |
$dumped .= 'ITEM_UNDEF' . "\n";
|
|
Packit |
14c646 |
next;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
$dumped .= 'ITEM ';
|
|
Packit |
14c646 |
&recursive_dump(\$item, 1);
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Dump hash table
|
|
Packit |
14c646 |
sub dump_hash {
|
|
Packit |
14c646 |
my ($href) = @_;
|
|
Packit |
14c646 |
my $items = scalar(keys %{$href});
|
|
Packit |
14c646 |
$dumped .= "HASH items=$items\n";
|
|
Packit |
14c646 |
foreach $key (sort keys %{$href}) {
|
|
Packit |
14c646 |
$dumped .= 'KEY ';
|
|
Packit |
14c646 |
&recursive_dump(\$key, undef);
|
|
Packit |
14c646 |
unless (defined $href->{$key}) {
|
|
Packit |
14c646 |
$dumped .= 'VALUE_UNDEF' . "\n";
|
|
Packit |
14c646 |
next;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
$dumped .= 'VALUE ';
|
|
Packit |
14c646 |
&recursive_dump(\$href->{$key}, 1);
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Dump reference to reference
|
|
Packit |
14c646 |
sub dump_ref {
|
|
Packit |
14c646 |
my ($rref) = @_;
|
|
Packit |
14c646 |
my $deref = $$rref; # Follow reference to reference
|
|
Packit |
14c646 |
$dumped .= 'REF ';
|
|
Packit |
14c646 |
&recursive_dump($deref, 1); # $dref is a reference
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
1;
|