Re: [Another bug] Re: about Storable perl module (again)

Message-ID: <20020523224316.GB989@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@16759

4 files changed, 277 insertions, 71 deletions

diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog
index d0fb08417b..a18c77fda6 100644
--- a/ext/Storable/ChangeLog
+++ b/ext/Storable/ChangeLog
@@ -1,3 +1,19 @@
+Thu May 23 22:50:41 BST 2002   Nicholas Clark <nick@ccl4.org>
+
+. Description:
+
+	Version 2.01
+
+	New regression tests integer.t
+	Add code to safely store large unsigned integers.
+	Change code not to attempt to store large integers (ie > 32 bits)
+	in network order as 32 bits.
+	*Never* underestimate the value of a pathological test suite carefully
+	crafted with maximum malice before writing a line of real code. It
+	prevents crafty bugs from stowing away in your released code.
+	It's much less embarrassing to find them before you ship.
+	(Well, never underestimate it if you ever want to work for me)
+	
 Fri May 17 22:48:59 BST 2002   Nicholas Clark <nick@ccl4.org>
 
 . Description:
diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index 112c87162b..e694273d77 100644
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -70,7 +70,7 @@ package Storable; @ISA = qw(Exporter DynaLoader);
 use AutoLoader;
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.00';
+$VERSION = '2.01';
 *AUTOLOAD = \&AutoLoader::AUTOLOAD;		# Grrr...
 
 #
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 1ab7a4c93f..baea2c509d 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -1836,89 +1836,134 @@ static int store_scalar(stcxt_t *cxt, SV *sv)
 			pv = SvPV(sv, len);			/* We know it's SvPOK */
 			goto string;				/* Share code below */
 		}
-	} else if (flags & SVp_POK) {		/* SvPOKp(sv) => string */
-		I32 wlen;						/* For 64-bit machines */
-		pv = SvPV(sv, len);
-
-		/*
-		 * Will come here from below with pv and len set if double & netorder,
-		 * or from above if it was readonly, POK and NOK but neither &PL_sv_yes
-		 * nor &PL_sv_no.
-		 */
-	string:
+	} else if (flags & SVf_POK) {
+            /* public string - go direct to string read.  */
+            goto string_readlen;
+        } else if (
+#if (PATCHLEVEL <= 6)
+            /* For 5.6 and earlier NV flag trumps IV flag, so only use integer
+               direct if NV flag is off.  */
+            (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK
+#else
+            /* 5.7 rules are that if IV public flag is set, IV value is as
+               good, if not better, than NV value.  */
+            flags & SVf_IOK
+#endif
+            ) {
+            iv = SvIV(sv);
+            /*
+             * Will come here from below with iv set if double is an integer.
+             */
+          integer:
 
-		wlen = (I32) len;				/* WLEN via STORE_SCALAR expects I32 */
-		if (SvUTF8 (sv))
-			STORE_UTF8STR(pv, wlen);
-		else
-			STORE_SCALAR(pv, wlen);
-		TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
-			 PTR2UV(sv), SvPVX(sv), (IV)len));
+            /* Sorry. This isn't in 5.005_56 (IIRC) or earlier.  */
+#ifdef SVf_IVisUV
+            /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
+             * (for example) and that ends up in the optimised small integer
+             * case. 
+             */
+            if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
+                TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv)));
+                goto string_readlen;
+            }
+#endif
+            /*
+             * Optimize small integers into a single byte, otherwise store as
+             * a real integer (converted into network order if they asked).
+             */
 
