1#
2#  Copyright (c) 1995-2000, Raphael Manfredi
3#
4#  You may redistribute only under the same terms as Perl 5, as specified
5#  in the README file that comes with the distribution.
6#
7
8package dump;
9use Carp;
10
11%dump = (
12	'SCALAR'	=> 'dump_scalar',
13	'LVALUE'	=> 'dump_scalar',
14	'ARRAY'		=> 'dump_array',
15	'HASH'		=> 'dump_hash',
16	'REF'		=> 'dump_ref',
17);
18
19# Given an object, dump its transitive data closure
20sub main::dump {
21	my ($object) = @_;
22	croak "Not a reference!" unless ref($object);
23	local %dumped;
24	local %object;
25	local $count = 0;
26	local $dumped = '';
27	&recursive_dump($object, 1);
28	return $dumped;
29}
30
31# This is the root recursive dumping routine that may indirectly be
32# called by one of the routine it calls...
33# The link parameter is set to false when the reference passed to
34# the routine is an internal temporary variable, implying the object's
35# address is not to be dumped in the %dumped table since it's not a
36# user-visible object.
37sub recursive_dump {
38	my ($object, $link) = @_;
39
40	# Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
41	# Then extract the bless, ref and address parts of that string.
42
43	my $what = "$object";		# Stringify
44	my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
45	($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
46
47	# Special case for references to references. When stringified,
48	# they appear as being scalars. However, ref() correctly pinpoints
49	# them as being references indirections. And that's it.
50
51	$ref = 'REF' if ref($object) eq 'REF';
52
53	# Make sure the object has not been already dumped before.
54	# We don't want to duplicate data. Retrieval will know how to
55	# relink from the previously seen object.
56
57	if ($link && $dumped{$addr}++) {
58		my $num = $object{$addr};
59		$dumped .= "OBJECT #$num seen\n";
60		return;
61	}
62
63	my $objcount = $count++;
64	$object{$addr} = $objcount;
65
66	# Call the appropriate dumping routine based on the reference type.
67	# If the referenced was blessed, we bless it once the object is dumped.
68	# The retrieval code will perform the same on the last object retrieved.
69
70	croak "Unknown simple type '$ref'" unless defined $dump{$ref};
71
72	&{$dump{$ref}}($object);	# Dump object
73	&bless($bless) if $bless;	# Mark it as blessed, if necessary
74
75	$dumped .= "OBJECT $objcount\n";
76}
77
78# Indicate that current object is blessed
79sub bless {
80	my ($class) = @_;
81	$dumped .= "BLESS $class\n";
82}
83
84# Dump single scalar
85sub dump_scalar {
86	my ($sref) = @_;
87	my $scalar = $$sref;
88	unless (defined $scalar) {
89		$dumped .= "UNDEF\n";
90		return;
91	}
92	my $len = length($scalar);
93	$dumped .= "SCALAR len=$len $scalar\n";
94}
95
96# Dump array
97sub dump_array {
98	my ($aref) = @_;
99	my $items = 0 + @{$aref};
100	$dumped .= "ARRAY items=$items\n";
101	foreach $item (@{$aref}) {
102		unless (defined $item) {
103			$dumped .= 'ITEM_UNDEF' . "\n";
104			next;
105		}
106		$dumped .= 'ITEM ';
107		&recursive_dump(\$item, 1);
108	}
109}
110
111# Dump hash table
112sub dump_hash {
113	my ($href) = @_;
114	my $items = scalar(keys %{$href});
115	$dumped .= "HASH items=$items\n";
116	foreach $key (sort keys %{$href}) {
117		$dumped .= 'KEY ';
118		&recursive_dump(\$key, undef);
119		unless (defined $href->{$key}) {
120			$dumped .= 'VALUE_UNDEF' . "\n";
121			next;
122		}
123		$dumped .= 'VALUE ';
124		&recursive_dump(\$href->{$key}, 1);
125	}
126}
127
128# Dump reference to reference
129sub dump_ref {
130	my ($rref) = @_;
131	my $deref = $$rref;				# Follow reference to reference
132	$dumped .= 'REF ';
133	&recursive_dump($deref, 1);		# $dref is a reference
134}
135
1361;
137