1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
;# Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp
;#
;# Copyright (c) 1995-2000, Raphael Manfredi
;#
;# You may redistribute only under the terms of the Artistic License,
;# as specified in the README file that comes with the distribution.
;#
;# Log: dump.pl,v
;# Revision 0.7 2000/08/03 22:04:45 ram
;# Baseline for second beta release.
;#
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',
);
# 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
}
# Dump code
sub dump_code {
my ($sref) = @_;
$dumped .= "CODE\n";
}
1;
|
