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