ext/Storable/t/downgrade.t See if Storable works
ext/Storable/t/forgive.t See if Storable works
ext/Storable/t/freeze.t See if Storable works
+ext/Storable/t/integer.t See if Storable works
ext/Storable/t/lock.t See if Storable works
ext/Storable/t/make_downgrade.pl See if Storable works
ext/Storable/t/malice.t See if Storable copes with corrupt files
+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:
use AutoLoader;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.00';
+$VERSION = '2.01';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
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 */
}
/*
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)
--- /dev/null
+#!./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");
+ }
+ }
+}
projects / platform / upstream / perl.git / commitdiff