Storable 2.06 (was Re: Bug in ext/Storable/t/integer.t)

Message-ID: <20021007223534.GD286@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@18008

10 files changed, 85 insertions, 32 deletions

diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog
index 16bc783071..74bad2eefa 100644
--- a/ext/Storable/ChangeLog
+++ b/ext/Storable/ChangeLog
@@ -1,3 +1,23 @@
+Mon Oct  7 21:56:38 BST 2002   Nicholas Clark  <nick@ccl4.org>
+
+    Version 2.06
+
+	Remove qr// from t/downgrade.t so that it will run on 5.004
+	Mention $File::Spec::VERSION a second time in t/forgive.t so that it
+	runs without warnings in 5.004 (this may be a 5.00405 bug I'm working
+	round)
+	Fix t/integer.t initialisation to actually generate 64 bits of 9c
+	Fix comparison tests to use eval to get around 64 bit IV conversion
+	issues on 5.6.x, following my t/integer.t ^ precedence bug found by
+	Rafael Garcia-Suarez
+	Alter t/malice.t to work with Test/More.pm in t/, and skip individual
+	subtests that use $Config{ptrsize}, so that the rest of the test can
+	now be run with 5.004
+	Change t/malice.t and the error message in check_magic in Storable.xs
+	from "Pointer integer size" to "Pointer size"
+	Remove prerequisite of Test::More from Makefile.PL
+	Ship Test::Builder, Test::Simple and Test::More in t
+
 Thu Oct  3 08:57:22 IST 2002   Abhijit Menon-Sen <ams@wiw.org>
 
     Version 2.05
diff --git a/ext/Storable/Makefile.PL b/ext/Storable/Makefile.PL
index 3ac71c8b8b..60e1453e88 100644
--- a/ext/Storable/Makefile.PL
+++ b/ext/Storable/Makefile.PL
@@ -12,7 +12,8 @@ WriteMakefile(
     NAME                => 'Storable',
     DISTNAME            => "Storable",
     MAN3PODS            => {},
-    PREREQ_PM           => { 'Test::More' => '0.41' },
+# We now ship this in t/
+#    PREREQ_PM           => { 'Test::More' => '0.41' },
     INSTALLDIRS         => 'perl',
     VERSION_FROM        => 'Storable.pm',
     dist                => { SUFFIX => 'gz', COMPRESS => 'gzip -f' },
diff --git a/ext/Storable/README b/ext/Storable/README
index 2ed16d51da..b0d5f1b6ec 100644
--- a/ext/Storable/README
+++ b/ext/Storable/README
@@ -1,4 +1,4 @@
-                         Storable 1.015
+                         Storable 2.06
                Copyright (c) 1995-2000, Raphael Manfredi
                Copyright (c) 2001,2002, Larry Wall
 
diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index 1283b7983e..1a62e622f7 100644
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter DynaLoader);
 use AutoLoader;
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.05';
+$VERSION = '2.06';
 *AUTOLOAD = \&AutoLoader::AUTOLOAD;		# Grrr...
 
 #
@@ -361,6 +361,9 @@ sub thaw {
 	return $self;
 }
 
+1;
+__END__
+
 =head1 NAME
 
 Storable - persistence for Perl data structures
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index b7ddc739e6..efa441a88d 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -5348,7 +5348,7 @@ static SV *magic_check(stcxt_t *cxt)
 
     /* sizeof(char *) */
     if ((int) *current != sizeof(char *))
