/*
- * 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 <XSUB.h>
#ifndef NETWARE
-#if 1
+#if 0
#define DEBUGME /* Debug mode, turns assertions on as well */
#define DASSERT /* Assertion mode */
#endif
* TRACEME() will only output things when the $Storable::DEBUGME is true.
*/
-#define TRACEME(x) do { \
+#define TRACEME(x) \
+ STMT_START { \
if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \
- { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
-} while (0)
+ { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
+ } STMT_END
#else
#define TRACEME(x)
#endif /* DEBUGME */
#ifdef DASSERT
-#define ASSERT(x,y) do { \
+#define ASSERT(x,y) \
+ STMT_START { \
if (!(x)) { \
PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \
__FILE__, __LINE__); \
PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \
} \
-} while (0)
+ } STMT_END
#else
#define ASSERT(x,y)
#endif
#define SX_BYTE C(8) /* (signed) byte forthcoming */
#define SX_NETINT C(9) /* Integer in network order forthcoming */
#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_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_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */
#define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */
#define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */
#define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */
#define SX_HOOK C(19) /* Stored via hook, user-defined */
#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_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_TIED_KEY C(21) /* Tied magic key forthcoming */
+#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
+#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_CLASS 'b' /* Object is blessed, class name length <255 */
-#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */
+#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */
#define SX_STORED 'X' /* End of object */
/*
#ifndef HAS_UTF8_ALL
int use_bytes; /* whether to bytes-ify utf8 */
#endif
+ int accept_future_minor; /* croak immediately on future minor versions? */
int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
int membuf_ro; /* true means membuf is read-only and msaved is rw */
struct extendable keybuf; /* for hash key retrieval */
int ver_major; /* major of version for retrieved object */
int ver_minor; /* minor of version for retrieved object */
SV *(**retrieve_vtbl)(); /* retrieve dispatch table */
- struct stcxt *prev; /* contexts chained backwards in real recursion */
+ SV *prev; /* contexts chained backwards in real recursion */
+ SV *my_sv; /* the blessed scalar who's SvPVX() I am */
} stcxt_t;
+#define NEW_STORABLE_CXT_OBJ(cxt) \
+ STMT_START { \
+ SV *self = newSV(sizeof(stcxt_t) - 1); \
+ SV *my_sv = newRV_noinc(self); \
+ sv_bless(my_sv, gv_stashpv("Storable::Cxt", TRUE)); \
+ cxt = (stcxt_t *)SvPVX(self); \
+ Zero(cxt, 1, stcxt_t); \
+ cxt->my_sv = my_sv; \
+ } STMT_END
+
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
#if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
#endif /* < perl5.004_68 */
#define dSTCXT_PTR(T,name) \
- T name = ((perinterp_sv && SvIOK(perinterp_sv) \
- ? INT2PTR(T, SvIVX(perinterp_sv)) : (T) 0))
+ T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \
+ ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
#define dSTCXT \
dSTCXT_SV; \
dSTCXT_PTR(stcxt_t *, cxt)
-#define INIT_STCXT \
- dSTCXT; \
- Newz(0, cxt, 1, stcxt_t); \
- sv_setiv(perinterp_sv, PTR2IV(cxt))
+#define INIT_STCXT \
+ dSTCXT; \
+ NEW_STORABLE_CXT_OBJ(cxt); \
+ sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv))
-#define SET_STCXT(x) do { \
+#define SET_STCXT(x) \
+ STMT_START { \
dSTCXT_SV; \
- sv_setiv(perinterp_sv, PTR2IV(x)); \
-} while (0)
+ sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \
+ } STMT_END
#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 INIT_STCXT dSTCXT
-#define SET_STCXT(x) Context_ptr = x
+#define SET_STCXT(x) Context_ptr = x
+#define INIT_STCXT \
+ dSTCXT; \
+ NEW_STORABLE_CXT_OBJ(cxt); \
+ SET_STCXT(cxt)
+
#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
* but the topmost context stacked.
*/
-#define CROAK(x) do { cxt->s_dirty = 1; croak x; } while (0)
+#define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END
/*
* End of "thread-safe" related definitions.
*/
#define kbuf (cxt->keybuf).arena
#define ksiz (cxt->keybuf).asiz
-#define KBUFINIT() do { \
+#define KBUFINIT() \
+ STMT_START { \
if (!kbuf) { \
TRACEME(("** allocating kbuf of 128 bytes")); \
New(10003, kbuf, 128, char); \
ksiz = 128; \
} \
-} while (0)
-#define KBUFCHK(x) do { \
+ } STMT_END
+#define KBUFCHK(x) \
+ STMT_START { \
if (x >= ksiz) { \
TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \
Renew(kbuf, x+1, char); \
ksiz = x+1; \
} \
-} while (0)
+ } STMT_END
/*
* memory buffer handling
#define int_aligned(x) \
((unsigned long) (x) == trunc_int(x))
-#define MBUF_INIT(x) do { \
+#define MBUF_INIT(x) \
+ STMT_START { \
if (!mbase) { \
TRACEME(("** allocating mbase of %d bytes", MGROW)); \
New(10003, mbase, MGROW, char); \
mend = mbase + x; \
else \
mend = mbase + msiz; \
-} while (0)
+ } STMT_END
#define MBUF_TRUNC(x) mptr = mbase + x
#define MBUF_SIZE() (mptr - mbase)
* buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
* data from a string.
*/
-#define MBUF_SAVE_AND_LOAD(in) do { \
+#define MBUF_SAVE_AND_LOAD(in) \
+ STMT_START { \
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)
+ } STMT_END
-#define MBUF_RESTORE() do { \
+#define MBUF_RESTORE() \
+ STMT_START { \
ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
cxt->membuf_ro = 0; \
TRACEME(("restoring mbuf")); \
StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
-} while (0)
+ } STMT_END
/*
* Use SvPOKp(), because SvPOK() fails on tainted scalars.
* See store_scalar() for other usage of this workaround.
*/
-#define MBUF_LOAD(v) do { \
+#define MBUF_LOAD(v) \
+ STMT_START { \
ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
if (!SvPOKp(v)) \
CROAK(("Not a scalar string")); \
mptr = mbase = SvPV(v, msiz); \
mend = mbase + msiz; \
-} while (0)
+ } STMT_END
-#define MBUF_XTEND(x) do { \
+#define MBUF_XTEND(x) \
+ STMT_START { \
int nsz = (int) round_mgrow((x)+msiz); \
int offset = mptr - mbase; \
ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
msiz = nsz; \
mptr = mbase + offset; \
mend = mbase + nsz; \
-} while (0)
+ } STMT_END
-#define MBUF_CHK(x) do { \
+#define MBUF_CHK(x) \
+ STMT_START { \
if ((mptr + (x)) > mend) \
MBUF_XTEND(x); \
-} while (0)
+ } STMT_END
-#define MBUF_GETC(x) do { \
+#define MBUF_GETC(x) \
+ STMT_START { \
if (mptr < mend) \
x = (int) (unsigned char) *mptr++; \
else \
return (SV *) 0; \
-} while (0)
+ } STMT_END
#ifdef CRAY_HACK
-#define MBUF_GETINT(x) do { \
+#define MBUF_GETINT(x) \
+ STMT_START { \
oC(x); \
if ((mptr + 4) <= mend) { \
memcpy(oI(&x), mptr, 4); \
mptr += 4; \
} else \
return (SV *) 0; \
-} while (0)
+ } STMT_END
#else
-#define MBUF_GETINT(x) do { \
+#define MBUF_GETINT(x) \
+ STMT_START { \
if ((mptr + sizeof(int)) <= mend) { \
if (int_aligned(mptr)) \
x = *(int *) mptr; \
mptr += sizeof(int); \
} else \
return (SV *) 0; \
-} while (0)
+ } STMT_END
#endif
-#define MBUF_READ(x,s) do { \
+#define MBUF_READ(x,s) \
+ STMT_START { \
if ((mptr + (s)) <= mend) { \
memcpy(x, mptr, s); \
mptr += s; \
} else \
return (SV *) 0; \
-} while (0)
+ } STMT_END
-#define MBUF_SAFEREAD(x,s,z) do { \
+#define MBUF_SAFEREAD(x,s,z) \
+ STMT_START { \
if ((mptr + (s)) <= mend) { \
memcpy(x, mptr, s); \
mptr += s; \
sv_free(z); \
return (SV *) 0; \
} \
-} while (0)
+ } STMT_END
-#define MBUF_PUTC(c) do { \
+#define MBUF_PUTC(c) \
+ STMT_START { \
if (mptr < mend) \
*mptr++ = (char) c; \
else { \
MBUF_XTEND(1); \
*mptr++ = (char) c; \
} \
-} while (0)
+ } STMT_END
#ifdef CRAY_HACK
-#define MBUF_PUTINT(i) do { \
+#define MBUF_PUTINT(i) \
+ STMT_START { \
MBUF_CHK(4); \
memcpy(mptr, oI(&i), 4); \
mptr += 4; \
-} while (0)
+ } STMT_END
#else
-#define MBUF_PUTINT(i) do { \
+#define MBUF_PUTINT(i) \
+ STMT_START { \
MBUF_CHK(sizeof(int)); \
if (int_aligned(mptr)) \
*(int *) mptr = i; \
else \
memcpy(mptr, &i, sizeof(int)); \
mptr += sizeof(int); \
-} while (0)
+ } STMT_END
#endif
-#define MBUF_WRITE(x,s) do { \
+#define MBUF_WRITE(x,s) \
+ STMT_START { \
MBUF_CHK(s); \
memcpy(mptr, x, s); \
mptr += s; \
-} while (0)
+ } STMT_END
/*
* Possible return values for sv_type().
* 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" */
* Useful store shortcuts...
*/
-#define PUTMARK(x) do { \
+#define PUTMARK(x) \
+ STMT_START { \
if (!cxt->fio) \
MBUF_PUTC(x); \
else if (PerlIO_putc(cxt->fio, x) == EOF) \
return -1; \
-} while (0)
+ } STMT_END
-#define WRITE_I32(x) do { \
+#define WRITE_I32(x) \
+ STMT_START { \
ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \
if (!cxt->fio) \
MBUF_PUTINT(x); \
else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
return -1; \
- } while (0)
+ } STMT_END
#ifdef HAS_HTONL
-#define WLEN(x) do { \
+#define WLEN(x) \
+ STMT_START { \
if (cxt->netorder) { \
int y = (int) htonl(x); \
if (!cxt->fio) \
else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \
return -1; \
} \
-} while (0)
+ } STMT_END
#else
#define WLEN(x) WRITE_I32(x)
#endif
-#define WRITE(x,y) do { \
+#define WRITE(x,y) \
+ STMT_START { \
if (!cxt->fio) \
MBUF_WRITE(x,y); \
else if (PerlIO_write(cxt->fio, x, y) != y) \
return -1; \
- } while (0)
+ } STMT_END
-#define STORE_PV_LEN(pv, len, small, large) do { \
+#define STORE_PV_LEN(pv, len, small, large) \
+ STMT_START { \
if (len <= LG_SCALAR) { \
unsigned char clen = (unsigned char) len; \
PUTMARK(small); \
WLEN(len); \
WRITE(pv, len); \
} \
-} while (0)
+ } STMT_END
#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
/*
* Store undef in arrays and hashes without recursing through store().
*/
-#define STORE_UNDEF() do { \
+#define STORE_UNDEF() \
+ STMT_START { \
cxt->tagnum++; \
PUTMARK(SX_UNDEF); \
-} while (0)
+ } STMT_END
/*
* Useful retrieve shortcuts...
#define GETCHAR() \
(cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++))
-#define GETMARK(x) do { \
+#define GETMARK(x) \
+ STMT_START { \
if (!cxt->fio) \
MBUF_GETC(x); \
else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \
return (SV *) 0; \
-} while (0)
+ } STMT_END
-#define READ_I32(x) do { \
+#define READ_I32(x) \
+ STMT_START { \
ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \
oC(x); \
if (!cxt->fio) \
MBUF_GETINT(x); \
else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
return (SV *) 0; \
-} while (0)
+ } STMT_END
#ifdef HAS_NTOHL
-#define RLEN(x) do { \
+#define RLEN(x) \
+ STMT_START { \
oC(x); \
if (!cxt->fio) \
MBUF_GETINT(x); \
return (SV *) 0; \
if (cxt->netorder) \
x = (int) ntohl(x); \
-} while (0)
+ } STMT_END
#else
#define RLEN(x) READ_I32(x)
#endif
-#define READ(x,y) do { \
+#define READ(x,y) \
+ STMT_START { \
if (!cxt->fio) \
MBUF_READ(x, y); \
else if (PerlIO_read(cxt->fio, x, y) != y) \
return (SV *) 0; \
-} while (0)
+ } STMT_END
-#define SAFEREAD(x,y,z) do { \
+#define SAFEREAD(x,y,z) \
+ STMT_START { \
if (!cxt->fio) \
MBUF_SAFEREAD(x,y,z); \
else if (PerlIO_read(cxt->fio, x, y) != y) { \
sv_free(z); \
return (SV *) 0; \
} \
-} while (0)
+ } STMT_END
/*
* This macro is used at retrieve time, to remember where object 'y', bearing a
* recursively, and the first SEEN() call for which the class name is not NULL
* will bless the object.
*/
-#define SEEN(y,c) do { \
+#define SEEN(y,c) \
+ STMT_START { \
if (!y) \
return (SV *) 0; \
if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
PTR2UV(y), SvREFCNT(y)-1)); \
if (c) \
BLESS((SV *) (y), c); \
-} while (0)
+ } STMT_END
/*
* Bless `s' in `p', via a temporary reference, required by sv_bless().
*/
-#define BLESS(s,p) do { \
+#define BLESS(s,p) \
+ STMT_START { \
SV *ref; \
HV *stash; \
TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
(void) sv_bless(ref, stash); \
SvRV(ref) = 0; \
SvREFCNT_dec(ref); \
-} while (0)
+ } STMT_END
static int store();
static SV *retrieve(stcxt_t *cxt, char *cname);
sv_free((SV *) hook_seen);
}
+ cxt->forgive_me = -1; /* Fetched from perl if needed */
+ cxt->canonical = -1; /* Idem */
+
reset_context(cxt);
}
#ifndef HAS_UTF8_ALL
cxt->use_bytes = -1; /* Fetched from perl if needed */
#endif
+ cxt->accept_future_minor = -1; /* Fetched from perl if needed */
}
/*
sv_free((SV *) hseen); /* optional HV, for backward compat. */
}
+#ifndef HAS_RESTRICTED_HASHES
+ cxt->derestrict = -1; /* Fetched from perl if needed */
+#endif
+#ifndef HAS_UTF8_ALL
+ cxt->use_bytes = -1; /* Fetched from perl if needed */
+#endif
+ cxt->accept_future_minor = -1; /* Fetched from perl if needed */
+
reset_context(cxt);
}
ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
- Newz(0, cxt, 1, stcxt_t);
- cxt->prev = parent_cxt;
+ NEW_STORABLE_CXT_OBJ(cxt);
+ cxt->prev = parent_cxt->my_sv;
SET_STCXT(cxt);
ASSERT(!cxt->s_dirty, ("clean context"));
static void free_context(cxt)
stcxt_t *cxt;
{
- stcxt_t *prev = cxt->prev;
+ stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
TRACEME(("free_context"));
ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(prev, ("not freeing root context"));
- if (kbuf)
- Safefree(kbuf);
- if (mbase)
- Safefree(mbase);
-
- Safefree(cxt);
+ SvREFCNT_dec(cxt->my_sv);
SET_STCXT(prev);
ASSERT(cxt, ("context not void"));
pv = SvPV(sv, len); /* We know it's SvPOK */
goto string; /* Share code below */
}
- } else if (flags & SVp_POK) { /* SvPOKp(sv) => string */
- I32 wlen; /* For 64-bit machines */
- pv = SvPV(sv, len);
-
- /*
- * Will come here from below with pv and len set if double & netorder,
- * or from above if it was readonly, POK and NOK but neither &PL_sv_yes
- * nor &PL_sv_no.
- */
- string:
+ } else if (flags & SVf_POK) {
+ /* public string - go direct to string read. */
+ goto string_readlen;
+ } else if (
+#if (PATCHLEVEL <= 6)
+ /* For 5.6 and earlier NV flag trumps IV flag, so only use integer
+ direct if NV flag is off. */
+ (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK
+#else
+ /* 5.7 rules are that if IV public flag is set, IV value is as
+ good, if not better, than NV value. */
+ flags & SVf_IOK
+#endif
+ ) {
+ iv = SvIV(sv);
+ /*
+ * Will come here from below with iv set if double is an integer.
+ */
+ integer:
- wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
- if (SvUTF8 (sv))
- STORE_UTF8STR(pv, wlen);
- else
- STORE_SCALAR(pv, wlen);
- TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
- PTR2UV(sv), SvPVX(sv), (IV)len));
+ /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
+#ifdef SVf_IVisUV
+ /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
+ * (for example) and that ends up in the optimised small integer
+ * case.
+ */
+ if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
+ TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv)));
+ goto string_readlen;
+ }
+#endif
+ /*
+ * Optimize small integers into a single byte, otherwise store as
+ * a real integer (converted into network order if they asked).
+ */
- } else if (flags & SVp_NOK) { /* SvNOKp(sv) => double */
- NV nv = SvNV(sv);
+ if (iv >= -128 && iv <= 127) {
+ unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
+ PUTMARK(SX_BYTE);
+ PUTMARK(siv);
+ TRACEME(("small integer stored as %d", siv));
+ } else if (cxt->netorder) {
+#ifndef HAS_HTONL
+ TRACEME(("no htonl, fall back to string for integer"));
+ goto string_readlen;
+#else
+ I32 niv;
- /*
- * Watch for number being an integer in disguise.
- */
- if (nv == (NV) (iv = I_V(nv))) {
- TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
- goto integer; /* Share code below */
- }
- if (cxt->netorder) {
- TRACEME(("double %"NVff" stored as string", nv));
- pv = SvPV(sv, len);
- goto string; /* Share code above */
- }
+#if IVSIZE > 4
+ if (
+#ifdef SVf_IVisUV
+ /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
+ ((flags & SVf_IVisUV) && SvUV(sv) > 0x7FFFFFFF) ||
+#endif
+ (iv > 0x7FFFFFFF) || (iv < -0x80000000)) {
+ /* Bigger than 32 bits. */
+ TRACEME(("large network order integer as string, value = %"IVdf, iv));
+ goto string_readlen;
+ }
+#endif
- PUTMARK(SX_DOUBLE);
- WRITE(&nv, sizeof(nv));
+ niv = (I32) htonl((I32) iv);
+ TRACEME(("using network order"));
+ PUTMARK(SX_NETINT);
+ WRITE_I32(niv);
+#endif
+ } else {
+ PUTMARK(SX_INTEGER);
+ WRITE(&iv, sizeof(iv));
+ }
+
+ TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
+ } else if (flags & SVf_NOK) {
+ NV nv;
+#if (PATCHLEVEL <= 6)
+ nv = SvNV(sv);
+ /*
+ * Watch for number being an integer in disguise.
+ */
+ if (nv == (NV) (iv = I_V(nv))) {
+ TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
+ goto integer; /* Share code above */
+ }
+#else
- TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
+ SvIV_please(sv);
+ if (SvIOK(sv)) {
+ iv = SvIV(sv);
+ goto integer; /* Share code above */
+ }
+ nv = SvNV(sv);
+#endif
- } else if (flags & SVp_IOK) { /* SvIOKp(sv) => integer */
- iv = SvIV(sv);
+ if (cxt->netorder) {
+ TRACEME(("double %"NVff" stored as string", nv));
+ goto string_readlen; /* Share code below */
+ }
- /*
- * Will come here from above with iv set if double is an integer.
- */
- integer:
+ PUTMARK(SX_DOUBLE);
+ WRITE(&nv, sizeof(nv));
- /*
- * Optimize small integers into a single byte, otherwise store as
- * a real integer (converted into network order if they asked).
- */
+ TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
- if (iv >= -128 && iv <= 127) {
- unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
- PUTMARK(SX_BYTE);
- PUTMARK(siv);
- TRACEME(("small integer stored as %d", siv));
- } else if (cxt->netorder) {
- I32 niv;
-#ifdef HAS_HTONL
- niv = (I32) htonl(iv);
- TRACEME(("using network order"));
-#else
- niv = (I32) iv;
- TRACEME(("as-is for network order"));
-#endif
- PUTMARK(SX_NETINT);
- WRITE_I32(niv);
- } else {
- PUTMARK(SX_INTEGER);
- WRITE(&iv, sizeof(iv));
- }
+ } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
+ I32 wlen; /* For 64-bit machines */
- TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
+ string_readlen:
+ pv = SvPV(sv, len);
+ /*
+ * Will come here from above if it was readonly, POK and NOK but
+ * neither &PL_sv_yes nor &PL_sv_no.
+ */
+ string:
+
+ wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
+ if (SvUTF8 (sv))
+ STORE_UTF8STR(pv, wlen);
+ else
+ STORE_SCALAR(pv, wlen);
+ TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
+ PTR2UV(sv), SvPVX(sv), (IV)len));
} else
- CROAK(("Can't determine type of %s(0x%"UVxf")",
- sv_reftype(sv, FALSE),
- PTR2UV(sv)));
-
- return 0; /* Ok, no recursion on scalars */
+ CROAK(("Can't determine type of %s(0x%"UVxf")",
+ sv_reftype(sv, FALSE),
+ PTR2UV(sv)));
+ return 0; /* Ok, no recursion on scalars */
}
/*
* 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;
}
*/
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(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);
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;
*/
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(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().
+ */
- old_len = sizeof(old_magicstr) - 1;
- READ(&buf[len], (SSize_t)(old_len - len));
- buf[old_len] = '\0'; /* Is now null-terminated */
+ version_major = use_network_order >> 1;
+ cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve;
- if (strcmp(buf, old_magicstr))
- CROAK(("File is not a perl storable"));
- }
+ TRACEME(("magic_check: netorder = 0x%x", use_network_order));
-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().
- */
- GETMARK(use_network_order);
- version_major = use_network_order >> 1;
- cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve;
+ /*
+ * Starting with 0.7 (binary major 2), a full byte is dedicated to the
+ * minor version of the protocol. See magic_write().
+ */
- TRACEME(("magic_check: netorder = 0x%x", use_network_order));
+ if (version_major > 1)
+ GETMARK(version_minor);
+ cxt->ver_major = version_major;
+ cxt->ver_minor = version_minor;
- /*
- * Starting with 0.7 (binary major 2), a full byte is dedicated to the
- * minor version of the protocol. See magic_write().
- */
+ TRACEME(("binary image version is %d.%d", version_major, version_minor));
- if (version_major > 1)
- GETMARK(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.
+ */
- cxt->ver_major = version_major;
- cxt->ver_minor = 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));
+ }
+ }
- TRACEME(("binary image version is %d.%d", version_major, version_minor));
+ /*
+ * If they stored using network order, there's no byte ordering
+ * information to check.
+ */
- /*
- * 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 ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
+ return &PL_sv_undef; /* No byte ordering info */
- if (
- version_major > STORABLE_BIN_MAJOR ||
- (version_major == STORABLE_BIN_MAJOR &&
- version_minor > STORABLE_BIN_MINOR)
- ) {
- TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
- STORABLE_BIN_MINOR));
+ /* In C truth is 1, falsehood is 0. Very convienient. */
+ use_NV_size = version_major >= 2 && version_minor >= 2;
- 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));
- }
+ GETMARK(c);
+ length = c + 3 + use_NV_size;
+ READ(buf, length); /* Not null-terminated */
- /*
- * If they stored using network order, there's no byte ordering
- * information to check.
- */
+ TRACEME(("byte order '%.*s' %d", c, buf, c));
- if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
- return &PL_sv_undef; /* No byte ordering info */
+#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"));
+ }
- sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
- GETMARK(c);
- READ(buf, c); /* Not null-terminated */
- buf[c] = '\0'; /* Is now */
+ current = buf + c;
+
+ /* sizeof(int) */
+ if ((int) *current++ != sizeof(int))
+ CROAK(("Integer size is not compatible"));
- TRACEME(("byte order '%s'", buf));
+ /* sizeof(long) */
+ if ((int) *current++ != sizeof(long))
+ CROAK(("Long integer size 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"));
- }
+ /* sizeof(char *) */
+ if ((int) *current != sizeof(char *))
+ CROAK(("Pointer integer size is not compatible"));
- return &PL_sv_undef; /* OK */
+ if (use_NV_size) {
+ /* sizeof(NV) */
+ if ((int) *++current != sizeof(NV))
+ CROAK(("Double size is not compatible"));
+ }
+
+ return &PL_sv_undef; /* OK */
}
/*
TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
return sv; /* The SV pointer where object was retrieved */
- }
+ } else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_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(("Storable binary image v%d.%d contains data of type %d. "
+ "This Storable is v%d.%d and can only handle data types up to %d",
+ cxt->ver_major, cxt->ver_minor, type,
+ STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1));
+ }
+ }
first_time: /* Will disappear when support for old format is dropped */
#define InputStream PerlIO *
#endif /* !OutputStream */
+MODULE = Storable PACKAGE = Storable::Cxt
+
+void
+DESTROY(self)
+ SV *self
+PREINIT:
+ stcxt_t *cxt = (stcxt_t *)SvPVX(SvRV(self));
+PPCODE:
+ if (kbuf)
+ Safefree(kbuf);
+ if (!cxt->membuf_ro && mbase)
+ Safefree(mbase);
+ if (cxt->membuf_ro && (cxt->msaved).arena)
+ Safefree((cxt->msaved).arena);
+
+
MODULE = Storable PACKAGE = Storable
PROTOTYPES: ENABLE
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
int
pstore(f,obj)
int
is_retrieving()
-
projects / p5sagit/p5-mst-13.2.git / blobdiff