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 { |
14 | my ($num, $ok) = @_; |
15 | print "not " unless $ok; |
16 | print "ok $num\n"; |
17 | } |
18 | |
19 | package dump; |
20 | use Carp; |
21 | |
22 | %dump = ( |
23 | 'SCALAR' => 'dump_scalar', |
24 | 'ARRAY' => 'dump_array', |
25 | 'HASH' => 'dump_hash', |
26 | 'REF' => 'dump_ref', |
27 | ); |
28 | |
29 | # Given an object, dump its transitive data closure |
30 | sub main'dump { |
31 | my ($object) = @_; |
32 | croak "Not a reference!" unless ref($object); |
33 | local %dumped; |
34 | local %object; |
35 | local $count = 0; |
36 | local $dumped = ''; |
37 | &recursive_dump($object, 1); |
38 | return $dumped; |
39 | } |
40 | |
41 | # This is the root recursive dumping routine that may indirectly be |
42 | # called by one of the routine it calls... |
43 | # The link parameter is set to false when the reference passed to |
44 | # the routine is an internal temporay variable, implying the object's |
45 | # address is not to be dumped in the %dumped table since it's not a |
46 | # user-visible object. |
47 | sub recursive_dump { |
48 | my ($object, $link) = @_; |
49 | |
50 | # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...). |
51 | # Then extract the bless, ref and address parts of that string. |
52 | |
53 | my $what = "$object"; # Stringify |
54 | my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/; |
55 | ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless; |
56 | |
57 | # Special case for references to references. When stringified, |
58 | # they appear as being scalars. However, ref() correctly pinpoints |
59 | # them as being references indirections. And that's it. |
60 | |
61 | $ref = 'REF' if ref($object) eq 'REF'; |
62 | |
63 | # Make sure the object has not been already dumped before. |
64 | # We don't want to duplicate data. Retrieval will know how to |
65 | # relink from the previously seen object. |
66 | |
67 | if ($link && $dumped{$addr}++) { |
68 | my $num = $object{$addr}; |
69 | $dumped .= "OBJECT #$num seen\n"; |
70 | return; |
71 | } |
72 | |
73 | my $objcount = $count++; |
74 | $object{$addr} = $objcount; |
75 | |
76 | # Call the appropriate dumping routine based on the reference type. |
77 | # If the referenced was blessed, we bless it once the object is dumped. |
78 | # The retrieval code will perform the same on the last object retrieved. |
79 | |
80 | croak "Unknown simple type '$ref'" unless defined $dump{$ref}; |
81 | |
82 | &{$dump{$ref}}($object); # Dump object |
83 | &bless($bless) if $bless; # Mark it as blessed, if necessary |
84 | |
85 | $dumped .= "OBJECT $objcount\n"; |
86 | } |
87 | |
88 | # Indicate that current object is blessed |
89 | sub bless { |
90 | my ($class) = @_; |
91 | $dumped .= "BLESS $class\n"; |
92 | } |
93 | |
94 | # Dump single scalar |
95 | sub dump_scalar { |
96 | my ($sref) = @_; |
97 | my $scalar = $$sref; |
98 | unless (defined $scalar) { |
99 | $dumped .= "UNDEF\n"; |
100 | return; |
101 | } |
102 | my $len = length($scalar); |
103 | $dumped .= "SCALAR len=$len $scalar\n"; |
104 | } |
105 | |
106 | # Dump array |
107 | sub dump_array { |
108 | my ($aref) = @_; |
109 | my $items = 0 + @{$aref}; |
110 | $dumped .= "ARRAY items=$items\n"; |
111 | foreach $item (@{$aref}) { |
112 | unless (defined $item) { |
113 | $dumped .= 'ITEM_UNDEF' . "\n"; |
114 | next; |
115 | } |
116 | $dumped .= 'ITEM '; |
117 | &recursive_dump(\$item, 1); |
118 | } |
119 | } |
120 | |
121 | # Dump hash table |
122 | sub dump_hash { |
123 | my ($href) = @_; |
124 | my $items = scalar(keys %{$href}); |
125 | $dumped .= "HASH items=$items\n"; |
126 | foreach $key (sort keys %{$href}) { |
127 | $dumped .= 'KEY '; |
128 | &recursive_dump(\$key, undef); |
129 | unless (defined $href->{$key}) { |
130 | $dumped .= 'VALUE_UNDEF' . "\n"; |
131 | next; |
132 | } |
133 | $dumped .= 'VALUE '; |
134 | &recursive_dump(\$href->{$key}, 1); |
135 | } |
136 | } |
137 | |
138 | # Dump reference to reference |
139 | sub dump_ref { |
140 | my ($rref) = @_; |
141 | my $deref = $$rref; # Follow reference to reference |
142 | $dumped .= 'REF '; |
143 | &recursive_dump($deref, 1); # $dref is a reference |
144 | } |
145 | |
146 | 1; |