Schizoid MANIFESTs.

p4raw-id: //depot/perl@16614

diff --git a/MANIFEST b/MANIFEST
index 6c00f87..1c37a85 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -615,6 +615,7 @@ ext/Storable/t/overload.t   See if Storable works
 ext/Storable/t/recurse.t       See if Storable works
 ext/Storable/t/restrict.t      See if Storable works
 ext/Storable/t/retrieve.t      See if Storable works
+ext/Storable/t/st-dump.pl      See if Storable works
 ext/Storable/t/store.t         See if Storable works
 ext/Storable/t/tied.t          See if Storable works
 ext/Storable/t/tied_hook.t     See if Storable works

diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST
index 1cdb74c..f946927 100644 (file)
--- a/ext/Storable/MANIFEST
+++ b/ext/Storable/MANIFEST
@@ -19,10 +19,10 @@ t/overload.t                    See if Storable works
 t/recurse.t                See if Storable works
 t/restrict.t               See if Storable works
 t/retrieve.t               See if Storable works
+t/st-dump.pl               helper routines for tests
 t/store.t                  See if Storable works
 t/tied.t                   See if Storable works
 t/tied_hook.t              See if Storable works
 t/tied_items.t             See if Storable works
 t/utf8.t                   See if Storable works
 t/utf8hash.t               See if Storable works
-lib/st-dump.pl             helper routines for tests

diff --git a/ext/Storable/t/st-dump.pl b/ext/Storable/t/st-dump.pl
new file mode 100644 (file)
index 0000000..6ce77f0
--- /dev/null
+++ b/ext/Storable/t/st-dump.pl
@@ -0,0 +1,169 @@
+;# $Id: dump.pl,v 1.0 2000/09/01 19:40:41 ram Exp $
+;#
+;#  Copyright (c) 1995-2000, Raphael Manfredi
+;#  
+;#  You may redistribute only under the same terms as Perl 5, as specified
+;#  in the README file that comes with the distribution.
+;#
+;# $Log: dump.pl,v $
+;# Revision 1.0  2000/09/01 19:40:41  ram
+;# Baseline for first official release.
+;#
+
+# NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl
+# TO t/lib/st-dump.pl.  One could also play games with
+# File::Spec->updir and catdir to get the st-dump.pl in
+# ext/Storable into @INC.
+
+sub ok {
+       my ($num, $ok, $name) = @_;
+        $num .= " - $name" if defined $name and length $name;
+       print $ok ? "ok $num\n" : "not ok $num\n";
+        $ok;
+}
+
+sub num_equal {
+       my ($num, $left, $right, $name) = @_;
+        my $ok = ((defined $left) ? $left == $right : undef);
+        unless (ok ($num, $ok, $name)) {
+          print "# Expected $right\n";
+          if (!defined $left) {
+            print "# Got undef\n";
+          } elsif ($left !~ tr/0-9//c) {
+            print "# Got $left\n";
+          } else {
+            $left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge;
+            print "# Got \"$left\"\n";
+          }
+        }
+        $ok;
+}
+
+package dump;
+use Carp;
+
+%dump = (
+       'SCALAR'        => 'dump_scalar',
+       'ARRAY'         => 'dump_array',
+       'HASH'          => 'dump_hash',
+       'REF'           => 'dump_ref',
+);
+
+# Given an object, dump its transitive data closure
+sub main'dump {
+       my ($object) = @_;
+       croak "Not a reference!" unless ref($object);
+       local %dumped;
+       local %object;
+       local $count = 0;
+       local $dumped = '';
+       &recursive_dump($object, 1);
+       return $dumped;
+}
+
+# This is the root recursive dumping routine that may indirectly be
+# called by one of the routine it calls...
+# The link parameter is set to false when the reference passed to
+# the routine is an internal temporay variable, implying the object's
+# address is not to be dumped in the %dumped table since it's not a
+# user-visible object.
+sub recursive_dump {
+       my ($object, $link) = @_;
+
+       # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
+       # Then extract the bless, ref and address parts of that string.
+
+       my $what = "$object";           # Stringify
+       my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
+       ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
+
+       # Special case for references to references. When stringified,
+       # they appear as being scalars. However, ref() correctly pinpoints
+       # them as being references indirections. And that's it.
+
+       $ref = 'REF' if ref($object) eq 'REF';
+
+       # Make sure the object has not been already dumped before.
+       # We don't want to duplicate data. Retrieval will know how to
+       # relink from the previously seen object.
+
+       if ($link && $dumped{$addr}++) {
+               my $num = $object{$addr};
+               $dumped .= "OBJECT #$num seen\n";
+               return;
+       }
+
+       my $objcount = $count++;
+       $object{$addr} = $objcount;
+
+       # Call the appropriate dumping routine based on the reference type.
+       # If the referenced was blessed, we bless it once the object is dumped.
+       # The retrieval code will perform the same on the last object retrieved.
+
+       croak "Unknown simple type '$ref'" unless defined $dump{$ref};
+
+       &{$dump{$ref}}($object);        # Dump object
+       &bless($bless) if $bless;       # Mark it as blessed, if necessary
+
+       $dumped .= "OBJECT $objcount\n";
+}
+
+# Indicate that current object is blessed
+sub bless {
+       my ($class) = @_;
+       $dumped .= "BLESS $class\n";
+}
+
+# Dump single scalar
+sub dump_scalar {
+       my ($sref) = @_;
+       my $scalar = $$sref;
+       unless (defined $scalar) {
+               $dumped .= "UNDEF\n";
+               return;
+       }
+       my $len = length($scalar);
+       $dumped .= "SCALAR len=$len $scalar\n";
+}
+
+# Dump array
+sub dump_array {
+       my ($aref) = @_;
+       my $items = 0 + @{$aref};
+       $dumped .= "ARRAY items=$items\n";
+       foreach $item (@{$aref}) {
+               unless (defined $item) {
+                       $dumped .= 'ITEM_UNDEF' . "\n";
+                       next;
+               }
+               $dumped .= 'ITEM ';
+               &recursive_dump(\$item, 1);
+       }
+}
+
+# Dump hash table
+sub dump_hash {
+       my ($href) = @_;
+       my $items = scalar(keys %{$href});
+       $dumped .= "HASH items=$items\n";
+       foreach $key (sort keys %{$href}) {
+               $dumped .= 'KEY ';
+               &recursive_dump(\$key, undef);
+               unless (defined $href->{$key}) {
+                       $dumped .= 'VALUE_UNDEF' . "\n";
+                       next;
+               }
+               $dumped .= 'VALUE ';
+               &recursive_dump(\$href->{$key}, 1);
+       }
+}
+
+# Dump reference to reference
+sub dump_ref {
+       my ($rref) = @_;
+       my $deref = $$rref;                             # Follow reference to reference
+       $dumped .= 'REF ';
+       &recursive_dump($deref, 1);             # $dref is a reference
+}
+
+1;

diff --git a/t/lib/st-dump.pl b/t/lib/st-dump.pl
index 05028f3..6ce77f0 100644 (file)
--- a/t/lib/st-dump.pl
+++ b/t/lib/st-dump.pl
@@ -10,6 +10,11 @@
 ;# Baseline for first official release.
 ;#
 
+# NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl
+# TO t/lib/st-dump.pl.  One could also play games with
+# File::Spec->updir and catdir to get the st-dump.pl in
+# ext/Storable into @INC.
+
 sub ok {
        my ($num, $ok, $name) = @_;
         $num .= " - $name" if defined $name and length $name;