[Orca-checkins] r289 - in trunk/orca: . packages/Storable-2.09 packages/Storable-2.11 packages/Storable-2.11/hints packages/Storable-2.11/t
Blair Zajac
blair at orcaware.com
Wed Mar 17 20:40:20 PST 2004
Author: blair
Date: Wed Mar 17 20:39:57 2004
New Revision: 289
Added:
trunk/orca/packages/Storable-2.11/
- copied from r283, trunk/orca/packages/Storable-2.09/
trunk/orca/packages/Storable-2.11/t/just_plain_nasty.t
trunk/orca/packages/Storable-2.11/t/threads.t
Removed:
trunk/orca/packages/Storable-2.09/
Modified:
trunk/orca/INSTALL
trunk/orca/configure.in
trunk/orca/packages/Storable-2.11/ChangeLog
trunk/orca/packages/Storable-2.11/MANIFEST
trunk/orca/packages/Storable-2.11/Storable.pm
trunk/orca/packages/Storable-2.11/Storable.xs
trunk/orca/packages/Storable-2.11/hints/linux.pl
trunk/orca/packages/Storable-2.11/t/blessed.t
trunk/orca/packages/Storable-2.11/t/code.t
trunk/orca/packages/Storable-2.11/t/restrict.t
Log:
Upgrade Storable from 2.09 to 2.11 and require the new version for
Orca.
* configure.in:
Bump Storable's version number to 2.11.
* INSTALL (Determine which Perl modules need compiling and installing):
Update all references to Storable's version number from 2.09 to
2.11.
* packages/Storable-2.11:
Renamed from packages/Storable-2.09. Directory contents updated
from Storable-2.11.tar.gz.
Modified: trunk/orca/INSTALL
==============================================================================
--- trunk/orca/INSTALL (original)
+++ trunk/orca/INSTALL Wed Mar 17 20:39:57 2004
@@ -176,7 +176,7 @@
Digest::MD5 >= 2.33 >= 2.33 2.33
Math::IntervalSearch >= 1.05 >= 1.05 1.05
RRDs >= 1.000461 >= 1.0.46 1.0.46
- Storable >= 2.09 >= 2.09 2.09
+ Storable >= 2.11 >= 2.11 2.11
Time::HiRes Not required by Orca 1.55
All seven of these modules are included with the Orca distribution
@@ -267,10 +267,10 @@
Storable
- http://www.perl.com/CPAN/authors/id/A/AM/AMS/Storable-2.09.tar.gz
+ http://www.perl.com/CPAN/authors/id/A/AM/AMS/Storable-2.11.tar.gz
- % gunzip -c Storable-2.09.tar.gz | tar xvf -
- % cd Storable-2.09
+ % gunzip -c Storable-2.11.tar.gz | tar xvf -
+ % cd Storable-2.11
% perl Makefile.PL
% make
% make test
Modified: trunk/orca/configure.in
==============================================================================
--- trunk/orca/configure.in (original)
+++ trunk/orca/configure.in Wed Mar 17 20:39:57 2004
@@ -39,8 +39,8 @@
MATH_INTERVALSEARCH_VER=1.05
RRDTOOL_DIR=rrdtool-1.0.46
RRDTOOL_VER=1.000461
-STORABLE_DIR=Storable-2.09
-STORABLE_VER=2.09
+STORABLE_DIR=Storable-2.11
+STORABLE_VER=2.11
TIME_HIRES_DIR=Time-HiRes-1.55
TIME_HIRES_VER=1.55
Modified: trunk/orca/packages/Storable-2.11/ChangeLog
==============================================================================
--- trunk/orca/packages/Storable-2.09/ChangeLog (original)
+++ trunk/orca/packages/Storable-2.11/ChangeLog Wed Mar 17 20:39:57 2004
@@ -1,3 +1,28 @@
+Sat Mar 13 20:11:03 GMT 2004 Nicholas Clark <nick at ccl4.org>
+
+ Version 2.11
+
+ 1. Storing restricted hashes in canonical order would SEGV. Fixed.
+ 2. It was impossible to retrieve references to PL_sv_no and and
+ PL_sv_undef from STORABLE_thaw hooks.
+ 3. restrict.t was failing on 5.8.0, due to 5.8.0's unique
+ implementation of restricted hashes using PL_sv_undef
+ 4. These changes allow a space optimisation for restricted hashes.
+
+Sat Jan 24 16:22:32 IST 2004 Abhijit Menon-Sen <ams at wiw.org>
+
+ Version 2.10
+
+ 1. Thread safety: Storable::CLONE/init_perlinterp() now create
+ a new Perl context for each new ithread.
+ (From Stas Bekman and Jan Dubois.)
+ 2. Fix a tag count mismatch with $Storable::Deparse that caused
+ all back-references after a stored sub to be off-by-N (where
+ N was the number of code references in between).
+ (From Sam Vilain.)
+ 3. Prevent CODE references from turning into SCALAR references.
+ (From Slaven Rezic.)
+
Sat Jan 3 18:49:18 GMT 2004 Nicholas Clark <nick at ccl4.org>
Version 2.09
Modified: trunk/orca/packages/Storable-2.11/MANIFEST
==============================================================================
--- trunk/orca/packages/Storable-2.09/MANIFEST (original)
+++ trunk/orca/packages/Storable-2.11/MANIFEST Wed Mar 17 20:39:57 2004
@@ -16,6 +16,7 @@
t/freeze.t See if Storable works
t/integer.t For "use integer" testing
t/interwork56.t Test combatibility kludge for 64bit data under 5.6.x
+t/just_plain_nasty.t Corner case corner.
t/lock.t See if Storable works
t/make_56_interwork.pl Make test data for interwork56.t
t/make_downgrade.pl Make test data for downgrade.t
@@ -29,6 +30,7 @@
t/tied.t See if Storable works
t/tied_hook.t See if Storable works
t/tied_items.t See if Storable works
+t/threads.t See if Storable works under ithreads
t/utf8.t See if Storable works
t/utf8hash.t See if Storable works
t/Test/Builder.pm For testing the CPAN release on pre 5.6.2
Modified: trunk/orca/packages/Storable-2.11/Storable.pm
==============================================================================
--- trunk/orca/packages/Storable-2.09/Storable.pm (original)
+++ trunk/orca/packages/Storable-2.11/Storable.pm Wed Mar 17 20:39:57 2004
@@ -21,7 +21,7 @@
use AutoLoader;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.09';
+$VERSION = '2.11';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
@@ -47,6 +47,11 @@
}
}
+sub CLONE {
+ # clone context under threads
+ Storable::init_perinterp();
+}
+
# Can't Autoload cleanly as this clashes 8.3 with &retrieve
sub retrieve_fd { &fd_retrieve } # Backward compatibility
@@ -786,10 +791,10 @@
%color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1);
- store(\%color, '/tmp/colors') or die "Can't store %a in /tmp/colors!\n";
+ store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n";
- $colref = retrieve('/tmp/colors');
- die "Unable to retrieve from /tmp/colors!\n" unless defined $colref;
+ $colref = retrieve('mycolors');
+ die "Unable to retrieve from mycolors!\n" unless defined $colref;
printf "Blue is still %lf\n", $colref->{'Blue'};
$colref2 = dclone(\%color);
Modified: trunk/orca/packages/Storable-2.11/Storable.xs
==============================================================================
--- trunk/orca/packages/Storable-2.09/Storable.xs (original)
+++ trunk/orca/packages/Storable-2.11/Storable.xs Wed Mar 17 20:39:57 2004
@@ -288,6 +288,7 @@
HV *hseen; /* which objects have been seen, store time */
AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
AV *aseen; /* which objects have been seen, retrieve time */
+ IV where_is_undef; /* index in aseen of PL_sv_undef */
HV *hclass; /* which classnames have been seen, store time */
AV *aclass; /* which classnames have been seen, retrieve time */
HV *hook; /* cache for hook methods per class name */
@@ -791,6 +792,13 @@
* Useful store shortcuts...
*/
+/*
+ * Note that if you put more than one mark for storing a particular
+ * type of thing, *and* in the retrieve_foo() function you mark both
+ * the thingy's you get off with SEEN(), you *must* increase the
+ * tagnum with cxt->tagnum++ along with this macro!
+ * - samv 20Jan04
+ */
#define PUTMARK(x) \
STMT_START { \
if (!cxt->fio) \
@@ -937,12 +945,14 @@
* To achieve that, the class name of the last retrieved object is passed down
* recursively, and the first SEEN() call for which the class name is not NULL
* will bless the object.
+ *
+ * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
*/
-#define SEEN(y,c) \
+#define SEEN(y,c,i) \
STMT_START { \
if (!y) \
return (SV *) 0; \
- if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
+ if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \
return (SV *) 0; \
TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
PTR2UV(y), SvREFCNT(y)-1)); \
@@ -1330,6 +1340,7 @@
? newHV() : 0);
cxt->aseen = newAV(); /* Where retrieved objects are kept */
+ cxt->where_is_undef = -1; /* Special case for PL_sv_undef */
cxt->aclass = newAV(); /* Where seen classnames are kept */
cxt->tagnum = 0; /* Have to count objects... */
cxt->classnum = 0; /* ...and class names as well */
@@ -1362,6 +1373,7 @@
av_undef(aseen);
sv_free((SV *) aseen);
}
+ cxt->where_is_undef = -1;
if (cxt->aclass) {
AV *aclass = cxt->aclass;
@@ -2179,15 +2191,44 @@
qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
for (i = 0; i < len; i++) {
- unsigned char flags;
+#ifdef HAS_RESTRICTED_HASHES
+ int placeholders = HvPLACEHOLDERS(hv);
+#endif
+ unsigned char flags = 0;
char *keyval;
STRLEN keylen_tmp;
I32 keylen;
SV *key = av_shift(av);
+ /* This will fail if key is a placeholder.
+ Track how many placeholders we have, and error if we
+ "see" too many. */
HE *he = hv_fetch_ent(hv, key, 0, 0);
- SV *val = HeVAL(he);
- if (val == 0)
- return 1; /* Internal error, not I/O error */
+ SV *val;
+
+ if (he) {
+ if (!(val = HeVAL(he))) {
+ /* Internal error, not I/O error */
+ return 1;
+ }
+ } else {
+#ifdef HAS_RESTRICTED_HASHES
+ /* Should be a placeholder. */
+ if (placeholders-- < 0) {
+ /* This should not happen - number of
+ retrieves should be identical to
+ number of placeholders. */
+ return 1;
+ }
+ /* Value is never needed, and PL_sv_undef is
+ more space efficient to store. */
+ val = &PL_sv_undef;
+ ASSERT (flags == 0,
+ ("Flags not 0 but %d", flags));
+ flags = SHV_K_PLACEHOLDER;
+#else
+ return 1;
+#endif
+ }
/*
* Store value first.
@@ -2208,12 +2249,9 @@
/* Implementation of restricted hashes isn't nicely
abstracted: */
- flags
- = (((hash_flags & SHV_RESTRICTED)
- && SvREADONLY(val))
- ? SHV_K_LOCKED : 0);
- if (val == &PL_sv_placeholder)
- flags |= SHV_K_PLACEHOLDER;
+ if ((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) {
+ flags |= SHV_K_LOCKED;
+ }
keyval = SvPV(key, keylen_tmp);
keylen = keylen_tmp;
@@ -2299,6 +2337,18 @@
if (val == 0)
return 1; /* Internal error, not I/O error */
+ /* Implementation of restricted hashes isn't nicely
+ abstracted: */
+ flags
+ = (((hash_flags & SHV_RESTRICTED)
+ && SvREADONLY(val))
+ ? SHV_K_LOCKED : 0);
+
+ if (val == &PL_sv_placeholder) {
+ flags |= SHV_K_PLACEHOLDER;
+ val = &PL_sv_undef;
+ }
+
/*
* Store value first.
*/
@@ -2308,14 +2358,6 @@
if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
goto out;
- /* Implementation of restricted hashes isn't nicely
- abstracted: */
- flags
- = (((hash_flags & SHV_RESTRICTED)
- && SvREADONLY(val))
- ? SHV_K_LOCKED : 0);
- if (val == &PL_sv_placeholder)
- flags |= SHV_K_PLACEHOLDER;
hek = HeKEY_hek(he);
len = HEK_LEN(hek);
@@ -2463,6 +2505,7 @@
*/
PUTMARK(SX_CODE);
+ cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
TRACEME(("size = %d", len));
TRACEME(("code = %s", SvPV_nolen(text)));
@@ -3259,7 +3302,39 @@
svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
if (svh) {
- I32 tagval = htonl(LOW_32BITS(*svh));
+ I32 tagval;
+
+ if (sv == &PL_sv_undef) {
+ /* We have seen PL_sv_undef before, but fake it as
+ if we have not.
+
+ Not the simplest solution to making restricted
+ hashes work on 5.8.0, but it does mean that
+ repeated references to the one true undef will
+ take up less space in the output file.
+ */
+ /* Need to jump past the next hv_store, because on the
+ second store of undef the old hash value will be
+ SV_REFCNT_DEC()ed, and as Storable cheats horribly
+ by storing non-SVs in the hash a SEGV will ensure.
+ Need to increase the tag number so that the
+ receiver has no idea what games we're up to. This
+ special casing doesn't affect hooks that store
+ undef, as the hook routine does its own lookup into
+ hseen. Also this means that any references back
+ to PL_sv_undef (from the pathological case of hooks
+ storing references to it) will find the seen hash
+ entry for the first time, as if we didn't have this
+ hackery here. (That hseen lookup works even on 5.8.0
+ because it's a key of &PL_sv_undef and a value
+ which is a tag number, not a value which is
+ PL_sv_undef.) */
+ cxt->tagnum++;
+ type = svis_SCALAR;
+ goto undef_special_case;
+ }
+
+ tagval = htonl(LOW_32BITS(*svh));
TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval)));
@@ -3291,6 +3366,7 @@
type = sv_type(sv);
+undef_special_case:
TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
PTR2UV(sv), cxt->tagnum, type));
@@ -3816,7 +3892,7 @@
default:
return retrieve_other(cxt, 0); /* Let it croak */
}
- SEEN(sv, 0); /* Don't bless yet */
+ SEEN(sv, 0, 0); /* Don't bless yet */
/*
* Whilst flags tell us to recurse, do so.
@@ -3957,9 +4033,17 @@
READ_I32(tag);
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
- if (!svh)
- CROAK(("Object #%"IVdf" should have been retrieved already",
- (IV) tag));
+ if (!svh) {
+ if (tag == cxt->where_is_undef) {
+ /* av_fetch uses PL_sv_undef internally, hence this
+ somewhat gruesome hack. */
+ xsv = &PL_sv_undef;
+ svh = &xsv;
+ } else {
+ CROAK(("Object #%"IVdf" should have been retrieved already",
+ (IV) tag));
+ }
+ }
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
@@ -4129,7 +4213,7 @@
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname); /* Will return if rv is null */
+ SEEN(rv, cname, 0); /* Will return if rv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
@@ -4186,7 +4270,7 @@
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname); /* Will return if rv is null */
+ SEEN(rv, cname, 0); /* Will return if rv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
@@ -4202,10 +4286,11 @@
/*
* Restore overloading magic.
*/
-
- stash = (HV *) SvSTASH (sv);
- if (!stash || !Gv_AMG(stash))
- CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)",
+ if (!SvTYPE(sv)
+ || !(stash = (HV *) SvSTASH (sv))
+ || !Gv_AMG(stash))
+ CROAK(("Cannot restore overloading on %s(0x%"UVxf
+ ") (package %s)",
sv_reftype(sv, FALSE),
PTR2UV(sv),
stash ? HvNAME(stash) : "<unknown>"));
@@ -4231,7 +4316,7 @@
TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
@@ -4260,7 +4345,7 @@
TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
@@ -4288,7 +4373,7 @@
TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if rv is null */
+ SEEN(tv, cname, 0); /* Will return if rv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv) {
return (SV *) 0; /* Failed */
@@ -4325,7 +4410,7 @@
TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
@@ -4357,7 +4442,7 @@
TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
@@ -4394,7 +4479,7 @@
*/
sv = NEWSV(10002, len);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
/*
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
@@ -4440,7 +4525,7 @@
*/
sv = NEWSV(10002, len);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
/*
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
@@ -4552,7 +4637,7 @@
READ(&iv, sizeof(iv));
sv = newSViv(iv);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("integer %"IVdf, iv));
TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv)));
@@ -4581,7 +4666,7 @@
sv = newSViv(iv);
TRACEME(("network integer (as-is) %d", iv));
#endif
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv)));
@@ -4603,7 +4688,7 @@
READ(&nv, sizeof(nv));
sv = newSVnv(nv);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("double %"NVff, nv));
TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv)));
@@ -4629,7 +4714,7 @@
TRACEME(("small integer read as %d", (unsigned char) siv));
tmp = (unsigned char) siv - 128;
sv = newSViv(tmp);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("byte %d", tmp));
TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv)));
@@ -4649,7 +4734,7 @@
TRACEME(("retrieve_undef"));
sv = newSV(0);
- SEEN(sv, cname);
+ SEEN(sv, cname, 0);
return sv;
}
@@ -4665,7 +4750,13 @@
TRACEME(("retrieve_sv_undef"));
- SEEN(sv, cname);
+ /* Special case PL_sv_undef, as av_fetch uses it internally to mark
+ deleted elements, and will return NULL (fetch failed) whenever it
+ is fetched. */
+ if (cxt->where_is_undef == -1) {
+ cxt->where_is_undef = cxt->tagnum;
+ }
+ SEEN(sv, cname, 1);
return sv;
}
@@ -4680,7 +4771,7 @@
TRACEME(("retrieve_sv_yes"));
- SEEN(sv, cname);
+ SEEN(sv, cname, 1);
return sv;
}
@@ -4695,7 +4786,7 @@
TRACEME(("retrieve_sv_no"));
- SEEN(sv, cname);
+ SEEN(sv, cname, 1);
return sv;
}
@@ -4724,7 +4815,7 @@
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av, cname); /* Will return if array not allocated nicely */
+ SEEN(av, cname, 0); /* Will return if array not allocated nicely */
if (len)
av_extend(av, len);
else
@@ -4776,7 +4867,7 @@
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv, cname); /* Will return if table not allocated properly */
+ SEEN(hv, cname, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */
@@ -4862,7 +4953,7 @@
RLEN(len);
TRACEME(("size = %d, flags = %d", len, hash_flags));
hv = newHV();
- SEEN(hv, cname); /* Will return if table not allocated properly */
+ SEEN(hv, cname, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */
@@ -4975,13 +5066,24 @@
CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
#else
dSP;
- int type, count;
+ int type, count, tagnum;
SV *cv;
SV *sv, *text, *sub;
TRACEME(("retrieve_code (#%d)", cxt->tagnum));
/*
+ * Insert dummy SV in the aseen array so that we don't screw
+ * up the tag numbers. We would just make the internal
+ * scalar an untagged item in the stream, but
+ * retrieve_scalar() calls SEEN(). So we just increase the
+ * tag number.
+ */
+ tagnum = cxt->tagnum;
+ sv = newSViv(0);
+ SEEN(sv, cname, 0);
+
+ /*
* Retrieve the source of the code reference
* as a small or large scalar
*/
@@ -5023,6 +5125,8 @@
CROAK(("Can't eval, please set $Storable::Eval to a true value"));
} else {
sv = newSVsv(sub);
+ /* fix up the dummy entry... */
+ av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
return sv;
}
}
@@ -5060,8 +5164,9 @@
FREETMPS;
LEAVE;
+ /* fix up the dummy entry... */
+ av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
- SEEN(sv, cname);
return sv;
#endif
}
@@ -5093,7 +5198,7 @@
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av, 0); /* Will return if array not allocated nicely */
+ SEEN(av, 0, 0); /* Will return if array not allocated nicely */
if (len)
av_extend(av, len);
else
@@ -5155,7 +5260,7 @@
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv, 0); /* Will return if table not allocated properly */
+ SEEN(hv, 0, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */
@@ -5901,6 +6006,9 @@
gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
#endif
+void
+init_perinterp()
+
int
pstore(f,obj)
OutputStream f
Modified: trunk/orca/packages/Storable-2.11/hints/linux.pl
==============================================================================
--- trunk/orca/packages/Storable-2.09/hints/linux.pl (original)
+++ trunk/orca/packages/Storable-2.11/hints/linux.pl Wed Mar 17 20:39:57 2004
@@ -6,5 +6,10 @@
# 20011002 and 3.3, and in Redhat 7.1 with gcc 3.3.1. The failures
# happen only for unthreaded builds, threaded builds work okay.
use Config;
-$self->{OPTIMIZE} = '-O2';
+if ($Config{gccversion}) {
+ my $optimize = $Config{optimize};
+ if ($optimize =~ s/(^| )-O[3-9]( |$)/$1-O2$2/) {
+ $self->{OPTIMIZE} = $optimize;
+ }
+}
Modified: trunk/orca/packages/Storable-2.11/t/blessed.t
==============================================================================
--- trunk/orca/packages/Storable-2.09/t/blessed.t (original)
+++ trunk/orca/packages/Storable-2.11/t/blessed.t Wed Mar 17 20:39:57 2004
@@ -25,7 +25,15 @@
use Storable qw(freeze thaw);
-print "1..12\n";
+%::immortals
+ = (u => \undef,
+ 'y' => \(1 == 1),
+ n => \(1 == 0)
+);
+
+my $test = 12;
+my $tests = $test + 2 * 6 * keys %::immortals;
+print "1..$tests\n";
package SHORT_NAME;
@@ -106,3 +114,47 @@
ok 11, ref $y eq 'Foobar';
ok 12, $$$y->[0] == 1;
}
+
+package RETURNS_IMMORTALS;
+
+sub make { my $self = shift; bless [@_], $self }
+
+sub STORABLE_freeze {
+ # Some reference some number of times.
+ my $self = shift;
+ my ($what, $times) = @$self;
+ return ("$what$times", ($::immortals{$what}) x $times);
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, @refs) = @_;
+ my ($what, $times) = $x =~ /(.)(\d+)/;
+ die "'$x' didn't match" unless defined $times;
+ main::ok ++$test, @refs == $times;
+ my $expect = $::immortals{$what};
+ die "'$x' did not give a reference" unless ref $expect;
+ my $fail;
+ foreach (@refs) {
+ $fail++ if $_ != $expect;
+ }
+ main::ok ++$test, !$fail;
+}
+
+package main;
+
+# $Storable::DEBUGME = 1;
+my $count;
+foreach $count (1..3) {
+ my $immortal;
+ foreach $immortal (keys %::immortals) {
+ print "# $immortal x $count\n";
+ my $i = RETURNS_IMMORTALS->make ($immortal, $count);
+
+ my $f = freeze ($i);
+ ok ++$test, $f;
+ my $t = thaw $f;
+ ok ++$test, 1;
+ }
+}
Modified: trunk/orca/packages/Storable-2.11/t/code.t
==============================================================================
--- trunk/orca/packages/Storable-2.09/t/code.t (original)
+++ trunk/orca/packages/Storable-2.11/t/code.t Wed Mar 17 20:39:57 2004
@@ -38,7 +38,7 @@
}
}
-BEGIN { plan tests => 49 }
+BEGIN { plan tests => 59 }
use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
use Safe;
@@ -118,7 +118,7 @@
######################################################################
eval { $freezed = freeze $obj[4] };
-ok($@ =~ /The result of B::Deparse::coderef2text was empty/);
+ok($@, qr/The result of B::Deparse::coderef2text was empty/);
######################################################################
# Test dclone
@@ -162,7 +162,7 @@
$freezed = freeze $obj[$i];
$@ = "";
eval { $thawed = thaw $freezed };
- ok($@ =~ /Can\'t eval/);
+ ok($@, qr/Can\'t eval/);
}
}
@@ -172,7 +172,7 @@
for my $i (0 .. 1) {
$@ = "";
eval { $freezed = freeze $obj[$i] };
- ok($@ =~ /Can\'t store CODE items/);
+ ok($@, qr/Can\'t store CODE items/);
}
}
@@ -184,7 +184,7 @@
$@ = "";
eval { $thawed = thaw $freezed };
ok($@, "");
- ok($$thawed =~ /^sub/);
+ ok($$thawed, qr/^sub/);
}
}
@@ -218,7 +218,8 @@
$freezed = freeze $obj[0]->[6];
eval { $thawed = thaw $freezed };
- ok($@ =~ /trapped/);
+ # The "Code sub ..." error message only appears if Log::Agent is installed
+ ok($@, qr/(trapped|Code sub)/);
if (0) {
# Disable or fix this test if the internal representation of Storable
@@ -234,7 +235,7 @@
substr($freezed, -1, 0, $bad_code);
$@ = "";
eval { $thawed = thaw $freezed };
- ok($@ =~ /trapped/);
+ ok($@, qr/(trapped|Code sub)/);
}
}
@@ -282,3 +283,30 @@
}
}
+{
+ # Check internal "seen" code
+ my $short_sub = sub { "short sub" }; # for SX_SCALAR
+ # for SX_LSCALAR
+ my $long_sub_code = 'sub { "' . "x"x255 . '" }';
+ my $long_sub = eval $long_sub_code; die $@ if $@;
+ my $sclr = \1;
+
+ local $Storable::Deparse = 1;
+ local $Storable::Eval = 1;
+
+ for my $sub ($short_sub, $long_sub) {
+ my $res;
+
+ $res = thaw freeze [$sub, $sub];
+ ok(int($res->[0]), int($res->[1]));
+
+ $res = thaw freeze [$sclr, $sub, $sub, $sclr];
+ ok(int($res->[0]), int($res->[3]));
+ ok(int($res->[1]), int($res->[2]));
+
+ $res = thaw freeze [$sub, $sub, $sclr, $sclr];
+ ok(int($res->[0]), int($res->[1]));
+ ok(int($res->[2]), int($res->[3]));
+ }
+
+}
Added: trunk/orca/packages/Storable-2.11/t/just_plain_nasty.t
==============================================================================
--- (empty file)
+++ trunk/orca/packages/Storable-2.11/t/just_plain_nasty.t Wed Mar 17 20:39:57 2004
@@ -0,0 +1,152 @@
+#!/usr/bin/perl
+
+# This is a test suite to cover all the nasty and horrible data
+# structures that cause bizarre corner cases.
+
+# Everyone's invited! :-D
+
+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 strict;
+BEGIN {
+ if (!eval q{
+ use Test;
+ use B::Deparse 0.61;
+ use 5.006;
+ 1;
+ }) {
+ print "1..0 # skip: tests only work with B::Deparse 0.61 and at least pe
+rl 5.6.0\n";
+ exit;
+ }
+ require File::Spec;
+ if ($File::Spec::VERSION < 0.8) {
+ print "1..0 # Skip: newer File::Spec needed\n";
+ exit 0;
+ }
+}
+
+use Storable qw(freeze thaw);
+
+#$Storable::DEBUGME = 1;
+BEGIN {
+ plan tests => 34;
+}
+
+{
+ package Banana;
+ use overload
+ '<=>' => \&compare,
+ '==' => \&equal,
+ '""' => \&real,
+ fallback => 1;
+ sub compare { return int(rand(3))-1 };
+ sub equal { return 1 if rand(1) > 0.5 }
+ sub real { return "keep it so" }
+}
+
+my (@a);
+
+for my $dbun (1, 0) { # dbun - don't be utterly nasty - being utterly
+ # nasty means having a reference to the object
+ # directly within itself. otherwise it's in the
+ # second array.
+ my $nasty = [
+ ($a[0] = bless [ ], "Banana"),
+ ($a[1] = [ ]),
+ ];
+
+ $a[$dbun]->[0] = $a[0];
+
+ ok(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)");
+
+ $Storable::Deparse = $Storable::Deparse = 1;
+ $Storable::Eval = $Storable::Eval = 1;
+
+ headit("circular overload 1 - freeze");
+ my $icicle = freeze $nasty;
+ #print $icicle; # cat -ve recommended :)
+ headit("circular overload 1 - thaw");
+ my $oh_dear = thaw $icicle;
+ ok(ref($oh_dear), "ARRAY", "dclone - circular overload");
+ ok($oh_dear->[0], "keep it so", "amagic ok 1");
+ ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
+
+ headit("closure dclone - freeze");
+ $icicle = freeze sub { "two" };
+ #print $icicle;
+ headit("closure dclone - thaw");
+ my $sub2 = thaw $icicle;
+ ok($sub2->(), "two", "closures getting dcloned OK");
+
+ headit("circular overload, after closure - freeze");
+ #use Data::Dumper;
+ #print Dumper $nasty;
+ $icicle = freeze $nasty;
+ #print $icicle;
+ headit("circular overload, after closure - thaw");
+ $oh_dear = thaw $icicle;
+ ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
+ ok($oh_dear->[0], "keep it so", "amagic ok 1");
+ ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
+
+ push @{$nasty}, sub { print "Goodbye, cruel world.\n" };
+ headit("closure freeze AFTER circular overload");
+ #print Dumper $nasty;
+ $icicle = freeze $nasty;
+ #print $icicle;
+ headit("circular thaw AFTER circular overload");
+ $oh_dear = thaw $icicle;
+ ok(ref($oh_dear), "ARRAY", "dclone - before a closure dclone");
+ ok($oh_dear->[0], "keep it so", "amagic ok 1");
+ ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
+
+ @{$nasty} = @{$nasty}[0, 2, 1];
+ headit("closure freeze BETWEEN circular overload");
+ #print Dumper $nasty;
+ $icicle = freeze $nasty;
+ #print $icicle;
+ headit("circular thaw BETWEEN circular overload");
+ $oh_dear = thaw $icicle;
+ ok(ref($oh_dear), "ARRAY", "dclone - between a closure dclone");
+ ok($oh_dear->[0], "keep it so", "amagic ok 1");
+ ok($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2");
+
+ @{$nasty} = @{$nasty}[1, 0, 2];
+ headit("closure freeze BEFORE circular overload");
+ #print Dumper $nasty;
+ $icicle = freeze $nasty;
+ #print $icicle;
+ headit("circular thaw BEFORE circular overload");
+ $oh_dear = thaw $icicle;
+ ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
+ ok($oh_dear->[1], "keep it so", "amagic ok 1");
+ ok($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2");
+}
+
+sub headit {
+
+ return; # comment out to get headings - useful for scanning
+ # output with $Storable::DEBUGME = 1
+
+ my $title = shift;
+
+ my $size_left = (66 - length($title)) >> 1;
+ my $size_right = (67 - length($title)) >> 1;
+
+ print "# ".("-" x $size_left). " $title "
+ .("-" x $size_right)."\n";
+}
+
Modified: trunk/orca/packages/Storable-2.11/t/restrict.t
==============================================================================
--- trunk/orca/packages/Storable-2.09/t/restrict.t (original)
+++ trunk/orca/packages/Storable-2.11/t/restrict.t Wed Mar 17 20:39:57 2004
@@ -35,10 +35,10 @@
}
-use Storable qw(dclone);
+use Storable qw(dclone freeze thaw);
use Hash::Util qw(lock_hash unlock_value);
-print "1..16\n";
+print "1..100\n";
my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
lock_hash %hash;
@@ -56,9 +56,15 @@
package main;
+sub freeze_thaw {
+ my $temp = freeze $_[0];
+ return thaw $temp;
+}
+
sub testit {
my $hash = shift;
- my $copy = dclone $hash;
+ my $cloner = shift;
+ my $copy = &$cloner($hash);
my @in_keys = sort keys %$hash;
my @out_keys = sort keys %$copy;
@@ -96,8 +102,29 @@
}
for $Storable::canonical (0, 1) {
- print "# \$Storable::canonical = $Storable::canonical\n";
- testit (\%hash);
- my $object = \%hash;
- # bless {}, "Restrict_Test";
+ for my $cloner (\&dclone, \&freeze_thaw) {
+ print "# \$Storable::canonical = $Storable::canonical\n";
+ testit (\%hash, $cloner);
+ my $object = \%hash;
+ # bless {}, "Restrict_Test";
+
+ my %hash2;
+ $hash2{"k$_"} = "v$_" for 0..16;
+ lock_hash %hash2;
+ for (0..16) {
+ unlock_value %hash2, "k$_";
+ delete $hash2{"k$_"};
+ }
+ my $copy = &$cloner(\%hash2);
+
+ for (0..16) {
+ my $k = "k$_";
+ eval { $copy->{$k} = undef } ;
+ unless (ok ++$test, !$@, "Can assign to reserved key '$k'?") {
+ my $diag = $@;
+ $diag =~ s/\n.*\z//s;
+ print "# \$\@: $diag\n";
+ }
+ }
+ }
}
Added: trunk/orca/packages/Storable-2.11/t/threads.t
==============================================================================
--- (empty file)
+++ trunk/orca/packages/Storable-2.11/t/threads.t Wed Mar 17 20:39:57 2004
@@ -0,0 +1,62 @@
+
+# as of 2.09 on win32 Storable w/threads dies with "free to wrong
+# pool" since it uses the same context for different threads. since
+# win32 perl implementation allocates a different memory pool for each
+# thread using the a memory pool from one thread to allocate memory
+# for another thread makes win32 perl very unhappy
+#
+# but the problem exists everywhere, not only on win32 perl , it's
+# just hard to catch it deterministically - since the same context is
+# used if two or more threads happen to change the state of the
+# context in the middle of the operation, and those operations aren't
+# atomic per thread, bad things including data loss and corrupted data
+# can happen.
+#
+# this has been solved in 2.10 by adding a Storable::CLONE which calls
+# Storable::init_perinterp() to create a new context for each new
+# thread when it starts
+
+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;
+ }
+ unless ($Config{'useithreads'} and eval { require threads; 1 }) {
+ print "1..0 # Skip: no threads\n";
+ exit 0;
+ }
+ # - is \W, so can't use \b at start. Negative look ahead and look behind
+ # works at start/end of string, or where preceded/followed by spaces
+ if ($] == 5.008002 and $Config{'ccflags'} =~ /(?<!\S)-DDEBUGGING(?!\S)/) {
+ # Bug caused by change 21610, fixed by change 21849
+ print "1..0 # Skip: tickles bug in threads combined with -DDEBUGGING on 5.8.2\n";
+ exit 0;
+ }
+}
+
+use Test::More;
+
+use strict;
+
+use threads;
+use Storable qw(nfreeze);
+
+plan tests => 2;
+
+threads->new(\&sub1);
+
+$_->join() for threads->list();
+
+ok 1;
+
+sub sub1 {
+ nfreeze {};
+ ok 1;
+}
More information about the Orca-checkins
mailing list