Storable/t/st-dump.pl

#
#  Copyright (c) 1995-2000, Raphael Manfredi
#
#  You may redistribute only under the same terms as Perl 5, as specified
#  in the README file that comes with the distribution.
#

# NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl
# TO t/lib/st-dump.pl.  One could also play games with
# File::Spec->updir and catdir to get the st-dump.pl in
# ext/Storable into @INC.

sub ok {
	my ($num, $ok, $name) = @_;
        $num .= " - $name" if defined $name and length $name;
	print $ok ? "ok $num\n" : "not ok $num\n";
        $ok;
}

sub num_equal {
	my ($num, $left, $right, $name) = @_;
        my $ok = ((defined $left) ? $left == $right : undef);
        unless (ok ($num, $ok, $name)) {
          print "# Expected $right\n";
          if (!defined $left) {
            print "# Got undef\n";
          } elsif ($left !~ tr/0-9//c) {
            print "# Got $left\n";
          } else {
            $left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge;
            print "# Got \"$left\"\n";
          }
        }
        $ok;
}

package dump;
use Carp;

%dump = (
	'SCALAR'	=> 'dump_scalar',
	'LVALUE'	=> 'dump_scalar',
	'ARRAY'		=> 'dump_array',
	'HASH'		=> 'dump_hash',
	'REF'		=> 'dump_ref',
);

# Given an object, dump its transitive data closure
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
# address is not to be dumped in the %dumped table since it's not a
# user-visible object.
sub recursive_dump {
	my ($object, $link) = @_;

	# Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
	# Then extract the bless, ref and address parts of that string.

	my $what = "$object";		# Stringify
	my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
	($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;

	# Special case for references to references. When stringified,
	# they appear as being scalars. However, ref() correctly pinpoints
	# them as being references indirections. And that's it.

	$ref = 'REF' if ref($object) eq 'REF';

	# Make sure the object has not been already dumped before.
	# We don't want to duplicate data. Retrieval will know how to
	# relink from the previously seen object.

	if ($link && $dumped{$addr}++) {
		my $num = $object{$addr};
		$dumped .= "OBJECT #$num seen\n";
		return;
	}

	my $objcount = $count++;
	$object{$addr} = $objcount;

	# Call the appropriate dumping routine based on the reference type.
	# If the referenced was blessed, we bless it once the object is dumped.
	# The retrieval code will perform the same on the last object retrieved.

	croak "Unknown simple type '$ref'" unless defined $dump{$ref};

	&{$dump{$ref}}($object);	# Dump object
	&bless($bless) if $bless;	# Mark it as blessed, if necessary

	$dumped .= "OBJECT $objcount\n";
}

# Indicate that current object is blessed
sub bless {
	my ($class) = @_;
	$dumped .= "BLESS $class\n";
}

# Dump single scalar
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";
}

# Dump array
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);
	}
}

# Dump hash table
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);
	}
}

# Dump reference to reference
sub dump_ref {
	my ($rref) = @_;
	my $deref = $$rref;				# Follow reference to reference
	$dumped .= 'REF ';
	&recursive_dump($deref, 1);		# $dref is a reference
}

1;