*/
/*
- * $Id: Storable.xs,v 1.0.1.8 2001/03/15 00:20:55 ram Exp $
+ * $Id: Storable.xs,v 1.0.1.9 2001/07/01 11:25:02 ram Exp $
*
* Copyright (c) 1995-2000, Raphael Manfredi
*
* in the README file that comes with the distribution.
*
* $Log: Storable.xs,v $
+ * Revision 1.0.1.9 2001/07/01 11:25:02 ram
+ * patch12: fixed memory corruption on croaks during thaw()
+ * patch12: made code compile cleanly with -Wall (Jarkko Hietaniemi)
+ * patch12: changed tagnum and classnum from I32 to IV in context
+ *
* Revision 1.0.1.8 2001/03/15 00:20:55 ram
* patch11: last version was wrongly compiling with assertions on
*
#include <EXTERN.h>
#include <perl.h>
+#include <patchlevel.h> /* Perl's one, needed since 5.6 */
#include <XSUB.h>
#if 0
*/
#ifndef PERL_VERSION /* For perls < 5.6 */
-#include <patchlevel.h>
-#define PERL_REVISION 5
-#define PERL_VERSION PATCHLEVEL
-#define PERL_SUBVERSION SUBVERSION
+#define PERL_VERSION PATCHLEVEL
#ifndef newRV_noinc
#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
#endif
-#if (PERL_VERSION <= 4) /* Older perls (<= 5.004) lack PL_ namespace */
+#if (PATCHLEVEL <= 4) /* Older perls (<= 5.004) lack PL_ namespace */
#define PL_sv_yes sv_yes
#define PL_sv_no sv_no
#define PL_sv_undef sv_undef
-#if (PERL_SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */
+#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */
#define newSVpvn newSVpv
#endif
-#endif /* PERL_VERSION <= 4 */
+#endif /* PATCHLEVEL <= 4 */
#ifndef HvSHAREKEYS_off
#define HvSHAREKEYS_off(hv) /* Ignore */
#endif
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
- 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 */
- 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 */
- IV tagnum; /* incremented at store time for each seen object */
- IV classnum; /* incremented at store time for each seen classname */
- int netorder; /* true if network order used */
- int s_tainted; /* true if input source is tainted, at retrieve time */
- int forgive_me; /* whether to be forgiving... */
- int canonical; /* whether to store hashes sorted by key */
+ 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 */
+ 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 */
+ IV tagnum; /* incremented at store time for each seen object */
+ IV classnum; /* incremented at store time for each seen classname */
+ int netorder; /* true if network order used */
+ int s_tainted; /* true if input source is tainted, at retrieve time */
+ int forgive_me; /* whether to be forgiving... */
+ int canonical; /* whether to store hashes sorted by key */
int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
- struct extendable keybuf; /* for hash key retrieval */
- struct extendable membuf; /* for memory store/retrieve operations */
+ int membuf_ro; /* true means membuf is read-only and msaved is rw */
+ struct extendable keybuf; /* for hash key retrieval */
+ struct extendable membuf; /* for memory store/retrieve operations */
+ struct extendable msaved; /* where potentially valid mbuf is saved */
PerlIO *fio; /* where I/O are performed, NULL for memory */
int ver_major; /* major of version for retrieved object */
int ver_minor; /* minor of version for retrieved object */
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
-#if (PERL_VERSION <= 4) && (PERL_SUBVERSION < 68)
+#if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
#define dSTCXT_SV \
SV *perinterp_sv = perl_get_sv(MY_VERSION, FALSE)
#else /* >= perl5.004_68 */
} while (0)
#define KBUFCHK(x) do { \
if (x >= ksiz) { \
- TRACEME(("** extending kbuf to %d bytes", x+1)); \
+ TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \
Renew(kbuf, x+1, char); \
ksiz = x+1; \
} \
#define MBUF_SIZE() (mptr - mbase)
/*
+ * MBUF_SAVE_AND_LOAD
+ * MBUF_RESTORE
+ *
+ * Those macros are used in do_retrieve() to save the current memory
+ * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
+ * data from a string.
+ */
+#define MBUF_SAVE_AND_LOAD(in) do { \
+ ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
+ cxt->membuf_ro = 1; \
+ TRACEME(("saving mbuf")); \
+ StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
+ MBUF_LOAD(in); \
+} while (0)
+
+#define MBUF_RESTORE() do { \
+ ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
+ cxt->membuf_ro = 0; \
+ TRACEME(("restoring mbuf")); \
+ StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
+} while (0)
+
+/*
* Use SvPOKp(), because SvPOK() fails on tainted scalars.
* See store_scalar() for other usage of this workaround.
*/
#define MBUF_LOAD(v) do { \
+ ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
if (!SvPOKp(v)) \
CROAK(("Not a scalar string")); \
mptr = mbase = SvPV(v, msiz); \
#define MBUF_XTEND(x) do { \
int nsz = (int) round_mgrow((x)+msiz); \
int offset = mptr - mbase; \
- TRACEME(("** extending mbase to %d bytes", nsz)); \
+ ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
+ TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \
+ msiz, nsz, (x))); \
Renew(mbase, nsz, char); \
msiz = nsz; \
mptr = mbase + offset; \
}
/*
+ * reset_context
+ *
+ * Called at the end of every context cleaning, to perform common reset
+ * operations.
+ */
+static void reset_context(stcxt_t *cxt)
+{
+ cxt->entry = 0;
+ cxt->s_dirty = 0;
+ cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */
+}
+
+/*
* init_store_context
*
* Initialize a new store context for real recursion.
* Insert real values into hashes where we stored faked pointers.
*/
- hv_iterinit(cxt->hseen);
- while ((he = hv_iternext(cxt->hseen)))
- HeVAL(he) = &PL_sv_undef;
+ if (cxt->hseen) {
+ hv_iterinit(cxt->hseen);
+ while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */
+ HeVAL(he) = &PL_sv_undef;
+ }
- hv_iterinit(cxt->hclass);
- while ((he = hv_iternext(cxt->hclass)))
- HeVAL(he) = &PL_sv_undef;
+ if (cxt->hclass) {
+ hv_iterinit(cxt->hclass);
+ while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */
+ HeVAL(he) = &PL_sv_undef;
+ }
/*
* And now dispose of them...
sv_free((SV *) hook_seen);
}
- cxt->entry = 0;
- cxt->s_dirty = 0;
+ reset_context(cxt);
}
/*
sv_free((SV *) hseen); /* optional HV, for backward compat. */
}
- cxt->entry = 0;
- cxt->s_dirty = 0;
+ reset_context(cxt);
}
/*
*
* A workaround for the CROAK bug: cleanup the last context.
*/
-static void clean_context(cxt)
-stcxt_t *cxt;
+static void clean_context(stcxt_t *cxt)
{
TRACEME(("clean_context"));
ASSERT(cxt->s_dirty, ("dirty context"));
+ if (cxt->membuf_ro)
+ MBUF_RESTORE();
+
+ ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
+
if (cxt->optype & ST_RETRIEVE)
clean_retrieve_context(cxt);
- else
+ else if (cxt->optype & ST_STORE)
clean_store_context(cxt);
+ else
+ reset_context(cxt);
ASSERT(!cxt->s_dirty, ("context is clean"));
+ ASSERT(cxt->entry == 0, ("context is reset"));
}
/*
cxt->prev = parent_cxt;
SET_STCXT(cxt);
+ TRACEME(("kbuf has %d bytes at 0x%x", ksiz, kbuf));
+ TRACEME(("mbuf has %d bytes at 0x%x", msiz, mbase));
+
+ ASSERT(!cxt->s_dirty, ("clean context"));
+
return cxt;
}
Safefree(cxt);
SET_STCXT(prev);
+
+ ASSERT(cxt, ("context not void"));
}
/***
continue;
}
TRACEME(("(#%d) item", i));
- if ((ret = store(cxt, *sav)))
+ if ((ret = store(cxt, *sav))) /* Extra () for -Wall, grr... */
return ret;
}
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if ((ret = store(cxt, val)))
+ if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
goto out;
/*
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if ((ret = store(cxt, val)))
+ if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
goto out;
/*
* accesses on the retrieved object will indeed call the magic methods...
*/
- if ((ret = store(cxt, mg->mg_obj)))
+ if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
TRACEME(("ok (tied)"));
PUTMARK(SX_TIED_KEY);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if ((ret = store(cxt, mg->mg_obj)))
+ if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
- if ((ret = store(cxt, (SV *) mg->mg_ptr)))
+ if ((ret = store(cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
return ret;
} else {
I32 idx = mg->mg_len;
PUTMARK(SX_TIED_IDX);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if ((ret = store(cxt, mg->mg_obj)))
+ if ((ret = store(cxt, mg->mg_obj))) /* Idem, for -Wall */
return ret;
TRACEME(("store_tied_item: storing IDX %d", idx));
I32 classnum;
int ret;
int clone = cxt->optype & ST_CLONE;
- char mtype = 0; /* for blessed ref to tied structures */
- unsigned char eflags = 0; /* used when object type is SHT_EXTRA */
+ char mtype = '\0'; /* for blessed ref to tied structures */
+ unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
} else
PUTMARK(flags);
- if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
+ if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
return ret;
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
* [<magic object>]
*/
- if ((ret = store(cxt, mg->mg_obj)))
+ if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
}
*/
(void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
- PTR2UV(sv), (char)0);
+ PTR2UV(sv), (char) 0);
len = strlen(buf);
STORE_SCALAR(buf, len);
*/
SV *mstore(SV *sv)
{
- dSTCXT;
SV *out;
TRACEME(("mstore"));
*/
SV *net_mstore(SV *sv)
{
- dSTCXT;
SV *out;
TRACEME(("net_mstore"));
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
- CROAK(("Class name #%"IVdf" should have been seen already",
- (IV)idx));
+ CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
- CROAK(("Class name #%"IVdf" should have been seen already",
- (IV)idx));
+ CROAK(("Class name #%"IVdf" should have been seen already",
+ (IV) idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
TRACEME(("class ID %d => %s", idx, class));
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
- CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tag));
+ CROAK(("Object #%"IVdf" should have been retrieved already",
+ (IV) tag));
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
{
SV *sv;
int siv;
- signed char tmp; /* must use temp var to work around
- an AIX compiler bug --H.Merijn Brand */
+ signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */
TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
GETMARK(siv);
TRACEME(("small integer read as %d", (unsigned char) siv));
- tmp = ((unsigned char)siv) - 128;
- sv = newSViv (tmp);
-
+ tmp = (unsigned char) siv - 128;
+ sv = newSViv(tmp);
SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
TRACEME(("byte %d", tmp));
I32 size;
I32 i;
HV *hv;
- SV *sv=NULL;
+ SV *sv = (SV *) 0;
int c;
static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
* information to check.
*/
- if ((cxt->netorder = (use_network_order & 0x1)))
+ if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
return &PL_sv_undef; /* No byte ordering info */
sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
I32 tagn;
svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
if (!svh)
- CROAK(("Old tag 0x%"UVxf" should have been mapped already", (UV)tag));
+ CROAK(("Old tag 0x%"UVxf" should have been mapped already",
+ (UV) tag));
tagn = SvIV(*svh); /* Mapped tag number computed earlier below */
/*
svh = av_fetch(cxt->aseen, tagn, FALSE);
if (!svh)
- CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tagn));
+ CROAK(("Object #%"IVdf" should have been retrieved already",
+ (IV) tagn));
sv = *svh;
TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
* Regular post-0.6 binary format.
*/
-again:
GETMARK(type);
TRACEME(("retrieve type = %d", type));
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
- CROAK(("Object #%"IVdf" should have been retrieved already",
- (IV)tag));
+ CROAK(("Object #%"IVdf" should have been retrieved already",
+ (IV) tag));
sv = *svh;
TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
dSTCXT;
SV *sv;
int is_tainted; /* Is input source tainted? */
- struct extendable msave; /* Where potentially valid mbuf is saved */
+ int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */
TRACEME(("do_retrieve (optype = 0x%x)", optype));
KBUFINIT(); /* Allocate hash key reading pool once */
- if (!f && in) {
- StructCopy(&cxt->membuf, &msave, struct extendable);
- MBUF_LOAD(in);
- }
-
+ if (!f && in)
+ MBUF_SAVE_AND_LOAD(in);
/*
* Magic number verifications.
*/
if (!f && in)
- StructCopy(&msave, &cxt->membuf, struct extendable);
+ MBUF_RESTORE();
+
+ pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */
/*
* The "root" context is never freed.
*
* Build a reference to the SV returned by pretrieve even if it is
* already one and not a scalar, for consistency reasons.
- *
- * NB: although context might have been cleaned, the value of `cxt->hseen'
- * remains intact, and can be used as a flag.
*/
- if (cxt->hseen) { /* Was not handling overloading by then */
+ if (pre_06_fmt) { /* Was not handling overloading by then */
SV *rv;
- if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv))
+ TRACEME(("fixing for old formats -- pre 0.6"));
+ if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
+ TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
return sv;
+ }
}
/*
*/
if (SvOBJECT(sv)) {
- HV *stash = (HV *) SvSTASH (sv);
+ HV *stash = (HV *) SvSTASH(sv);
SV *rv = newRV_noinc(sv);
if (stash && Gv_AMG(stash)) {
SvAMAGIC_on(rv);
TRACEME(("restored overloading on root reference"));
}
+ TRACEME(("ended do_retrieve() with an object"));
return rv;
}
+ TRACEME(("regular do_retrieve() end"));
+
return newRV_noinc(sv);
}
projects / p5sagit/p5-mst-13.2.git / commitdiff