/*
- * Store and retrieve mechanism.
- */
-
-/*
- * $Id: Storable.xs,v 1.0.1.10 2001/08/28 21:52:14 ram Exp $
+ * Store and retrieve mechanism.
*
* Copyright (c) 1995-2000, Raphael Manfredi
*
* You may redistribute only under the same terms as Perl 5, as specified
* in the README file that comes with the distribution.
*
- * $Log: Storable.xs,v $
- * Revision 1.0.1.10 2001/08/28 21:52:14 ram
- * patch13: removed spurious debugging messages
- *
- * 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
- *
- * Revision 1.0.1.7 2001/02/17 12:25:26 ram
- * patch8: now bless objects ASAP at retrieve time
- * patch8: added support for blessed ref to tied structures
- *
- * Revision 1.0.1.6 2001/01/03 09:40:40 ram
- * patch7: prototype and casting cleanup
- * patch7: trace offending package when overloading cannot be restored
- * patch7: made context cleanup safer to avoid dup freeing
- *
- * Revision 1.0.1.5 2000/11/05 17:21:24 ram
- * patch6: fixed severe "object lost" bug for STORABLE_freeze returns
- *
- * 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
- *
- * Revision 1.0.1.2 2000/09/28 21:43:10 ram
- * patch2: perls before 5.004_04 lack newSVpvn
- *
- * Revision 1.0.1.1 2000/09/17 16:47:49 ram
- * patch1: now only taint retrieved data when source was tainted
- * patch1: added support for UTF-8 strings
- * patch1: fixed store hook bug: was allocating class id too soon
- *
- * Revision 1.0 2000/09/01 19:40:41 ram
- * Baseline for first official release.
- *
*/
#include <EXTERN.h>
#include <perl.h>
-#include <patchlevel.h> /* Perl's one, needed since 5.6 */
#include <XSUB.h>
+#ifndef PATCHLEVEL
+# include <patchlevel.h> /* Perl's one, needed since 5.6 */
+# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+#endif
+
#ifndef NETWARE
#if 0
#define DEBUGME /* Debug mode, turns assertions on as well */
#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
-#define SX_ERROR C(26) /* Error */
+#define SX_CODE C(26) /* Code references as perl source code */
+#define SX_ERROR C(27) /* Error */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
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 deparse; /* whether to deparse code refs */
+ SV *eval; /* whether to eval source code */
int canonical; /* whether to store hashes sorted by key */
#ifndef HAS_RESTRICTED_HASHES
int derestrict; /* whether to downgrade restrcted hashes */
#define dSTCXT_PTR(T,name) \
T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \
- ? (T)SvPVX(SvRV((SV*)SvIVX(perinterp_sv))) : (T) 0))
+ ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
#define dSTCXT \
dSTCXT_SV; \
dSTCXT_PTR(stcxt_t *, cxt)
#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
-static stcxt_t Context;
-static stcxt_t *Context_ptr = &Context;
+static stcxt_t *Context_ptr = NULL;
#define dSTCXT stcxt_t *cxt = Context_ptr
+#define SET_STCXT(x) Context_ptr = x
#define INIT_STCXT \
dSTCXT; \
- NEW_STORABLE_CXT_OBJ(cxt)
+ NEW_STORABLE_CXT_OBJ(cxt); \
+ SET_STCXT(cxt)
-#define SET_STCXT(x) Context_ptr = x
#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
if (!mbase) { \
TRACEME(("** allocating mbase of %d bytes", MGROW)); \
New(10003, mbase, MGROW, char); \
- msiz = MGROW; \
+ msiz = (STRLEN)MGROW; \
} \
mptr = mbase; \
if (x) \
#define svis_HASH 3
#define svis_TIED 4
#define svis_TIED_ITEM 5
-#define svis_OTHER 6
+#define svis_CODE 6
+#define svis_OTHER 7
/*
* Flags for SX_HOOK.
* a "minor" version, to better track this kind of evolution from now on.
*
*/
-static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
-static char magicstr[] = "pst0"; /* Used as a magic number */
+static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
+static const char magicstr[] = "pst0"; /* Used as a magic number */
+
+#define MAGICSTR_BYTES 'p','s','t','0'
+#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e'
+
+/* 5.6.x introduced the ability to have IVs as long long.
+ However, Configure still defined BYTEORDER based on the size of a long.
+ Storable uses the BYTEORDER value as part of the header, but doesn't
+ explicity store sizeof(IV) anywhere in the header. Hence on 5.6.x built
+ with IV as long long on a platform that uses Configure (ie most things
+ except VMS and Windows) headers are identical for the different IV sizes,
+ despite the files containing some fields based on sizeof(IV)
+ Erk. Broken-ness.
+ 5.8 is consistent - the following redifinition kludge is only needed on
+ 5.6.x, but the interwork is needed on 5.8 while data survives in files
+ with the 5.6 header.
+
+*/
+
+#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4)
+#ifndef NO_56_INTERWORK_KLUDGE
+#define USE_56_INTERWORK_KLUDGE
+#endif
+#if BYTEORDER == 0x1234
+#undef BYTEORDER
+#define BYTEORDER 0x12345678
+#else
+#if BYTEORDER == 0x4321
+#undef BYTEORDER
+#define BYTEORDER 0x87654321
+#endif
+#endif
+#endif
+
+#if BYTEORDER == 0x1234
+#define BYTEORDER_BYTES '1','2','3','4'
+#else
+#if BYTEORDER == 0x12345678
+#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8'
+#ifdef USE_56_INTERWORK_KLUDGE
+#define BYTEORDER_BYTES_56 '1','2','3','4'
+#endif
+#else
+#if BYTEORDER == 0x87654321
+#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1'
+#ifdef USE_56_INTERWORK_KLUDGE
+#define BYTEORDER_BYTES_56 '4','3','2','1'
+#endif
+#else
+#if BYTEORDER == 0x4321
+#define BYTEORDER_BYTES '4','3','2','1'
+#else
+#error Unknown byteoder. Please append your byteorder to Storable.xs
+#endif
+#endif
+#endif
+#endif
+static const char byteorderstr[] = {BYTEORDER_BYTES, 0};
+#ifdef USE_56_INTERWORK_KLUDGE
+static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
+#endif
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */
+#define STORABLE_BIN_MINOR 6 /* Binary minor "version" */
/* If we aren't 5.7.3 or later, we won't be writing out files that use the
* new flagged hash introdued in 2.5, so put 2.4 in the binary header to
* As of perl 5.7.3, utf8 hash key is introduced.
* So this must change -- dankogai
*/
-#define STORABLE_BIN_WRITE_MINOR 5
+#define STORABLE_BIN_WRITE_MINOR 6
#endif /* (PATCHLEVEL <= 6) */
+#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
+#define PL_sv_placeholder PL_sv_undef
+#endif
+
/*
* 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) \
#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
/*
- * Store undef in arrays and hashes without recursing through store().
+ * Store &PL_sv_undef in arrays without recursing through store().
*/
-#define STORE_UNDEF() \
+#define STORE_SV_UNDEF() \
STMT_START { \
cxt->tagnum++; \
- PUTMARK(SX_UNDEF); \
+ PUTMARK(SX_SV_UNDEF); \
} STMT_END
/*
static int store_hash(stcxt_t *cxt, HV *hv);
static int store_tied(stcxt_t *cxt, SV *sv);
static int store_tied_item(stcxt_t *cxt, SV *sv);
+static int store_code(stcxt_t *cxt, CV *cv);
static int store_other(stcxt_t *cxt, SV *sv);
static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
(int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */
store_tied, /* svis_TIED */
store_tied_item, /* svis_TIED_ITEM */
+ (int (*)(stcxt_t *cxt, SV *sv)) store_code, /* svis_CODE */
store_other, /* svis_OTHER */
};
retrieve_other, /* SX_UTF8STR not supported */
retrieve_other, /* SX_LUTF8STR not supported */
retrieve_other, /* SX_FLAG_HASH not supported */
+ retrieve_other, /* SX_CODE not supported */
retrieve_other, /* SX_ERROR */
};
static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname);
+static SV *retrieve_code(stcxt_t *cxt, char *cname);
static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
0, /* SX_OBJECT -- entry unused dynamically */
retrieve_utf8str, /* SX_UTF8STR */
retrieve_lutf8str, /* SX_LUTF8STR */
retrieve_flag_hash, /* SX_HASH */
+ retrieve_code, /* SX_CODE */
retrieve_other, /* SX_ERROR */
};
cxt->netorder = network_order;
cxt->forgive_me = -1; /* Fetched from perl if needed */
+ cxt->deparse = -1; /* Idem */
+ cxt->eval = NULL; /* Idem */
cxt->canonical = -1; /* Idem */
cxt->tagnum = -1; /* Reset tag numbers */
cxt->classnum = -1; /* Reset class numbers */
}
cxt->forgive_me = -1; /* Fetched from perl if needed */
+ cxt->deparse = -1; /* Idem */
+ if (cxt->eval) {
+ SvREFCNT_dec(cxt->eval);
+ }
+ cxt->eval = NULL; /* Idem */
cxt->canonical = -1; /* Idem */
reset_context(cxt);
* new retrieve routines.
*/
- cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0);
+ cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve)
+ ? newHV() : 0);
cxt->aseen = newAV(); /* Where retrieved objects are kept */
cxt->aclass = newAV(); /* Where seen classnames are kept */
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_notUV(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 */
}
/*
sav = av_fetch(av, i, 0);
if (!sav) {
TRACEME(("(#%d) undef item", i));
- STORE_UNDEF();
+ STORE_SV_UNDEF();
continue;
}
TRACEME(("(#%d) item", i));
= (((hash_flags & SHV_RESTRICTED)
&& SvREADONLY(val))
? SHV_K_LOCKED : 0);
- if (val == &PL_sv_undef)
+ if (val == &PL_sv_placeholder)
flags |= SHV_K_PLACEHOLDER;
keyval = SvPV(key, keylen_tmp);
PUTMARK(flags);
TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
} else {
- assert (flags == 0);
+ /* This is a workaround for a bug in 5.8.0
+ that causes the HEK_WASUTF8 flag to be
+ set on an HEK without the hash being
+ marked as having key flags. We just
+ cross our fingers and drop the flag.
+ AMS 20030901 */
+ assert (flags == 0 || flags == SHV_K_WASUTF8);
TRACEME(("(#%d) key '%s'", i, keyval));
}
WLEN(keylen);
/*
* Storing in "random" order (in the order the keys are stored
- * within the the hash). This is the default and will be faster!
+ * within the hash). This is the default and will be faster!
*/
for (i = 0; i < len; i++) {
= (((hash_flags & SHV_RESTRICTED)
&& SvREADONLY(val))
? SHV_K_LOCKED : 0);
- if (val == &PL_sv_undef)
+ if (val == &PL_sv_placeholder)
flags |= SHV_K_PLACEHOLDER;
hek = HeKEY_hek(he);
PUTMARK(flags);
TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
} else {
- assert (flags == 0);
+ /* This is a workaround for a bug in 5.8.0
+ that causes the HEK_WASUTF8 flag to be
+ set on an HEK without the hash being
+ marked as having key flags. We just
+ cross our fingers and drop the flag.
+ AMS 20030901 */
+ assert (flags == 0 || flags == SHV_K_WASUTF8);
TRACEME(("(#%d) key '%s'", i, key));
}
if (flags & SHV_K_ISSV) {
}
/*
+ * store_code
+ *
+ * Store a code reference.
+ *
+ * Layout is SX_CODE <length> followed by a scalar containing the perl
+ * source code of the code reference.
+ */
+static int store_code(stcxt_t *cxt, CV *cv)
+{
+#if PERL_VERSION < 6
+ /*
+ * retrieve_code does not work with perl 5.005 or less
+ */
+ return store_other(cxt, (SV*)cv);
+#else
+ dSP;
+ I32 len;
+ int count, reallen;
+ SV *text, *bdeparse;
+
+ TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv)));
+
+ if (
+ cxt->deparse == 0 ||
+ (cxt->deparse < 0 && !(cxt->deparse =
+ SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0))
+ ) {
+ return store_other(cxt, (SV*)cv);
+ }
+
+ /*
+ * Require B::Deparse. At least B::Deparse 0.61 is needed for
+ * blessed code references.
+ */
+ /* XXX sv_2mortal seems to be evil here. why? */
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
+
+ ENTER;
+ SAVETMPS;
+
+ /*
+ * create the B::Deparse object
+ */
+
+ PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newSVpvn("B::Deparse",10)));
+ PUTBACK;
+ count = call_method("new", G_SCALAR);
+ SPAGAIN;
+ if (count != 1)
+ CROAK(("Unexpected return value from B::Deparse::new\n"));
+ bdeparse = POPs;
+
+ /*
+ * call the coderef2text method
+ */
+
+ PUSHMARK(sp);
+ XPUSHs(bdeparse); /* XXX is this already mortal? */
+ XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
+ PUTBACK;
+ count = call_method("coderef2text", G_SCALAR);
+ SPAGAIN;
+ if (count != 1)
+ CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
+
+ text = POPs;
+ len = SvLEN(text);
+ reallen = strlen(SvPV_nolen(text));
+
+ /*
+ * Empty code references or XS functions are deparsed as
+ * "(prototype) ;" or ";".
+ */
+
+ if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') {
+ CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
+ }
+
+ /*
+ * Signal code by emitting SX_CODE.
+ */
+
+ PUTMARK(SX_CODE);
+ cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
+ TRACEME(("size = %d", len));
+ TRACEME(("code = %s", SvPV_nolen(text)));
+
+ /*
+ * Now store the source code.
+ */
+
+ STORE_SCALAR(SvPV_nolen(text), len);
+
+ FREETMPS;
+ LEAVE;
+
+ TRACEME(("ok (code)"));
+
+ return 0;
+#endif
+}
+
+/*
* store_tied
*
* When storing a tied object (be it a tied scalar, array or hash), we lay out
static int store_tied(stcxt_t *cxt, SV *sv)
{
MAGIC *mg;
+ SV *obj = NULL;
int ret = 0;
int svt = SvTYPE(sv);
char mtype = 'P';
* accesses on the retrieved object will indeed call the magic methods...
*/
- if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
+ /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
+ obj = mg->mg_obj ? mg->mg_obj : newSV(0);
+ if ((ret = store(cxt, obj)))
return ret;
TRACEME(("ok (tied)"));
* If they returned more than one item, we need to serialize some
* extra references if not already done.
*
- * Loop over the array, starting at postion #1, and for each item,
+ * Loop over the array, starting at position #1, and for each item,
* ensure it is a reference, serialize it if not already done, and
* replace the entry with the tag ID of the corresponding serialized
* object.
len = strlen(buf);
STORE_SCALAR(buf, len);
- TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, len));
+ TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len));
return 0;
}
if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
return svis_TIED;
return svis_HASH;
+ case SVt_PVCV:
+ return svis_CODE;
default:
break;
}
*
* NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
* real pointer, rather a tag number (watch the insertion code below).
- * That means it pobably safe to assume it is well under the 32-bit limit,
+ * That means it probably safe to assume it is well under the 32-bit limit,
* and makes the truncation safe.
* -- RAM, 14/09/1999
*/
*/
static int magic_write(stcxt_t *cxt)
{
- char buf[256]; /* Enough room for 256 hexa digits */
- unsigned char c;
- int use_network_order = cxt->netorder;
-
- TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio)
- : -1));
-
- if (cxt->fio)
- WRITE(magicstr, (SSize_t)strlen(magicstr)); /* Don't write final \0 */
-
- /*
- * Starting with 0.6, the "use_network_order" byte flag is also used to
- * indicate the version number of the binary image, encoded in the upper
- * bits. The bit 0 is always used to indicate network order.
- */
-
- c = (unsigned char)
- ((use_network_order ? 0x1 : 0x0) | (STORABLE_BIN_MAJOR << 1));
- PUTMARK(c);
-
- /*
- * Starting with 0.7, a full byte is dedicated to the minor version of
- * the binary format, which is incremented only when new markers are
- * introduced, for instance, but when backward compatibility is preserved.
- */
+ /*
+ * Starting with 0.6, the "use_network_order" byte flag is also used to
+ * indicate the version number of the binary image, encoded in the upper
+ * bits. The bit 0 is always used to indicate network order.
+ */
+ /*
+ * Starting with 0.7, a full byte is dedicated to the minor version of
+ * the binary format, which is incremented only when new markers are
+ * introduced, for instance, but when backward compatibility is preserved.
+ */
- PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR);
+ /* Make these at compile time. The WRITE() macro is sufficiently complex
+ that it saves about 200 bytes doing it this way and only using it
+ once. */
+ static const unsigned char network_file_header[] = {
+ MAGICSTR_BYTES,
+ (STORABLE_BIN_MAJOR << 1) | 1,
+ STORABLE_BIN_WRITE_MINOR
+ };
+ static const unsigned char file_header[] = {
+ MAGICSTR_BYTES,
+ (STORABLE_BIN_MAJOR << 1) | 0,
+ STORABLE_BIN_WRITE_MINOR,
+ /* sizeof the array includes the 0 byte at the end: */
+ (char) sizeof (byteorderstr) - 1,
+ BYTEORDER_BYTES,
+ (unsigned char) sizeof(int),
+ (unsigned char) sizeof(long),
+ (unsigned char) sizeof(char *),
+ (unsigned char) sizeof(NV)
+ };
+#ifdef USE_56_INTERWORK_KLUDGE
+ static const unsigned char file_header_56[] = {
+ MAGICSTR_BYTES,
+ (STORABLE_BIN_MAJOR << 1) | 0,
+ STORABLE_BIN_WRITE_MINOR,
+ /* sizeof the array includes the 0 byte at the end: */
+ (char) sizeof (byteorderstr_56) - 1,
+ BYTEORDER_BYTES_56,
+ (unsigned char) sizeof(int),
+ (unsigned char) sizeof(long),
+ (unsigned char) sizeof(char *),
+ (unsigned char) sizeof(NV)
+ };
+#endif
+ const unsigned char *header;
+ SSize_t length;
+
+ TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1));
+
+ if (cxt->netorder) {
+ header = network_file_header;
+ length = sizeof (network_file_header);
+ } else {
+#ifdef USE_56_INTERWORK_KLUDGE
+ if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) {
+ header = file_header_56;
+ length = sizeof (file_header_56);
+ } else
+#endif
+ {
+ header = file_header;
+ length = sizeof (file_header);
+ }
+ }
- if (use_network_order)
- return 0; /* Don't bother with byte ordering */
+ if (!cxt->fio) {
+ /* sizeof the array includes the 0 byte at the end. */
+ header += sizeof (magicstr) - 1;
+ length -= sizeof (magicstr) - 1;
+ }
- sprintf(buf, "%lx", (unsigned long) BYTEORDER);
- c = (unsigned char) strlen(buf);
- PUTMARK(c);
- WRITE(buf, (SSize_t)c); /* Don't write final \0 */
- PUTMARK((unsigned char) sizeof(int));
- PUTMARK((unsigned char) sizeof(long));
- PUTMARK((unsigned char) sizeof(char *));
- PUTMARK((unsigned char) sizeof(NV));
+ WRITE( (unsigned char*) header, length);
+ if (!cxt->netorder) {
TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
- (unsigned long) BYTEORDER, (int) c,
+ (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1,
(int) sizeof(int), (int) sizeof(long),
(int) sizeof(char *), (int) sizeof(NV)));
-
- return 0;
+ }
+ return 0;
}
/*
* We don't need to remember the addresses returned by retrieval, because
* all the references will be obtained through indirection via the object
* tags in the object-ID list.
+ *
+ * We need to decrement the reference count for these objects
+ * because, if the user doesn't save a reference to them in the hook,
+ * they must be freed when this context is cleaned.
*/
while (flags & SHF_NEED_RECURSE) {
rv = retrieve(cxt, 0);
if (!rv)
return (SV *) 0;
+ SvREFCNT_dec(rv);
TRACEME(("retrieve_hook back with rv=0x%"UVxf,
PTR2UV(rv)));
GETMARK(flags);
*/
TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)",
- class, PTR2UV(sv), AvFILLp(av) + 1));
+ class, PTR2UV(sv), (IV) AvFILLp(av) + 1));
rv = newRV(sv);
(void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
* an SX_OBJECT indication, a ref count increment was done.
*/
- sv_upgrade(rv, SVt_RV);
+ if (cname) {
+ /* Do not use sv_upgrade to preserve STASH */
+ SvFLAGS(rv) &= ~SVTYPEMASK;
+ SvFLAGS(rv) |= SVt_RV;
+ } else {
+ sv_upgrade(rv, SVt_RV);
+ }
+
SvRV(rv) = sv; /* $rv = \$sv */
SvROK_on(rv);
/*
* 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>"));
static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
{
SV *tv;
- SV *sv;
+ SV *sv, *obj = NULL;
TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
SEEN(tv, cname); /* Will return if rv is null */
sv = retrieve(cxt, 0); /* Retrieve <object> */
- if (!sv)
+ if (!sv) {
return (SV *) 0; /* Failed */
+ }
+ else if (SvTYPE(sv) != SVt_NULL) {
+ obj = sv;
+ }
sv_upgrade(tv, SVt_PVMG);
- sv_magic(tv, sv, 'q', Nullch, 0);
- SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
+ sv_magic(tv, obj, 'q', Nullch, 0);
+
+ if (obj) {
+ /* Undo refcnt inc from sv_magic() */
+ SvREFCNT_dec(obj);
+ }
TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv)));
SV *sv;
RLEN(len);
- TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, len));
+ TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len));
/*
* Allocate an empty scalar of the suitable length.
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(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv)));
TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv)));
return sv;
TRACEME(("retrieve_sv_no"));
+ cxt->tagnum--; /* undo the tagnum increment in retrieve_l?scalar */
SEEN(sv, cname);
return sv;
}
if (flags & SHV_K_PLACEHOLDER) {
SvREFCNT_dec (sv);
- sv = &PL_sv_undef;
+ sv = &PL_sv_placeholder;
store_flags |= HVhek_PLACEHOLD;
}
if (flags & SHV_K_UTF8) {
*/
#ifdef HAS_RESTRICTED_HASHES
- if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0)
+ if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0)
return (SV *) 0;
#else
if (!(store_flags & HVhek_PLACEHOLD))
}
/*
+ * retrieve_code
+ *
+ * Return a code reference.
+ */
+static SV *retrieve_code(stcxt_t *cxt, char *cname)
+{
+#if PERL_VERSION < 6
+ CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
+#else
+ dSP;
+ 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);
+
+ /*
+ * Retrieve the source of the code reference
+ * as a small or large scalar
+ */
+
+ GETMARK(type);
+ switch (type) {
+ case SX_SCALAR:
+ text = retrieve_scalar(cxt, cname);
+ break;
+ case SX_LSCALAR:
+ text = retrieve_lscalar(cxt, cname);
+ break;
+ default:
+ CROAK(("Unexpected type %d in retrieve_code\n", type));
+ }
+
+ /*
+ * prepend "sub " to the source
+ */
+
+ sub = newSVpvn("sub ", 4);
+ sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
+ SvREFCNT_dec(text);
+
+ /*
+ * evaluate the source to a code reference and use the CV value
+ */
+
+ if (cxt->eval == NULL) {
+ cxt->eval = perl_get_sv("Storable::Eval", TRUE);
+ SvREFCNT_inc(cxt->eval);
+ }
+ if (!SvTRUE(cxt->eval)) {
+ if (
+ cxt->forgive_me == 0 ||
+ (cxt->forgive_me < 0 && !(cxt->forgive_me =
+ SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
+ ) {
+ 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;
+ }
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
+ SV* errsv = get_sv("@", TRUE);
+ sv_setpv(errsv, ""); /* clear $@ */
+ PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newSVsv(sub)));
+ PUTBACK;
+ count = call_sv(cxt->eval, G_SCALAR);
+ SPAGAIN;
+ if (count != 1)
+ CROAK(("Unexpected return value from $Storable::Eval callback\n"));
+ cv = POPs;
+ if (SvTRUE(errsv)) {
+ CROAK(("code %s caused an error: %s",
+ SvPV_nolen(sub), SvPV_nolen(errsv)));
+ }
+ PUTBACK;
+ } else {
+ cv = eval_pv(SvPV_nolen(sub), TRUE);
+ }
+ if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
+ sv = SvRV(cv);
+ } else {
+ CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub)));
+ }
+
+ SvREFCNT_inc(sv); /* XXX seems to be necessary */
+ SvREFCNT_dec(sub);
+
+ FREETMPS;
+ LEAVE;
+ /* fix up the dummy entry... */
+ av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
+
+ return sv;
+#endif
+}
+
+/*
* old_retrieve_array
*
* Retrieve a whole array in pre-0.6 binary format.
*/
static SV *magic_check(stcxt_t *cxt)
{
- char buf[256];
- char byteorder[256];
- int c;
- int use_network_order;
- int version_major;
- int version_minor = 0;
+ /* The worst case for a malicious header would be old magic (which is
+ longer), major, minor, byteorder length byte of 255, 255 bytes of
+ garbage, sizeof int, long, pointer, NV.
+ So the worse of that we can read is 255 bytes of garbage plus 4.
+ Err, I am assuming 8 bit bytes here. Please file a bug report if you're
+ compiling perl on a system with chars that are larger than 8 bits.
+ (Even Crays aren't *that* perverse).
+ */
+ unsigned char buf[4 + 255];
+ unsigned char *current;
+ int c;
+ int length;
+ int use_network_order;
+ int use_NV_size;
+ int version_major;
+ int version_minor = 0;
+
+ TRACEME(("magic_check"));
- TRACEME(("magic_check"));
+ /*
+ * The "magic number" is only for files, not when freezing in memory.
+ */
- /*
- * The "magic number" is only for files, not when freezing in memory.
- */
+ if (cxt->fio) {
+ /* This includes the '\0' at the end. I want to read the extra byte,
+ which is usually going to be the major version number. */
+ STRLEN len = sizeof(magicstr);
+ STRLEN old_len;
- if (cxt->fio) {
- STRLEN len = sizeof(magicstr) - 1;
- STRLEN old_len;
+ READ(buf, (SSize_t)(len)); /* Not null-terminated */
- READ(buf, (SSize_t)len); /* Not null-terminated */
- buf[len] = '\0'; /* Is now */
+ /* Point at the byte after the byte we read. */
+ current = buf + --len; /* Do the -- outside of macros. */
- if (0 == strcmp(buf, magicstr))
- goto magic_ok;
+ if (memNE(buf, magicstr, len)) {
+ /*
+ * Try to read more bytes to check for the old magic number, which
+ * was longer.
+ */
- /*
- * Try to read more bytes to check for the old magic number, which
- * was longer.
- */
+ TRACEME(("trying for old magic number"));
- old_len = sizeof(old_magicstr) - 1;
- READ(&buf[len], (SSize_t)(old_len - len));
- buf[old_len] = '\0'; /* Is now null-terminated */
+ old_len = sizeof(old_magicstr) - 1;
+ READ(current + 1, (SSize_t)(old_len - len));
+
+ if (memNE(buf, old_magicstr, old_len))
+ CROAK(("File is not a perl storable"));
+ current = buf + old_len;
+ }
+ use_network_order = *current;
+ } else
+ GETMARK(use_network_order);
+
+ /*
+ * Starting with 0.6, the "use_network_order" byte flag is also used to
+ * indicate the version number of the binary, and therefore governs the
+ * setting of sv_retrieve_vtbl. See magic_write().
+ */
- if (strcmp(buf, old_magicstr))
- CROAK(("File is not a perl storable"));
- }
+ version_major = use_network_order >> 1;
+ cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve;
-magic_ok:
- /*
- * Starting with 0.6, the "use_network_order" byte flag is also used to
- * indicate the version number of the binary, and therefore governs the
- * setting of sv_retrieve_vtbl. See magic_write().
- */
+ TRACEME(("magic_check: netorder = 0x%x", use_network_order));
- GETMARK(use_network_order);
- version_major = use_network_order >> 1;
- cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve;
- TRACEME(("magic_check: netorder = 0x%x", use_network_order));
+ /*
+ * Starting with 0.7 (binary major 2), a full byte is dedicated to the
+ * minor version of the protocol. See magic_write().
+ */
+ if (version_major > 1)
+ GETMARK(version_minor);
- /*
- * Starting with 0.7 (binary major 2), a full byte is dedicated to the
- * minor version of the protocol. See magic_write().
- */
+ cxt->ver_major = version_major;
+ cxt->ver_minor = version_minor;
- if (version_major > 1)
- GETMARK(version_minor);
+ TRACEME(("binary image version is %d.%d", version_major, version_minor));
- cxt->ver_major = version_major;
- cxt->ver_minor = version_minor;
+ /*
+ * Inter-operability sanity check: we can't retrieve something stored
+ * using a format more recent than ours, because we have no way to
+ * know what has changed, and letting retrieval go would mean a probable
+ * failure reporting a "corrupted" storable file.
+ */
- TRACEME(("binary image version is %d.%d", version_major, version_minor));
+ if (
+ version_major > STORABLE_BIN_MAJOR ||
+ (version_major == STORABLE_BIN_MAJOR &&
+ version_minor > STORABLE_BIN_MINOR)
+ ) {
+ int croak_now = 1;
+ TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
+ STORABLE_BIN_MINOR));
+
+ if (version_major == STORABLE_BIN_MAJOR) {
+ TRACEME(("cxt->accept_future_minor is %d",
+ cxt->accept_future_minor));
+ if (cxt->accept_future_minor < 0)
+ cxt->accept_future_minor
+ = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
+ TRUE))
+ ? 1 : 0);
+ if (cxt->accept_future_minor == 1)
+ croak_now = 0; /* Don't croak yet. */
+ }
+ if (croak_now) {
+ CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)",
+ version_major, version_minor,
+ STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
+ }
+ }
- /*
- * Inter-operability sanity check: we can't retrieve something stored
- * using a format more recent than ours, because we have no way to
- * know what has changed, and letting retrieval go would mean a probable
- * failure reporting a "corrupted" storable file.
- */
+ /*
+ * If they stored using network order, there's no byte ordering
+ * information to check.
+ */
- if (
- version_major > STORABLE_BIN_MAJOR ||
- (version_major == STORABLE_BIN_MAJOR &&
- version_minor > STORABLE_BIN_MINOR)
- ) {
- int croak_now = 1;
- TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
- STORABLE_BIN_MINOR));
-
- if (version_major == STORABLE_BIN_MAJOR) {
- TRACEME(("cxt->accept_future_minor is %d",
- cxt->accept_future_minor));
- if (cxt->accept_future_minor < 0)
- cxt->accept_future_minor
- = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
- TRUE))
- ? 1 : 0);
- if (cxt->accept_future_minor == 1)
- croak_now = 0; /* Don't croak yet. */
- }
- if (croak_now) {
- CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)",
- version_major, version_minor,
- STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
- }
- }
+ if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
+ return &PL_sv_undef; /* No byte ordering info */
- /*
- * If they stored using network order, there's no byte ordering
- * information to check.
- */
+ /* In C truth is 1, falsehood is 0. Very convienient. */
+ use_NV_size = version_major >= 2 && version_minor >= 2;
- if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
- return &PL_sv_undef; /* No byte ordering info */
+ GETMARK(c);
+ length = c + 3 + use_NV_size;
+ READ(buf, length); /* Not null-terminated */
- sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
- GETMARK(c);
- READ(buf, c); /* Not null-terminated */
- buf[c] = '\0'; /* Is now */
+ TRACEME(("byte order '%.*s' %d", c, buf, c));
- TRACEME(("byte order '%s'", buf));
+#ifdef USE_56_INTERWORK_KLUDGE
+ /* No point in caching this in the context as we only need it once per
+ retrieve, and we need to recheck it each read. */
+ if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) {
+ if ((c != (sizeof (byteorderstr_56) - 1))
+ || memNE(buf, byteorderstr_56, c))
+ CROAK(("Byte order is not compatible"));
+ } else
+#endif
+ {
+ if ((c != (sizeof (byteorderstr) - 1)) || memNE(buf, byteorderstr, c))
+ CROAK(("Byte order is not compatible"));
+ }
- if (strcmp(buf, byteorder))
- CROAK(("Byte order is not compatible"));
-
- GETMARK(c); /* sizeof(int) */
- if ((int) c != sizeof(int))
- CROAK(("Integer size is not compatible"));
-
- GETMARK(c); /* sizeof(long) */
- if ((int) c != sizeof(long))
- CROAK(("Long integer size is not compatible"));
-
- GETMARK(c); /* sizeof(char *) */
- if ((int) c != sizeof(char *))
- CROAK(("Pointer integer size is not compatible"));
-
- if (version_major >= 2 && version_minor >= 2) {
- GETMARK(c); /* sizeof(NV) */
- if ((int) c != sizeof(NV))
- CROAK(("Double size is not compatible"));
- }
+ current = buf + c;
+
+ /* sizeof(int) */
+ if ((int) *current++ != sizeof(int))
+ CROAK(("Integer size is not compatible"));
+
+ /* sizeof(long) */
+ if ((int) *current++ != sizeof(long))
+ CROAK(("Long integer size is not compatible"));
+
+ /* sizeof(char *) */
+ if ((int) *current != sizeof(char *))
+ CROAK(("Pointer size is not compatible"));
+
+ if (use_NV_size) {
+ /* sizeof(NV) */
+ if ((int) *++current != sizeof(NV))
+ CROAK(("Double size is not compatible"));
+ }
- return &PL_sv_undef; /* OK */
+ return &PL_sv_undef; /* OK */
}
/*
if (!sv) {
TRACEME(("retrieve ERROR"));
+#if (PATCHLEVEL <= 4)
+ /* perl 5.00405 seems to screw up at this point with an
+ 'attempt to modify a read only value' error reported in the
+ eval { $self = pretrieve(*FILE) } in _retrieve.
+ I can't see what the cause of this error is, but I suspect a
+ bug in 5.004, as it seems to be capable of issuing spurious
+ errors or core dumping with matches on $@. I'm not going to
+ spend time on what could be a fruitless search for the cause,
+ so here's a bodge. If you're running 5.004 and don't like
+ this inefficiency, either upgrade to a newer perl, or you are
+ welcome to find the problem and send in a patch.
+ */
+ return newSV(0);
+#else
return &PL_sv_undef; /* Something went wrong, return undef */
+#endif
}
TRACEME(("retrieve got %s(0x%"UVxf")",
BOOT:
init_perinterp();
+ gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV);
+#ifdef DEBUGME
+ /* Only disable the used only once warning if we are in debugging mode. */
+ gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV);
+#endif
+#ifdef USE_56_INTERWORK_KLUDGE
+ gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
+#endif
+
+void
+init_perinterp()
int
pstore(f,obj)
int
is_retrieving()
-
projects / p5sagit/p5-mst-13.2.git / blobdiff