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