-	} else if (flags & SVp_NOK) {		/* SvNOKp(sv) => double */
-		NV nv = SvNV(sv);
+            if (iv >= -128 && iv <= 127) {
+                unsigned char siv = (unsigned char) (iv + 128);	/* [0,255] */
+                PUTMARK(SX_BYTE);
+                PUTMARK(siv);
+                TRACEME(("small integer stored as %d", siv));
+            } else if (cxt->netorder) {
+#ifndef HAS_HTONL
+                TRACEME(("no htonl, fall back to string for integer"));
+                goto string_readlen;
+#else
+                I32 niv;
 
-		/*
-		 * Watch for number being an integer in disguise.
-		 */
-		if (nv == (NV) (iv = I_V(nv))) {
-			TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
-			goto integer;		/* Share code below */
-		}
 
-		if (cxt->netorder) {
-			TRACEME(("double %"NVff" stored as string", nv));
-			pv = SvPV(sv, len);
-			goto string;		/* Share code above */
-		}
+#if IVSIZE > 4
+                if (
+#ifdef SVf_IVisUV
+                    /* Sorry. This isn't in 5.005_56 (IIRC) or earlier.  */
+                    ((flags & SVf_IVisUV) && SvUV(sv) > 0x7FFFFFFF) ||
+#endif
+                    (iv > 0x7FFFFFFF) || (iv < -0x80000000)) {
+                    /* Bigger than 32 bits.  */
+                    TRACEME(("large network order integer as string, value = %"IVdf, iv));
+                    goto string_readlen;
+                }
+#endif
 
-		PUTMARK(SX_DOUBLE);
-		WRITE(&nv, sizeof(nv));
+                niv = (I32) htonl((I32) iv);
+                TRACEME(("using network order"));
+                PUTMARK(SX_NETINT);
+                WRITE_I32(niv);
+#endif
+            } else {
+                PUTMARK(SX_INTEGER);
+                WRITE(&iv, sizeof(iv));
+            }
+            
+            TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
+	} else if (flags & SVf_NOK) {
+            NV nv;
+#if (PATCHLEVEL <= 6)
+            nv = SvNV(sv);
+            /*
+             * Watch for number being an integer in disguise.
+             */
+            if (nv == (NV) (iv = I_V(nv))) {
+                TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
+                goto integer;		/* Share code above */
+            }
+#else
 
-		TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
+            SvIV_please(sv);
+            if (SvIOK(sv)) {
+                iv = SvIV(sv);
+                goto integer;		/* Share code above */
+            }
+            nv = SvNV(sv);
+#endif
 
-	} else if (flags & SVp_IOK) {		/* SvIOKp(sv) => integer */
-		iv = SvIV(sv);
+            if (cxt->netorder) {
+                TRACEME(("double %"NVff" stored as string", nv));
+                goto string_readlen;		/* Share code below */
+            }
 
-		/*
-		 * Will come here from above with iv set if double is an integer.
-		 */
-	integer:
+            PUTMARK(SX_DOUBLE);
+            WRITE(&nv, sizeof(nv));
 
-		/*
-		 * Optimize small integers into a single byte, otherwise store as
-		 * a real integer (converted into network order if they asked).
-		 */
+            TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
 
-		if (iv >= -128 && iv <= 127) {
-			unsigned char siv = (unsigned char) (iv + 128);	/* [0,255] */
-			PUTMARK(SX_BYTE);
-			PUTMARK(siv);
-			TRACEME(("small integer stored as %d", siv));
-		} else if (cxt->netorder) {
-			I32 niv;
-#ifdef HAS_HTONL
-			niv = (I32) htonl(iv);
-			TRACEME(("using network order"));
-#else
-			niv = (I32) iv;
-			TRACEME(("as-is for network order"));
-#endif
-			PUTMARK(SX_NETINT);
-			WRITE_I32(niv);
-		} else {
-			PUTMARK(SX_INTEGER);
-			WRITE(&iv, sizeof(iv));
-		}
+	} else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
+            I32 wlen; /* For 64-bit machines */
 
-		TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
+          string_readlen:
+            pv = SvPV(sv, len);
 
+            /*
+             * Will come here from above  if it was readonly, POK and NOK but
+             * neither &PL_sv_yes nor &PL_sv_no.
+             */
+          string:
+
+            wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
+            if (SvUTF8 (sv))
+                STORE_UTF8STR(pv, wlen);
+            else
+                STORE_SCALAR(pv, wlen);
+            TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
+                     PTR2UV(sv), SvPVX(sv), (IV)len));
 	} else
-		CROAK(("Can't determine type of %s(0x%"UVxf")",
-		       sv_reftype(sv, FALSE),
-		       PTR2UV(sv)));
-
-	return 0;		/* Ok, no recursion on scalars */
+            CROAK(("Can't determine type of %s(0x%"UVxf")",
+                   sv_reftype(sv, FALSE),
+                   PTR2UV(sv)));
+        return 0;		/* Ok, no recursion on scalars */
 }
 
 /*
@@ -5483,6 +5528,10 @@ PROTOTYPES: ENABLE
 
 BOOT:
     init_perinterp();
+#ifdef DEBUGME
+    /* Only disable the used only once warning if we are in debugging mode.  */
+    gv_fetchpv("Storable::DEBUGME",   GV_ADDMULTI, SVt_PV);
+#endif
 
 int
 pstore(f,obj)
