From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 18 May 2002 00:18:39 +0000 (+0100)
Subject: Re: [PATCH] Storable stand alone tests
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7dadce444419cb5cc2a17faf09d9ea75a7e4b67b;p=p5sagit%2Fp5-mst-13.2.git

Re: [PATCH] Storable stand alone tests
Message-ID: <20020517231838.GI290@Bagpuss.unfortu.net>

Use Storable's st-dump.pl.

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

diff --git a/MANIFEST b/MANIFEST
index 834b980..bcff43b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2378,7 +2378,6 @@ t/lib/sample-tests/todo			Test data for Test::Harness
 t/lib/sample-tests/todo_inline		Test data for Test::Harness
 t/lib/sample-tests/vms_nit		Test data for Test::Harness
 t/lib/sample-tests/with_comments	Test data for Test::Harness
-t/lib/st-dump.pl		See if Storable works
 t/lib/strict/refs		Tests of "use strict 'refs'" for strict.t
 t/lib/strict/subs		Tests of "use strict 'subs'" for strict.t
 t/lib/strict/vars		Tests of "use strict 'vars'" for strict.t
diff --git a/ext/Storable/t/blessed.t b/ext/Storable/t/blessed.t
index 4c9ea8e..f53ba3a 100644
--- a/ext/Storable/t/blessed.t
+++ b/ext/Storable/t/blessed.t
@@ -15,7 +15,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/compat06.t b/ext/Storable/t/compat06.t
index 08c2ce5..bad203f 100644
--- a/ext/Storable/t/compat06.t
+++ b/ext/Storable/t/compat06.t
@@ -18,7 +18,7 @@
 BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/dclone.t b/ext/Storable/t/dclone.t
index 563817b..f42c02a 100644
--- a/ext/Storable/t/dclone.t
+++ b/ext/Storable/t/dclone.t
@@ -15,7 +15,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/freeze.t b/ext/Storable/t/freeze.t
index fd91ad8..8a94419 100644
--- a/ext/Storable/t/freeze.t
+++ b/ext/Storable/t/freeze.t
@@ -18,7 +18,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/lock.t b/ext/Storable/t/lock.t
index 6ed9148..5e274f0 100644
--- a/ext/Storable/t/lock.t
+++ b/ext/Storable/t/lock.t
@@ -22,7 +22,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/overload.t b/ext/Storable/t/overload.t
index e0d204d..b272d1a 100644
--- a/ext/Storable/t/overload.t
+++ b/ext/Storable/t/overload.t
@@ -18,7 +18,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/recurse.t b/ext/Storable/t/recurse.t
index f10511d..4d1bf49 100644
--- a/ext/Storable/t/recurse.t
+++ b/ext/Storable/t/recurse.t
@@ -26,7 +26,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/restrict.t b/ext/Storable/t/restrict.t
index 24e7b9d..a028d42 100644
--- a/ext/Storable/t/restrict.t
+++ b/ext/Storable/t/restrict.t
@@ -10,7 +10,7 @@
 sub BEGIN {
     chdir('t') if -d 't';
     if ($ENV{PERL_CORE}){
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
         require Config;
         if ($Config::Config{'extensions'} !~ /\bStorable\b/) {
             print "1..0 # Skip: Storable was not built\n";
diff --git a/ext/Storable/t/retrieve.t b/ext/Storable/t/retrieve.t
index 96701ba..8f564fe 100644
--- a/ext/Storable/t/retrieve.t
+++ b/ext/Storable/t/retrieve.t
@@ -15,7 +15,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/store.t b/ext/Storable/t/store.t
index 94df1c0..1440355 100644
--- a/ext/Storable/t/store.t
+++ b/ext/Storable/t/store.t
@@ -15,7 +15,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/tied.t b/ext/Storable/t/tied.t
index 327074d..f0a3f03 100644
--- a/ext/Storable/t/tied.t
+++ b/ext/Storable/t/tied.t
@@ -15,7 +15,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/tied_hook.t b/ext/Storable/t/tied_hook.t
index b085285..54a711e 100644
--- a/ext/Storable/t/tied_hook.t
+++ b/ext/Storable/t/tied_hook.t
@@ -18,7 +18,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/tied_items.t b/ext/Storable/t/tied_items.t
index 0198f44..ba790e8 100644
--- a/ext/Storable/t/tied_items.t
+++ b/ext/Storable/t/tied_items.t
@@ -19,7 +19,7 @@
 sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/ext/Storable/t/utf8.t b/ext/Storable/t/utf8.t
index 890834f..449126a 100644
--- a/ext/Storable/t/utf8.t
+++ b/ext/Storable/t/utf8.t
@@ -23,7 +23,7 @@ sub BEGIN {
     }
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
-	@INC = ('.', '../lib', '../t/lib');
+	@INC = ('.', '../lib', '../ext/Storable/t');
     } else {
 	unshift @INC, 't';
     }
diff --git a/t/lib/st-dump.pl b/t/lib/st-dump.pl
deleted file mode 100644
index 6ce77f0..0000000
--- a/t/lib/st-dump.pl
+++ /dev/null
@@ -1,169 +0,0 @@
-;# $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;