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