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