ext/Storable/t/st-dump.pl

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