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