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
155
156
157
158
159
160
161
162
163
164
165
|
#
# 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;
|
