t/lib/st-dump.pl

   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 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;