From: Nicholas Clark Date: Thu, 23 May 2002 23:43:16 +0000 (+0100) Subject: Re: [Another bug] Re: about Storable perl module (again) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=db670f21917627f71db2c20f133a7cd785b58e98;p=p5sagit%2Fp5-mst-13.2.git Re: [Another bug] Re: about Storable perl module (again) Message-ID: <20020523224316.GB989@Bagpuss.unfortu.net> p4raw-id: //depot/perl@16759 --- diff --git a/MANIFEST b/MANIFEST index 8887c40..43f3043 100644 --- a/MANIFEST +++ b/MANIFEST @@ -610,6 +610,7 @@ ext/Storable/t/dclone.t See if Storable works 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 diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index d0fb084..a18c77f 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,19 @@ +Thu May 23 22:50:41 BST 2002 Nicholas Clark + +. 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 . Description: diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 112c871..e694273 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 1ab7a4c..baea2c5 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 0000000..de33647 --- /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"); + } + } +}