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