diff --git a/ext/Storable/t/integer.t b/ext/Storable/t/integer.t
new file mode 100644
index 0000000000..de33647dec
--- /dev/null
+++ b/ext/Storable/t/integer.t
@@ -0,0 +1,141 @@
+#!./perl -w
+
+#
+#  Copyright 2002, Larry Wall.
+#
+#  You may redistribute only under the same terms as Perl 5, as specified
+#  in the README file that comes with the distribution.
+#
+
+# I ought to keep this test easily backwards compatible to 5.004, so no
+# qr//;
+
+# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
+# are encountered.
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+	chdir('t') if -d 't';
+	@INC = ('.', '../lib');
+    } else {
+	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;
+    }
+}
+
+use Test::More;
+use Storable qw (dclone store retrieve freeze thaw nstore nfreeze);
+use strict;
+
+my $max_uv = ~0;
+my $max_uv_m1 = ~0 ^ 1;
+# Express it in this way so as not to use any addition, as 5.6 maths would
+# do this in NVs on 64 bit machines, and we're overflowing IVs so can't use
+# 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;
+  local $^W;
+  hex $temp;
+};
+
+my $max_iv = ~0 >> 1;
+my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption
+
+my @processes = (["dclone", \&do_clone],
+                 ["freeze/thaw", \&freeze_and_thaw],
+                 ["nfreeze/thaw", \&nfreeze_and_thaw],
+                 ["store/retrieve", \&store_and_retrieve],
+                 ["nstore/retrieve", \&store_and_retrieve],
+                );
+my @numbers =
+  (# IV bounds of 8 bits
+   -1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 256,
+   # IV bounds of 32 bits
+   -2147483647, -2147483648, -2147483649, 2147483646, 2147483647, 2147483648,
+   # IV bounds
+   $min_iv, do {use integer; $min_iv + 1}, do {use integer; $max_iv - 1},
+   $max_iv,
+   # UV bounds at 32 bits
+   0x7FFFFFFF, 0x80000000, 0x80000001, 0xFFFFFFFF, 0xDEADBEEF,
+   # UV bounds
+   $max_iv_p1, $max_uv_m1, $max_uv, $lots_of_9C,
+  );
+
+plan tests => @processes * @numbers * 4;
+
+my $file = "integer.$$";
+die "Temporary file '$file' already exists" if -e $file;
+
+END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
+
+sub do_clone {
+  my $data = shift;
+  my $copy = eval {dclone $data};
+  is ($@, '', 'Should be no error dcloning');
+  ok (1, "dlcone is only 1 process, not 2");
+  return $copy;
+}
+
+sub freeze_and_thaw {
+  my $data = shift;
+  my $frozen = eval {freeze $data};
+  is ($@, '', 'Should be no error freezing');
+  my $copy = eval {thaw $frozen};
+  is ($@, '', 'Should be no error thawing');
+  return $copy;
+}
+
+sub nfreeze_and_thaw {
+  my $data = shift;
+  my $frozen = eval {nfreeze $data};
+  is ($@, '', 'Should be no error nfreezing');
+  my $copy = eval {thaw $frozen};
+  is ($@, '', 'Should be no error thawing');
+  return $copy;
+}
+
+sub store_and_retrieve {
+  my $data = shift;
+  my $frozen = eval {store $data, $file};
+  is ($@, '', 'Should be no error storing');
+  my $copy = eval {retrieve $file};
+  is ($@, '', 'Should be no error retrieving');
+  return $copy;
+}
+
+sub nstore_and_retrieve {
+  my $data = shift;
+  my $frozen = eval {nstore $data, $file};
+  is ($@, '', 'Should be no error storing');
+  my $copy = eval {retrieve $file};
+  is ($@, '', 'Should be no error retrieving');
+  return $copy;
+}
+
+foreach (@processes) {
+  my ($process, $sub) = @$_;
+  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 $copy_s = &$sub (\$copy0);
+    # use Devel::Peek; Dump $copy0;
+    if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) {
+      # Test inside use integer to see if the bit pattern is identical
+      # and outside to see if the sign is right.
+      # On 5.8 we don't need this trickery anymore.
+      my $eq = do {use integer; $$copy_s == $copy1} && $$copy_s == $copy1;
+      ok ($eq, "$process $copy1") or
+        printf "# Passed in $copy1, got back %s\n",
+          defined $$copy_s ? $$copy_s : undef;
+    } else {
+      fail ("$process $copy1");
+    }
+  }
+}