From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Wed, 15 May 2002 20:03:28 +0000 (+0000)
Subject: Schizoid MANIFESTs.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c0d8608835372f57ea08949bb5269ea6234ee3f3;p=p5sagit%2Fp5-mst-13.2.git

Schizoid MANIFESTs.

p4raw-id: //depot/perl@16614
---

diff --git a/MANIFEST b/MANIFEST
index 6c00f87..1c37a85 100644
--- 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
--- 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
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
--- 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;