*/
/*
- * $Id: Storable.xs,v 1.0 2000/09/01 19:40:41 ram Exp $
+ * $Id: Storable.xs,v 1.0.1.4 2000/10/26 17:11:04 ram Exp ram $
*
* Copyright (c) 1995-2000, Raphael Manfredi
*
* in the README file that comes with the distribution.
*
* $Log: Storable.xs,v $
+ * Revision 1.0.1.4 2000/10/26 17:11:04 ram
+ * patch5: auto requires module of blessed ref when STORABLE_thaw misses
+ *
+ * Revision 1.0.1.3 2000/09/29 19:49:57 ram
+ * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp
+ *
+ * $Log: Storable.xs,v $
* Revision 1.0 2000/09/01 19:40:41 ram
* Baseline for first official release.
*
#define PL_sv_yes sv_yes
#define PL_sv_no sv_no
#define PL_sv_undef sv_undef
+#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */
+#define newSVpvn newSVpv
#endif
+#endif /* PATCHLEVEL <= 4 */
#ifndef HvSHAREKEYS_off
#define HvSHAREKEYS_off(hv) /* Ignore */
#endif
#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */
#define SX_OBJECT C(0) /* Already stored object */
-#define SX_LSCALAR C(1) /* Scalar (string) forthcoming (length, data) */
+#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
#define SX_ARRAY C(2) /* Array forthcominng (size, item list) */
#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
#define SX_REF C(4) /* Reference to object forthcoming */
#define SX_DOUBLE C(7) /* Double forthcoming */
#define SX_BYTE C(8) /* (signed) byte forthcoming */
#define SX_NETINT C(9) /* Integer in network order forthcoming */
-#define SX_SCALAR C(10) /* Scalar (small) forthcoming (length, data) */
+#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */
#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */
#define SX_TIED_HASH C(12) /* Tied hash forthcoming */
#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */
#define SX_OVERLOAD C(20) /* Overloaded reference */
#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */
#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
-#define SX_ERROR C(23) /* Error */
+#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
+#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
+#define SX_ERROR C(25) /* Error */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
#define MY_VERSION "Storable(" XS_VERSION ")"
+/*
+ * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
+ * files remap tainted and dirty when threading is enabled. That's bad for
+ * perl to remap such common words. -- RAM, 29/09/00
+ */
+
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
I32 tagnum; /* incremented at store time for each seen object */
I32 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 dirty; /* context is dirty due to CROAK() -- can be cleaned */
+ 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 */
PerlIO *fio; /* where I/O are performed, NULL for memory */
* but the topmost context stacked.
*/
-#define CROAK(x) do { cxt->dirty = 1; croak x; } while (0)
+#define CROAK(x) do { cxt->s_dirty = 1; croak x; } while (0)
/*
* End of "thread-safe" related definitions.
static char magicstr[] = "pst0"; /* Used as a magic number */
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 2 /* Binary minor "version" */
+#define STORABLE_BIN_MINOR 3 /* Binary minor "version" */
/*
* Useful store shortcuts...
return -1; \
} while (0)
-#define STORE_SCALAR(pv, len) do { \
+#define STORE_PV_LEN(pv, len, small, large) do { \
if (len <= LG_SCALAR) { \
unsigned char clen = (unsigned char) len; \
- PUTMARK(SX_SCALAR); \
+ PUTMARK(small); \
PUTMARK(clen); \
if (len) \
WRITE(pv, len); \
} else { \
- PUTMARK(SX_LSCALAR); \
+ PUTMARK(large); \
WLEN(len); \
WRITE(pv, len); \
} \
} while (0)
+#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
+
+/*
+ * Conditional UTF8 support.
+ * On non-UTF8 perls, UTF8 strings are returned as normal strings.
+ *
+ */
+#ifdef SvUTF8_on
+#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
+#else
+#define SvUTF8(sv) 0
+#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
+#define SvUTF8_on(sv) CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
+#endif
+
/*
* Store undef in arrays and hashes without recursing through store().
*/
*/
static SV *retrieve_lscalar(stcxt_t *cxt);
+static SV *retrieve_lutf8str(stcxt_t *cxt);
static SV *old_retrieve_array(stcxt_t *cxt);
static SV *old_retrieve_hash(stcxt_t *cxt);
static SV *retrieve_ref(stcxt_t *cxt);
static SV *retrieve_byte(stcxt_t *cxt);
static SV *retrieve_netint(stcxt_t *cxt);
static SV *retrieve_scalar(stcxt_t *cxt);
+static SV *retrieve_utf8str(stcxt_t *cxt);
static SV *retrieve_tied_array(stcxt_t *cxt);
static SV *retrieve_tied_hash(stcxt_t *cxt);
static SV *retrieve_tied_scalar(stcxt_t *cxt);
retrieve_other, /* SX_OVERLOADED not supported */
retrieve_other, /* SX_TIED_KEY not supported */
retrieve_other, /* SX_TIED_IDX not supported */
+ retrieve_other, /* SX_UTF8STR not supported */
+ retrieve_other, /* SX_LUTF8STR not supported */
retrieve_other, /* SX_ERROR */
};
retrieve_overloaded, /* SX_OVERLOAD */
retrieve_tied_key, /* SX_TIED_KEY */
retrieve_tied_idx, /* SX_TIED_IDX */
+ retrieve_utf8str, /* SX_UTF8STR */
+ retrieve_lutf8str, /* SX_LUTF8STR */
retrieve_other, /* SX_ERROR */
};
sv_free((SV *) cxt->hook);
cxt->entry = 0;
- cxt->dirty = 0;
+ cxt->s_dirty = 0;
}
/*
*
* Initialize a new retrieve context for real recursion.
*/
-static void init_retrieve_context(cxt, optype)
-stcxt_t *cxt;
-int optype;
+static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
{
TRACEME(("init_retrieve_context"));
cxt->tagnum = 0; /* Have to count objects... */
cxt->classnum = 0; /* ...and class names as well */
cxt->optype = optype;
+ cxt->s_tainted = is_tainted;
cxt->entry = 1; /* No recursion yet */
}
*
* Clean retrieve context by
*/
-static void clean_retrieve_context(cxt)
-stcxt_t *cxt;
+static void clean_retrieve_context(stcxt_t *cxt)
{
TRACEME(("clean_retrieve_context"));
sv_free((SV *) cxt->hseen); /* optional HV, for backward compat. */
cxt->entry = 0;
- cxt->dirty = 0;
+ cxt->s_dirty = 0;
}
/*
{
TRACEME(("clean_context"));
- ASSERT(cxt->dirty, ("dirty context"));
+ ASSERT(cxt->s_dirty, ("dirty context"));
if (cxt->optype & ST_RETRIEVE)
clean_retrieve_context(cxt);
TRACEME(("allocate_context"));
- ASSERT(!parent_cxt->dirty, ("parent context clean"));
+ ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
Newz(0, cxt, 1, stcxt_t);
cxt->prev = parent_cxt;
TRACEME(("free_context"));
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(prev, ("not freeing root context"));
if (kbuf)
}
/*
+ * pkg_uncache
+ *
+ * Discard cached value: a whole fetch loop will be retried at next lookup.
+ */
+static void pkg_uncache(
+ HV *cache,
+ HV *pkg,
+ char *method)
+{
+ (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD);
+}
+
+/*
* pkg_can
*
* Our own "UNIVERSAL::can", which caches results.
string:
wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
- STORE_SCALAR(pv, wlen);
+ 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));
pv = SvPV(ary[0], len2);
/*
- * Allocate a class ID if not already done.
- */
-
- if (!known_class(cxt, class, len, &classnum)) {
- TRACEME(("first time we see class %s, ID = %d", class, classnum));
- classnum = -1; /* Mark: we must store classname */
- } else {
- TRACEME(("already seen class %s, ID = %d", class, classnum));
- }
-
- /*
* If they returned more than one item, we need to serialize some
* extra references if not already done.
*
}
/*
+ * Allocate a class ID if not already done.
+ *
+ * This needs to be done after the recursion above, since at retrieval
+ * time, we'll see the inner objects first. Many thanks to
+ * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
+ * proposed the right fix. -- RAM, 15/09/2000
+ */
+
+ if (!known_class(cxt, class, len, &classnum)) {
+ TRACEME(("first time we see class %s, ID = %d", class, classnum));
+ classnum = -1; /* Mark: we must store classname */
+ } else {
+ TRACEME(("already seen class %s, ID = %d", class, classnum));
+ }
+
+ /*
* Compute leading flags.
*/
* free up memory for them now.
*/
- if (cxt->dirty)
+ if (cxt->s_dirty)
clean_context(cxt);
/*
cxt->entry++;
ASSERT(cxt->entry == 1, ("starting new recursion"));
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
/*
* Ensure sv is actually a reference. From perl, we called something
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
- CROAK(("Class name #%d should have been seen already", idx));
+ CROAK(("Class name #%d should have been seen already", (int)idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
- CROAK(("Class name #%d should have been seen already", idx));
+ CROAK(("Class name #%d should have been seen already", (int)idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
TRACEME(("class ID %d => %s", idx, class));
*SvEND(frozen) = '\0';
}
(void) SvPOK_only(frozen); /* Validates string pointer */
- SvTAINT(frozen);
+ if (cxt->s_tainted) /* Is input source tainted? */
+ SvTAINT(frozen);
TRACEME(("frozen string: %d bytes", len2));
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
- CROAK(("Object #%d should have been retrieved already", tag));
+ CROAK(("Object #%d should have been retrieved already", (int)tag));
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
BLESS(sv, class);
hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
- if (!hook)
- CROAK(("No STORABLE_thaw defined for objects of class %s", class));
+ if (!hook) {
+ /*
+ * Hook not found. Maybe they did not require the module where this
+ * hook is defined yet?
+ *
+ * If the require below succeeds, we'll be able to find the hook.
+ * Still, it only works reliably when each class is defined in a
+ * file of its own.
+ */
+
+ SV *psv = newSVpvn("require ", 8);
+ sv_catpv(psv, class);
+
+ TRACEME(("No STORABLE_thaw defined for objects of class %s", class));
+ TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv)));
+
+ perl_eval_sv(psv, G_DISCARD);
+ sv_free(psv);
+
+ /*
+ * We cache results of pkg_can, so we need to uncache before attempting
+ * the lookup again.
+ */
+
+ pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+
+ if (!hook)
+ CROAK(("No STORABLE_thaw defined for objects of class %s "
+ "(even after a \"require %s;\")", class, class));
+ }
/*
* If we don't have an `av' yet, prepare one.
SvCUR_set(sv, len); /* Record C string length */
*SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */
(void) SvPOK_only(sv); /* Validate string pointer */
- SvTAINT(sv); /* External data cannot be trusted */
+ if (cxt->s_tainted) /* Is input source tainted? */
+ SvTAINT(sv); /* External data cannot be trusted */
TRACEME(("large scalar len %"IVdf" '%s'", len, SvPVX(sv)));
TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv)));
}
(void) SvPOK_only(sv); /* Validate string pointer */
- SvTAINT(sv); /* External data cannot be trusted */
+ if (cxt->s_tainted) /* Is input source tainted? */
+ SvTAINT(sv); /* External data cannot be trusted */
TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv)));
return sv;
}
/*
+ * retrieve_utf8str
+ *
+ * Like retrieve_scalar(), but tag result as utf8.
+ * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
+ */
+static SV *retrieve_utf8str(stcxt_t *cxt)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_utf8str"));
+
+ sv = retrieve_scalar(cxt);
+ if (sv)
+ SvUTF8_on(sv);
+
+ return sv;
+}
+
+/*
+ * retrieve_lutf8str
+ *
+ * Like retrieve_lscalar(), but tag result as utf8.
+ * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
+ */
+static SV *retrieve_lutf8str(stcxt_t *cxt)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_lutf8str"));
+
+ sv = retrieve_lscalar(cxt);
+ if (sv)
+ SvUTF8_on(sv);
+
+ return sv;
+}
+
+/*
* retrieve_integer
*
* Retrieve defined integer.
I32 tagn;
svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
if (!svh)
- CROAK(("Old tag 0x%x should have been mapped already", tag));
+ CROAK(("Old tag 0x%x should have been mapped already", (unsigned)tag));
tagn = SvIV(*svh); /* Mapped tag number computed earlier below */
/*
svh = av_fetch(cxt->aseen, tagn, FALSE);
if (!svh)
- CROAK(("Object #%d should have been retrieved already", tagn));
+ CROAK(("Object #%d should have been retrieved already", (int)tagn));
sv = *svh;
TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
- CROAK(("Object #%d should have been retrieved already", tag));
+ CROAK(("Object #%d should have been retrieved already", (int)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 */
TRACEME(("do_retrieve (optype = 0x%x)", optype));
* free up memory for them now.
*/
- if (cxt->dirty)
+ if (cxt->s_dirty)
clean_context(cxt);
/*
cxt->entry++;
ASSERT(cxt->entry == 1, ("starting new recursion"));
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
/*
* Prepare context.
TRACEME(("data stored in %s format",
cxt->netorder ? "net order" : "native"));
- init_retrieve_context(cxt, optype);
+ /*
+ * Check whether input source is tainted, so that we don't wrongly
+ * taint perfectly good values...
+ *
+ * We assume file input is always tainted. If both `f' and `in' are
+ * NULL, then we come from dclone, and tainted is already filled in
+ * the context. That's a kludge, but the whole dclone() thing is
+ * already quite a kludge anyway! -- RAM, 15/09/2000.
+ */
+
+ is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted);
+ TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
+ init_retrieve_context(cxt, optype, is_tainted);
ASSERT(is_retrieving(), ("within retrieve operation"));
* free up memory for them now.
*/
- if (cxt->dirty)
+ if (cxt->s_dirty)
clean_context(cxt);
/*
* Now, `cxt' may refer to a new context.
*/
- ASSERT(!cxt->dirty, ("clean context"));
+ ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
size = MBUF_SIZE();
TRACEME(("dclone stored %d bytes", size));
-
MBUF_INIT(size);
- out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE); /* Will free non-root context */
+
+ /*
+ * Since we're passing do_retrieve() both a NULL file and sv, we need
+ * to pre-compute the taintedness of the input by setting cxt->tainted
+ * to whatever state our own input string was. -- RAM, 15/09/2000
+ *
+ * do_retrieve() will free non-root context.
+ */
+
+ cxt->s_tainted = SvTAINTED(sv);
+ out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE);
TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out)));
projects / p5sagit/p5-mst-13.2.git / blobdiff