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