-        CROAK(("Pointer integer size is not compatible"));
+        CROAK(("Pointer size is not compatible"));
 
     if (use_NV_size) {
         /* sizeof(NV) */
@@ -5642,7 +5642,22 @@ static SV *do_retrieve(
 
 	if (!sv) {
 		TRACEME(("retrieve ERROR"));
+#if (PATCHLEVEL <= 4) 
+		/* perl 5.00405 seems to screw up at this point with an
+		   'attempt to modify a read only value' error reported in the
+		   eval { $self = pretrieve(*FILE) } in _retrieve.
+		   I can't see what the cause of this error is, but I suspect a
+		   bug in 5.004, as it seems to be capable of issuing spurious
+		   errors or core dumping with matches on $@. I'm not going to
+		   spend time on what could be a fruitless search for the cause,
+		   so here's a bodge. If you're running 5.004 and don't like
+		   this inefficiency, either upgrade to a newer perl, or you are
+		   welcome to find the problem and send in a patch.
+		 */
+		return newSV(0);
+#else
 		return &PL_sv_undef;		/* Something went wrong, return undef */
+#endif
 	}
 
 	TRACEME(("retrieve got %s(0x%"UVxf")",
diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t
index 2274dc9003..a227360b24 100644
--- a/ext/Storable/t/downgrade.t
+++ b/ext/Storable/t/downgrade.t
@@ -9,13 +9,6 @@
 # I ought to keep this test easily backwards compatible to 5.004, so no
 # qr//;
 
-BEGIN {
-    if ($] < 5.005) {
-	print "1..0 # Skip: usage of qr//\n";
-	exit 0;
-    }
-}
-
 # This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
 # are encountered.
 
@@ -67,8 +60,8 @@ if ($] > 5.007002) {
   plan tests => 67;
 }
 
-$UTF8_CROAK = qr/^Cannot retrieve UTF8 data in non-UTF8 perl/;
-$RESTRICTED_CROAK = qr/^Cannot retrieve restricted hash/;
+$UTF8_CROAK = "/^Cannot retrieve UTF8 data in non-UTF8 perl/";
+$RESTRICTED_CROAK = "/^Cannot retrieve restricted hash/";
 
 my %tests;
 {
@@ -128,11 +121,11 @@ sub test_locked_hash {
   my @keys = keys %$hash;
   my ($key, $value) = each %$hash;
   eval {$hash->{$key} = reverse $value};
-  like( $@, qr/^Modification of a read-only value attempted/,
+  like( $@, "/^Modification of a read-only value attempted/",
         'trying to change a locked key' );
   is ($hash->{$key}, $value, "hash should not change?");
   eval {$hash->{use} = 'perl'};
-  like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/,
+  like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
         'trying to add another key' );
   ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
 }
@@ -146,7 +139,7 @@ sub test_restricted_hash {
         'trying to change a restricted key' );
   is ($hash->{$key}, reverse ($value), "hash should change");
   eval {$hash->{use} = 'perl'};
-  like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/,
+  like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
         'trying to add another key' );
   ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
 }
diff --git a/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t
index 65a2e4ccc1..109ba833b7 100644
--- a/ext/Storable/t/forgive.t
+++ b/ext/Storable/t/forgive.t
@@ -29,6 +29,9 @@ use Storable qw(store retrieve);
 if (eval { require File::Spec; 1 } || $File::Spec::VERSION < 0.8) {
     print "1..0 # Skip: File::Spec 0.8 needed\n";
     exit 0;
+    # Mention $File::Spec::VERSION again, as 5.00503's harness seems to have
+    # warnings on.
+    exit $File::Spec::VERSION;
 }
 
 print "1..8\n";
diff --git a/ext/Storable/t/integer.t b/ext/Storable/t/integer.t
index 3d0c41070b..8b0e6c4bab 100644
--- a/ext/Storable/t/integer.t
+++ b/ext/Storable/t/integer.t
@@ -37,10 +37,10 @@ my $max_uv_m1 = ~0 ^ 1;
 # use integer.
 my $max_iv_p1 = $max_uv ^ ($max_uv >> 1);
 my $lots_of_9C = do {
-  my $temp = sprintf "%X", ~0;
-  $temp =~ s/FF/9C/g;
+  my $temp = sprintf "%#x", ~0;
+  $temp =~ s/ff/9c/g;
   local $^W;
-  hex $temp;
+  eval $temp;
 };
 
 my $max_iv = ~0 >> 1;
@@ -122,7 +122,7 @@ foreach (@processes) {
   foreach my $number (@numbers) {
     # as $number is an alias into @numbers, we don't want any side effects of
     # conversion macros affecting later runs, so pass a copy to Storable:
-    my $copy1 = my $copy0 = $number;
+    my $copy1 = my $copy2 = my $copy0 = $number;
     my $copy_s = &$sub (\$copy0);
     if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) {
       # Test inside use integer to see if the bit pattern is identical
@@ -148,19 +148,28 @@ foreach (@processes) {
       # $eq =  && (($copy_s1 <=> 0) == ($copy1 <=> 0));
       # Split this into 2 tests, to cater for 5.005_03
 
-      my $bit =  ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
+      # Aargh. Even this doesn't work because 5.6.x sends values with (same
+      # number of decimal digits as ~0 + 1) via atof. So ^ is getting strings
+      # cast to doubles cast to integers. And that truncates low order bits.
+      # my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
+
+      # Oh well; at least the parser gets it right. :-)
+      my $copy_s3 = eval $copy_s1;
+      die "Was supposed to have number $copy_s3, got error $@"
+	unless defined $copy_s3;
+      my $bit = ok (($copy_s3 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
       # This is sick. 5.005_03 survives without the IV/UV flag, and somehow
       # gets it right, providing you don't have side effects of conversion.
 #      local $TODO;
 #      $TODO = "pre 5.6 doesn't have flag to distinguish IV/UV"
 #        if $[ < 5.005_56 and $copy1 > $max_iv;
-      my $sign = ok (($copy_s2 <=> 0) == ($copy1 <=> 0),
+      my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0),
                      "$process $copy1 (sign)");
 
       unless ($bit and $sign) {
         printf "# Passed in %s  (%#x, %i)\n# got back '%s' (%#x, %i)\n",
           $copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1;
-        # use Devel::Peek; Dump $copy_s1; Dump $$copy_s;
+        # use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1;
       }
       # unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; }
     } else {
diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t
index 6d21776683..0b667d94b3 100644
--- a/ext/Storable/t/malice.t
+++ b/ext/Storable/t/malice.t
@@ -17,16 +17,15 @@ sub BEGIN {
     if ($ENV{PERL_CORE}){
 	chdir('t') if -d 't';
 	@INC = ('.', '../lib');
+    } else {
+	# This lets us distribute Test::More in t/
+	unshift @INC, 't';
     }
     require Config; import Config;
     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
         print "1..0 # Skip: Storable was not built\n";
         exit 0;
     }
-    if ($] < 5.005) {
-        print "1..0 # Skip: Config{ptrsize} not defined\n";
-        exit 0;
-    }
 }
 
 use strict;
@@ -88,7 +87,11 @@ sub test_header {
     is ($header->{byteorder}, $byteorder, "byte order");
     is ($header->{intsize}, $Config{intsize}, "int size");
     is ($header->{longsize}, $Config{longsize}, "long size");
-    is ($header->{ptrsize}, $Config{ptrsize}, "long size");
+ SKIP: {
+	skip ("No \$Config{prtsize} on this perl version ($])", 1)
+	    unless defined $Config{ptrsize};
+	is ($header->{ptrsize}, $Config{ptrsize}, "long size");
+    }
     is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
         "nv size"); # 5.00405 doesn't even have doublesize in config.
   }
@@ -115,6 +118,7 @@ sub test_truncated {
   for my $i (0 .. length ($data) - 1) {
     my $short = substr $data, 0, $i;
 
+    # local $Storable::DEBUGME = 1;
     my $clone = &$sub($short);
     is (defined ($clone), '', "truncated $what to $i should fail");
     if ($i < $magic_len) {
@@ -213,7 +217,7 @@ sub test_things {
     $where = $file_magic + 3 + length $header->{byteorder};
     foreach (['intsize', "Integer"],
              ['longsize', "Long integer"],
-             ['ptrsize', "Pointer integer"],
+             ['ptrsize', "Pointer"],
              ['nvsize', "Double"]) {
       my ($key, $name) = @$_;
       $copy = $contents;
diff --git a/ext/Storable/t/restrict.t b/ext/Storable/t/restrict.t
index 75c9d20657..4ab6d86813 100644
--- a/ext/Storable/t/restrict.t
+++ b/ext/Storable/t/restrict.t
@@ -16,9 +16,14 @@ sub BEGIN {
             exit 0;
         }
     } else {
-        unless (eval "require Hash::Util") {
-            if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/) {
-                print "1..0 # Skip: No Hash::Util\n";
+	if ($[ < 5.005) {
+	    print "1..0 # Skip: No Hash::Util pre 5.005\n";
+	    exit 0;
+	    # And doing this seems on 5.004 seems to create bogus warnings about
+	    # unitialized variables, or coredumps in Perl_pp_padsv
+	} elsif (!eval "require Hash::Util") {
+            if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) {
+                print "1..0 # Skip: No Hash::Util:\n";
                 exit 0;
             } else {
                 die;