/*
- * 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.
- *
*/
+#define PERL_NO_GET_CONTEXT /* we want efficiency */
#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 */
+#endif
+
+#if !defined(PERL_VERSION) || PERL_VERSION < 8
+#include "ppport.h" /* handle old perls */
+#endif
+
#if 0
#define DEBUGME /* Debug mode, turns assertions on as well */
#define DASSERT /* Assertion mode */
#endif
#endif
+#ifndef SvRV_set
+#define SvRV_set(sv, val) \
+ STMT_START { \
+ assert(SvTYPE(sv) >= SVt_RV); \
+ (((XRV*)SvANY(sv))->xrv_rv = (val)); \
+ } STMT_END
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+
+#ifndef dNOOP
+#define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef dVAR
+#define dVAR dNOOP
+#endif
+
+#ifndef HvRITER_set
+# define HvRITER_set(hv,r) (HvRITER(hv) = r)
+#endif
+#ifndef HvEITER_set
+# define HvEITER_set(hv,r) (HvEITER(hv) = r)
+#endif
+
+#ifndef HvRITER_get
+# define HvRITER_get HvRITER
+#endif
+#ifndef HvEITER_get
+# define HvEITER_get HvEITER
+#endif
+
+#ifndef HvNAME_get
+#define HvNAME_get HvNAME
+#endif
+
+#ifndef HvPLACEHOLDERS_get
+# define HvPLACEHOLDERS_get HvPLACEHOLDERS
+#endif
+
#ifdef DEBUGME
#ifndef DASSERT
* 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_ERROR C(25) /* Error */
+#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_CODE C(26) /* Code references as perl source code */
+#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */
+#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */
+#define SX_ERROR C(29) /* Error */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
*/
#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 */
/*
#define MY_VERSION "Storable(" XS_VERSION ")"
+
+/*
+ * Conditional UTF8 support.
+ *
+ */
+#ifdef SvUTF8_on
+#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
+#define HAS_UTF8_SCALARS
+#ifdef HeKUTF8
+#define HAS_UTF8_HASHES
+#define HAS_UTF8_ALL
+#else
+/* 5.6 perl has utf8 scalars but not hashes */
+#endif
+#else
+#define SvUTF8(sv) 0
+#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
+#endif
+#ifndef HAS_UTF8_ALL
+#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
+#endif
+#ifndef SvWEAKREF
+#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
+#endif
+
+#ifdef HvPLACEHOLDERS
+#define HAS_RESTRICTED_HASHES
+#else
+#define HVhek_PLACEHOLD 0x200
+#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
+#endif
+
+#ifdef HvHASKFLAGS
+#define HAS_HASH_KEY_FLAGS
+#endif
+
+#ifdef ptr_table_new
+#define USE_PTR_TABLE
+#endif
+
/*
* 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
*/
+struct stcxt;
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
- HV *hseen; /* which objects have been seen, store time */
+ /* which objects have been seen, store time.
+ tags are numbers, which are cast to (SV *) and stored directly */
+#ifdef USE_PTR_TABLE
+ /* use pseen if we have ptr_tables. We have to store tag+1, because
+ tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table
+ without it being confused for a fetch lookup failure. */
+ struct ptr_tbl *pseen;
+ /* Still need hseen for the 0.6 file format code. */
+#endif
+ HV *hseen;
AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
AV *aseen; /* which objects have been seen, retrieve time */
+ IV where_is_undef; /* index in aseen of PL_sv_undef */
HV *hclass; /* which classnames have been seen, store time */
AV *aclass; /* which classnames have been seen, retrieve time */
HV *hook; /* cache for hook methods per class name */
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 */
+#endif
+#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 */
PerlIO *fio; /* where I/O are performed, NULL for memory */
int ver_major; /* major of version for retrieved object */
int ver_minor; /* minor of version for retrieved object */
- SV *(**retrieve_vtbl)(); /* retrieve dispatch table */
- struct stcxt *prev; /* contexts chained backwards in real recursion */
+ SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */
+ 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); \
- msiz = MGROW; \
+ msiz = (STRLEN)MGROW; \
} \
mptr = mbase; \
if (x) \
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().
#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.
#define SHT_THASH 6 /* 4 + 2 -- tied hash */
/*
+ * per hash flags for flagged hashes
+ */
+
+#define SHV_RESTRICTED 0x01
+
+/*
+ * per key flags for flagged hashes
+ */
+
+#define SHV_K_UTF8 0x01
+#define SHV_K_WASUTF8 0x02
+#define SHV_K_LOCKED 0x04
+#define SHV_K_ISSV 0x08
+#define SHV_K_PLACEHOLDER 0x10
+
+/*
* Before 0.6, the magic string was "perl-store" (binary version number 0).
*
* Since 0.6 introduced many binary incompatibilities, the magic string has
* 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 byteorder. Please append your byteorder to Storable.xs
+#endif
+#endif
+#endif
+#endif
-#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 4 /* Binary minor "version" */
+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 7 /* Binary minor "version" */
+
+#if (PATCHLEVEL <= 5)
+#define STORABLE_BIN_WRITE_MINOR 4
+#else
+/*
+ * Perl 5.6.0 onwards can do weak references.
+*/
+#define STORABLE_BIN_WRITE_MINOR 7
+#endif /* (PATCHLEVEL <= 5) */
+
+#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
+#define PL_sv_placeholder PL_sv_undef
+#endif
/*
* Useful store shortcuts...
*/
-#define PUTMARK(x) do { \
+/*
+ * 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) \
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)
/*
- * 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().
+ * Store &PL_sv_undef in arrays without recursing through store().
*/
-#define STORE_UNDEF() do { \
+#define STORE_SV_UNDEF() \
+ STMT_START { \
cxt->tagnum++; \
- PUTMARK(SX_UNDEF); \
-} while (0)
+ PUTMARK(SX_SV_UNDEF); \
+ } 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
* To achieve that, the class name of the last retrieved object is passed down
* recursively, and the first SEEN() call for which the class name is not NULL
* will bless the object.
+ *
+ * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
*/
-#define SEEN(y,c) do { \
+#define SEEN(y,c,i) \
+ STMT_START { \
if (!y) \
return (SV *) 0; \
- if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
+ if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \
return (SV *) 0; \
TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
PTR2UV(y), SvREFCNT(y)-1)); \
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))); \
stash = gv_stashpv((p), TRUE); \
ref = newRV_noinc(s); \
(void) sv_bless(ref, stash); \
- SvRV(ref) = 0; \
+ SvRV_set(ref, NULL); \
SvREFCNT_dec(ref); \
-} while (0)
+ } STMT_END
+/*
+ * sort (used in store_hash) - conditionally use qsort when
+ * sortsv is not available ( <= 5.6.1 ).
+ */
+
+#if (PATCHLEVEL <= 6)
+
+#if defined(USE_ITHREADS)
+
+#define STORE_HASH_SORT \
+ ENTER; { \
+ PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \
+ SAVESPTR(orig_perl); \
+ PERL_SET_CONTEXT(aTHX); \
+ qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \
+ } LEAVE;
+
+#else /* ! USE_ITHREADS */
+
+#define STORE_HASH_SORT \
+ qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
+
+#endif /* USE_ITHREADS */
+
+#else /* PATCHLEVEL > 6 */
-static int store();
-static SV *retrieve(stcxt_t *cxt, char *cname);
+#define STORE_HASH_SORT \
+ sortsv(AvARRAY(av), len, Perl_sv_cmp);
+
+#endif /* PATCHLEVEL <= 6 */
+
+static int store(pTHX_ stcxt_t *cxt, SV *sv);
+static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
/*
* Dynamic dispatching table for SV store.
*/
-static int store_ref(stcxt_t *cxt, SV *sv);
-static int store_scalar(stcxt_t *cxt, SV *sv);
-static int store_array(stcxt_t *cxt, AV *av);
-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_other(stcxt_t *cxt, SV *sv);
-static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
-
-static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
- store_ref, /* svis_REF */
- store_scalar, /* svis_SCALAR */
- (int (*)(stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */
- (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */
- store_tied, /* svis_TIED */
- store_tied_item, /* svis_TIED_ITEM */
- store_other, /* svis_OTHER */
+static int store_ref(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_array(pTHX_ stcxt_t *cxt, AV *av);
+static int store_hash(pTHX_ stcxt_t *cxt, HV *hv);
+static int store_tied(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_code(pTHX_ stcxt_t *cxt, CV *cv);
+static int store_other(pTHX_ stcxt_t *cxt, SV *sv);
+static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg);
+
+typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv);
+
+static const sv_store_t sv_store[] = {
+ (sv_store_t)store_ref, /* svis_REF */
+ (sv_store_t)store_scalar, /* svis_SCALAR */
+ (sv_store_t)store_array, /* svis_ARRAY */
+ (sv_store_t)store_hash, /* svis_HASH */
+ (sv_store_t)store_tied, /* svis_TIED */
+ (sv_store_t)store_tied_item, /* svis_TIED_ITEM */
+ (sv_store_t)store_code, /* svis_CODE */
+ (sv_store_t)store_other, /* svis_OTHER */
};
#define SV_STORE(x) (*sv_store[x])
* Dynamic dispatching tables for SV retrieval.
*/
-static SV *retrieve_lscalar(stcxt_t *cxt, char *cname);
-static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname);
-static SV *old_retrieve_array(stcxt_t *cxt, char *cname);
-static SV *old_retrieve_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_ref(stcxt_t *cxt, char *cname);
-static SV *retrieve_undef(stcxt_t *cxt, char *cname);
-static SV *retrieve_integer(stcxt_t *cxt, char *cname);
-static SV *retrieve_double(stcxt_t *cxt, char *cname);
-static SV *retrieve_byte(stcxt_t *cxt, char *cname);
-static SV *retrieve_netint(stcxt_t *cxt, char *cname);
-static SV *retrieve_scalar(stcxt_t *cxt, char *cname);
-static SV *retrieve_utf8str(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_array(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname);
-static SV *retrieve_other(stcxt_t *cxt, char *cname);
-
-static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = {
+static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname);
+
+typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name);
+
+static const sv_retrieve_t sv_old_retrieve[] = {
0, /* SX_OBJECT -- entry unused dynamically */
- retrieve_lscalar, /* SX_LSCALAR */
- old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
- old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */
- retrieve_ref, /* SX_REF */
- retrieve_undef, /* SX_UNDEF */
- retrieve_integer, /* SX_INTEGER */
- retrieve_double, /* SX_DOUBLE */
- retrieve_byte, /* SX_BYTE */
- retrieve_netint, /* SX_NETINT */
- retrieve_scalar, /* SX_SCALAR */
- retrieve_tied_array, /* SX_ARRAY */
- retrieve_tied_hash, /* SX_HASH */
- retrieve_tied_scalar, /* SX_SCALAR */
- retrieve_other, /* SX_SV_UNDEF not supported */
- retrieve_other, /* SX_SV_YES not supported */
- retrieve_other, /* SX_SV_NO not supported */
- retrieve_other, /* SX_BLESS not supported */
- retrieve_other, /* SX_IX_BLESS not supported */
- retrieve_other, /* SX_HOOK not supported */
- 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 */
+ (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */
+ (sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
+ (sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */
+ (sv_retrieve_t)retrieve_ref, /* SX_REF */
+ (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */
+ (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */
+ (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */
+ (sv_retrieve_t)retrieve_byte, /* SX_BYTE */
+ (sv_retrieve_t)retrieve_netint, /* SX_NETINT */
+ (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */
+ (sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */
+ (sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */
+ (sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */
+ (sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_ERROR */
};
-static SV *retrieve_array(stcxt_t *cxt, char *cname);
-static SV *retrieve_hash(stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_no(stcxt_t *cxt, char *cname);
-static SV *retrieve_blessed(stcxt_t *cxt, char *cname);
-static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname);
-static SV *retrieve_hook(stcxt_t *cxt, char *cname);
-static SV *retrieve_overloaded(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
-
-static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
+static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname);
+
+static const sv_retrieve_t sv_retrieve[] = {
0, /* SX_OBJECT -- entry unused dynamically */
- retrieve_lscalar, /* SX_LSCALAR */
- retrieve_array, /* SX_ARRAY */
- retrieve_hash, /* SX_HASH */
- retrieve_ref, /* SX_REF */
- retrieve_undef, /* SX_UNDEF */
- retrieve_integer, /* SX_INTEGER */
- retrieve_double, /* SX_DOUBLE */
- retrieve_byte, /* SX_BYTE */
- retrieve_netint, /* SX_NETINT */
- retrieve_scalar, /* SX_SCALAR */
- retrieve_tied_array, /* SX_ARRAY */
- retrieve_tied_hash, /* SX_HASH */
- retrieve_tied_scalar, /* SX_SCALAR */
- retrieve_sv_undef, /* SX_SV_UNDEF */
- retrieve_sv_yes, /* SX_SV_YES */
- retrieve_sv_no, /* SX_SV_NO */
- retrieve_blessed, /* SX_BLESS */
- retrieve_idx_blessed, /* SX_IX_BLESS */
- retrieve_hook, /* SX_HOOK */
- 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_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */
+ (sv_retrieve_t)retrieve_array, /* SX_ARRAY */
+ (sv_retrieve_t)retrieve_hash, /* SX_HASH */
+ (sv_retrieve_t)retrieve_ref, /* SX_REF */
+ (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */
+ (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */
+ (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */
+ (sv_retrieve_t)retrieve_byte, /* SX_BYTE */
+ (sv_retrieve_t)retrieve_netint, /* SX_NETINT */
+ (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */
+ (sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */
+ (sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */
+ (sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */
+ (sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */
+ (sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */
+ (sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */
+ (sv_retrieve_t)retrieve_blessed, /* SX_BLESS */
+ (sv_retrieve_t)retrieve_idx_blessed, /* SX_IX_BLESS */
+ (sv_retrieve_t)retrieve_hook, /* SX_HOOK */
+ (sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */
+ (sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */
+ (sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */
+ (sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */
+ (sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */
+ (sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */
+ (sv_retrieve_t)retrieve_code, /* SX_CODE */
+ (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */
+ (sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */
+ (sv_retrieve_t)retrieve_other, /* SX_ERROR */
};
#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
-static SV *mbuf2sv(void);
+static SV *mbuf2sv(pTHX);
/***
*** Context management.
*
* Called once per "thread" (interpreter) to initialize some global context.
*/
-static void init_perinterp(void)
+static void init_perinterp(pTHX)
{
INIT_STCXT;
cxt->netorder = 0; /* true if network order used */
cxt->forgive_me = -1; /* whether to be forgiving... */
+ cxt->accept_future_minor = -1; /* would otherwise occur too late */
}
/*
* Initialize a new store context for real recursion.
*/
static void init_store_context(
+ pTHX_
stcxt_t *cxt,
PerlIO *f,
int optype,
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 */
* those optimizations increase the throughput by 12%.
*/
+#ifdef USE_PTR_TABLE
+ cxt->pseen = ptr_table_new();
+ cxt->hseen = 0;
+#else
cxt->hseen = newHV(); /* Table where seen objects are stored */
HvSHAREKEYS_off(cxt->hseen);
-
+#endif
/*
* The following does not work well with perl5.004_04, and causes
* a core dump later on, in a completely unrelated spot, which
*/
#if PERL_VERSION >= 5
#define HBUCKETS 4096 /* Buckets for %hseen */
+#ifndef USE_PTR_TABLE
HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */
#endif
+#endif
/*
* The `hclass' hash uses the same settings as `hseen' above, but it is
*
* Clean store context by
*/
-static void clean_store_context(stcxt_t *cxt)
+static void clean_store_context(pTHX_ stcxt_t *cxt)
{
HE *he;
* Insert real values into hashes where we stored faked pointers.
*/
+#ifndef USE_PTR_TABLE
if (cxt->hseen) {
hv_iterinit(cxt->hseen);
while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */
HeVAL(he) = &PL_sv_undef;
}
+#endif
if (cxt->hclass) {
hv_iterinit(cxt->hclass);
* -- RAM, 20/12/2000
*/
+#ifdef USE_PTR_TABLE
+ if (cxt->pseen) {
+ struct ptr_tbl *pseen = cxt->pseen;
+ cxt->pseen = 0;
+ ptr_table_free(pseen);
+ }
+ assert(!cxt->hseen);
+#else
if (cxt->hseen) {
HV *hseen = cxt->hseen;
cxt->hseen = 0;
hv_undef(hseen);
sv_free((SV *) hseen);
}
+#endif
if (cxt->hclass) {
HV *hclass = cxt->hclass;
sv_free((SV *) hook_seen);
}
+ 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);
}
*
* Initialize a new retrieve context for real recursion.
*/
-static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
+static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted)
{
TRACEME(("init_retrieve_context"));
cxt->hook = newHV(); /* Caches STORABLE_thaw */
+#ifdef USE_PTR_TABLE
+ cxt->pseen = 0;
+#endif
+
/*
* If retrieving an old binary version, the cxt->retrieve_vtbl variable
* was set to sv_old_retrieve. We'll need a hash table to keep track of
* 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->where_is_undef = -1; /* Special case for PL_sv_undef */
cxt->aclass = newAV(); /* Where seen classnames are kept */
cxt->tagnum = 0; /* Have to count objects... */
cxt->classnum = 0; /* ...and class names as well */
cxt->optype = optype;
cxt->s_tainted = is_tainted;
cxt->entry = 1; /* No recursion yet */
+#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 */
}
/*
*
* Clean retrieve context by
*/
-static void clean_retrieve_context(stcxt_t *cxt)
+static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
{
TRACEME(("clean_retrieve_context"));
av_undef(aseen);
sv_free((SV *) aseen);
}
+ cxt->where_is_undef = -1;
if (cxt->aclass) {
AV *aclass = cxt->aclass;
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);
}
*
* A workaround for the CROAK bug: cleanup the last context.
*/
-static void clean_context(stcxt_t *cxt)
+static void clean_context(pTHX_ stcxt_t *cxt)
{
TRACEME(("clean_context"));
ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
if (cxt->optype & ST_RETRIEVE)
- clean_retrieve_context(cxt);
+ clean_retrieve_context(aTHX_ cxt);
else if (cxt->optype & ST_STORE)
- clean_store_context(cxt);
+ clean_store_context(aTHX_ cxt);
else
reset_context(cxt);
* Allocate a new context and push it on top of the parent one.
* This new context is made globally visible via SET_STCXT().
*/
-static stcxt_t *allocate_context(parent_cxt)
-stcxt_t *parent_cxt;
+static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt)
{
stcxt_t *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"));
* Free current context, which cannot be the "root" one.
* Make the context underneath globally visible via SET_STCXT().
*/
-static void free_context(cxt)
-stcxt_t *cxt;
+static void free_context(pTHX_ 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"));
*
* Tells whether we're in the middle of a store operation.
*/
-int is_storing(void)
+static int is_storing(pTHX)
{
dSTCXT;
*
* Tells whether we're in the middle of a retrieve operation.
*/
-int is_retrieving(void)
+static int is_retrieving(pTHX)
{
dSTCXT;
* This is typically out-of-band information that might prove useful
* to people wishing to convert native to network order data when used.
*/
-int last_op_in_netorder(void)
+static int last_op_in_netorder(pTHX)
{
dSTCXT;
* nor its ancestors know about the method.
*/
static SV *pkg_fetchmeth(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
{
GV *gv;
SV *sv;
+ const char *hvname = HvNAME_get(pkg);
+
/*
* The following code is the same as the one performed by UNIVERSAL::can
gv = gv_fetchmethod_autoload(pkg, method, FALSE);
if (gv && isGV(gv)) {
sv = newRV((SV*) GvCV(gv));
- TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv)));
+ TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv)));
} else {
sv = newSVsv(&PL_sv_undef);
- TRACEME(("%s->%s: not found", HvNAME(pkg), method));
+ TRACEME(("%s->%s: not found", hvname, method));
}
/*
* it just won't be cached.
*/
- (void) hv_store(cache, HvNAME(pkg), strlen(HvNAME(pkg)), sv, 0);
+ (void) hv_store(cache, hvname, strlen(hvname), sv, 0);
return SvOK(sv) ? sv : (SV *) 0;
}
* Force cached value to be undef: hook ignored even if present.
*/
static void pkg_hide(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
{
+ const char *hvname = HvNAME_get(pkg);
(void) hv_store(cache,
- HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0);
+ hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0);
}
/*
* Discard cached value: a whole fetch loop will be retried at next lookup.
*/
static void pkg_uncache(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
{
- (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD);
+ const char *hvname = HvNAME_get(pkg);
+ (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
}
/*
* know about the method.
*/
static SV *pkg_can(
+ pTHX_
HV *cache,
HV *pkg,
char *method)
{
SV **svh;
SV *sv;
+ const char *hvname = HvNAME_get(pkg);
- TRACEME(("pkg_can for %s->%s", HvNAME(pkg), method));
+ TRACEME(("pkg_can for %s->%s", hvname, method));
/*
* Look into the cache to see whether we already have determined
* that only one hook (i.e. always the same) is cached in a given cache.
*/
- svh = hv_fetch(cache, HvNAME(pkg), strlen(HvNAME(pkg)), FALSE);
+ svh = hv_fetch(cache, hvname, strlen(hvname), FALSE);
if (svh) {
sv = *svh;
if (!SvOK(sv)) {
- TRACEME(("cached %s->%s: not found", HvNAME(pkg), method));
+ TRACEME(("cached %s->%s: not found", hvname, method));
return (SV *) 0;
} else {
TRACEME(("cached %s->%s: 0x%"UVxf,
- HvNAME(pkg), method, PTR2UV(sv)));
+ hvname, method, PTR2UV(sv)));
return sv;
}
}
TRACEME(("not cached yet"));
- return pkg_fetchmeth(cache, pkg, method); /* Fetch and cache */
+ return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */
}
/*
* Propagates the single returned value if not called in void context.
*/
static SV *scalar_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning,
* Returns the list of returned values in an array.
*/
static AV *array_call(
+ pTHX_
SV *obj,
SV *hook,
int cloning)
* Return true if the class was known, false if the ID was just generated.
*/
static int known_class(
+ pTHX_
stcxt_t *cxt,
char *name, /* Class name */
int len, /* Name length */
* Store a reference.
* Layout is SX_REF <object> or SX_OVERLOAD <object>.
*/
-static int store_ref(stcxt_t *cxt, SV *sv)
+static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
{
+ int is_weak = 0;
TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv)));
/*
* Follow reference, and check if target is overloaded.
*/
+#ifdef SvWEAKREF
+ if (SvWEAKREF(sv))
+ is_weak = 1;
+ TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't"));
+#endif
sv = SvRV(sv);
if (SvOBJECT(sv)) {
HV *stash = (HV *) SvSTASH(sv);
if (stash && Gv_AMG(stash)) {
TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv)));
- PUTMARK(SX_OVERLOAD);
+ PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD);
} else
- PUTMARK(SX_REF);
+ PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
} else
- PUTMARK(SX_REF);
+ PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
- return store(cxt, sv);
+ return store(aTHX_ cxt, sv);
}
/*
*
* Store a scalar.
*
- * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <lenght> <data> or SX_UNDEF.
+ * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
* The <data> section is omitted if <length> is 0.
*
* If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
* Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
*/
-static int store_scalar(stcxt_t *cxt, SV *sv)
+static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
{
IV iv;
char *pv;
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:
-
- 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 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:
+
+ /* 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).
+ */
+
+ 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;
- } else if (flags & SVp_NOK) { /* SvNOKp(sv) => double */
- NV 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 below */
- }
+#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
- if (cxt->netorder) {
- TRACEME(("double %"NVff" stored as string", nv));
- pv = SvPV(sv, len);
- goto string; /* Share code above */
- }
+ 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
- PUTMARK(SX_DOUBLE);
- WRITE(&nv, sizeof(nv));
+ SvIV_please(sv);
+ if (SvIOK_notUV(sv)) {
+ iv = SvIV(sv);
+ goto integer; /* Share code above */
+ }
+ nv = SvNV(sv);
+#endif
- TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
+ if (cxt->netorder) {
+ TRACEME(("double %"NVff" stored as string", nv));
+ goto string_readlen; /* Share code below */
+ }
- } else if (flags & SVp_IOK) { /* SvIOKp(sv) => integer */
- iv = SvIV(sv);
+ PUTMARK(SX_DOUBLE);
+ WRITE(&nv, sizeof(nv));
- /*
- * Will come here from above with iv set if double is an integer.
- */
- integer:
+ TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
- /*
- * Optimize small integers into a single byte, otherwise store as
- * a real integer (converted into network order if they asked).
- */
+ } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
+ I32 wlen; /* For 64-bit machines */
- 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));
- }
+ string_readlen:
+ pv = SvPV(sv, len);
- TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
+ /*
+ * 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 */
}
/*
* Layout is SX_ARRAY <size> followed by each item, in increading index order.
* Each item is stored as <object>.
*/
-static int store_array(stcxt_t *cxt, AV *av)
+static int store_array(pTHX_ stcxt_t *cxt, AV *av)
{
SV **sav;
I32 len = av_len(av) + 1;
sav = av_fetch(av, i, 0);
if (!sav) {
TRACEME(("(#%d) undef item", i));
- STORE_UNDEF();
+ STORE_SV_UNDEF();
continue;
}
TRACEME(("(#%d) item", i));
- if ((ret = store(cxt, *sav))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */
return ret;
}
return 0;
}
+
+#if (PATCHLEVEL <= 6)
+
/*
* sortcmp
*
static int
sortcmp(const void *a, const void *b)
{
- return sv_cmp(*(SV * const *) a, *(SV * const *) b);
+#if defined(USE_ITHREADS)
+ dTHX;
+#endif /* USE_ITHREADS */
+ return sv_cmp(*(SV * const *) a, *(SV * const *) b);
}
+#endif /* PATCHLEVEL <= 6 */
/*
* store_hash
*
* Store a hash table.
*
+ * For a "normal" hash (not restricted, no utf8 keys):
+ *
* Layout is SX_HASH <size> followed by each key/value pair, in random order.
* Values are stored as <object>.
* Keys are stored as <length> <data>, the <data> section being omitted
* if length is 0.
+ *
+ * For a "fancy" hash (restricted or utf8 keys):
+ *
+ * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
+ * in random order.
+ * Values are stored as <object>.
+ * Keys are stored as <flags> <length> <data>, the <data> section being omitted
+ * if length is 0.
+ * Currently the only hash flag is "restriced"
+ * Key flags are as for hv.h
*/
-static int store_hash(stcxt_t *cxt, HV *hv)
+static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
{
- I32 len = HvKEYS(hv);
+ dVAR;
+ I32 len =
+#ifdef HAS_RESTRICTED_HASHES
+ HvTOTALKEYS(hv);
+#else
+ HvKEYS(hv);
+#endif
I32 i;
int ret = 0;
I32 riter;
HE *eiter;
+ int flagged_hash = ((SvREADONLY(hv)
+#ifdef HAS_HASH_KEY_FLAGS
+ || HvHASKFLAGS(hv)
+#endif
+ ) ? 1 : 0);
+ unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
- TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv)));
+ if (flagged_hash) {
+ /* needs int cast for C++ compilers, doesn't it? */
+ TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv),
+ (int) hash_flags));
+ } else {
+ TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv)));
+ }
/*
* Signal hash by emitting SX_HASH, followed by the table length.
*/
- PUTMARK(SX_HASH);
+ if (flagged_hash) {
+ PUTMARK(SX_FLAG_HASH);
+ PUTMARK(hash_flags);
+ } else {
+ PUTMARK(SX_HASH);
+ }
WLEN(len);
TRACEME(("size = %d", len));
* Save possible iteration state via each() on that table.
*/
- riter = HvRITER(hv);
- eiter = HvEITER(hv);
+ riter = HvRITER_get(hv);
+ eiter = HvEITER_get(hv);
hv_iterinit(hv);
/*
if (
!(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
(cxt->canonical < 0 && (cxt->canonical =
- SvTRUE(perl_get_sv("Storable::canonical", TRUE)) ? 1 : 0)))
+ (SvTRUE(perl_get_sv("Storable::canonical", TRUE)) ? 1 : 0))))
) {
/*
* Storing in order, sorted by key.
AV *av = newAV();
+ /*av_extend (av, len);*/
+
TRACEME(("using canonical order"));
for (i = 0; i < len; i++) {
+#ifdef HAS_RESTRICTED_HASHES
+ HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
+#else
HE *he = hv_iternext(hv);
+#endif
SV *key = hv_iterkeysv(he);
av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
}
- qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
+ STORE_HASH_SORT;
for (i = 0; i < len; i++) {
+#ifdef HAS_RESTRICTED_HASHES
+ int placeholders = (int)HvPLACEHOLDERS_get(hv);
+#endif
+ unsigned char flags = 0;
char *keyval;
- I32 keylen;
+ STRLEN keylen_tmp;
+ I32 keylen;
SV *key = av_shift(av);
+ /* This will fail if key is a placeholder.
+ Track how many placeholders we have, and error if we
+ "see" too many. */
HE *he = hv_fetch_ent(hv, key, 0, 0);
- SV *val = HeVAL(he);
- if (val == 0)
- return 1; /* Internal error, not I/O error */
+ SV *val;
+
+ if (he) {
+ if (!(val = HeVAL(he))) {
+ /* Internal error, not I/O error */
+ return 1;
+ }
+ } else {
+#ifdef HAS_RESTRICTED_HASHES
+ /* Should be a placeholder. */
+ if (placeholders-- < 0) {
+ /* This should not happen - number of
+ retrieves should be identical to
+ number of placeholders. */
+ return 1;
+ }
+ /* Value is never needed, and PL_sv_undef is
+ more space efficient to store. */
+ val = &PL_sv_undef;
+ ASSERT (flags == 0,
+ ("Flags not 0 but %d", flags));
+ flags = SHV_K_PLACEHOLDER;
+#else
+ return 1;
+#endif
+ }
/*
* Store value first.
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
goto out;
/*
* See retrieve_hash() for details.
*/
- keyval = hv_iterkey(he, &keylen);
- TRACEME(("(#%d) key '%s'", i, keyval));
+ /* Implementation of restricted hashes isn't nicely
+ abstracted: */
+ if ((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) {
+ flags |= SHV_K_LOCKED;
+ }
+
+ keyval = SvPV(key, keylen_tmp);
+ keylen = keylen_tmp;
+#ifdef HAS_UTF8_HASHES
+ /* If you build without optimisation on pre 5.6
+ then nothing spots that SvUTF8(key) is always 0,
+ so the block isn't optimised away, at which point
+ the linker dislikes the reference to
+ bytes_from_utf8. */
+ if (SvUTF8(key)) {
+ const char *keysave = keyval;
+ bool is_utf8 = TRUE;
+
+ /* Just casting the &klen to (STRLEN) won't work
+ well if STRLEN and I32 are of different widths.
+ --jhi */
+ keyval = (char*)bytes_from_utf8((U8*)keyval,
+ &keylen_tmp,
+ &is_utf8);
+
+ /* If we were able to downgrade here, then than
+ means that we have a key which only had chars
+ 0-255, but was utf8 encoded. */
+
+ if (keyval != keysave) {
+ keylen = keylen_tmp;
+ flags |= SHV_K_WASUTF8;
+ } else {
+ /* keylen_tmp can't have changed, so no need
+ to assign back to keylen. */
+ flags |= SHV_K_UTF8;
+ }
+ }
+#endif
+
+ if (flagged_hash) {
+ PUTMARK(flags);
+ TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
+ } else {
+ /* 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);
if (keylen)
WRITE(keyval, keylen);
+ if (flags & SHV_K_WASUTF8)
+ Safefree (keyval);
}
/*
/*
* 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++) {
- char *key;
+ char *key = 0;
I32 len;
- SV *val = hv_iternextsv(hv, &key, &len);
+ unsigned char flags;
+#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
+ HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
+#else
+ HE *he = hv_iternext(hv);
+#endif
+ SV *val = (he ? hv_iterval(hv, he) : 0);
+ SV *key_sv = NULL;
+ HEK *hek;
if (val == 0)
return 1; /* Internal error, not I/O error */
+ /* Implementation of restricted hashes isn't nicely
+ abstracted: */
+ flags
+ = (((hash_flags & SHV_RESTRICTED)
+ && SvREADONLY(val))
+ ? SHV_K_LOCKED : 0);
+
+ if (val == &PL_sv_placeholder) {
+ flags |= SHV_K_PLACEHOLDER;
+ val = &PL_sv_undef;
+ }
+
/*
* Store value first.
*/
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
- if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
goto out;
+
+ hek = HeKEY_hek(he);
+ len = HEK_LEN(hek);
+ if (len == HEf_SVKEY) {
+ /* This is somewhat sick, but the internal APIs are
+ * such that XS code could put one of these in in
+ * a regular hash.
+ * Maybe we should be capable of storing one if
+ * found.
+ */
+ key_sv = HeKEY_sv(he);
+ flags |= SHV_K_ISSV;
+ } else {
+ /* Regular string key. */
+#ifdef HAS_HASH_KEY_FLAGS
+ if (HEK_UTF8(hek))
+ flags |= SHV_K_UTF8;
+ if (HEK_WASUTF8(hek))
+ flags |= SHV_K_WASUTF8;
+#endif
+ key = HEK_KEY(hek);
+ }
/*
* Write key string.
* Keys are written after values to make sure retrieval
* See retrieve_hash() for details.
*/
- TRACEME(("(#%d) key '%s'", i, key));
- WLEN(len);
- if (len)
+ if (flagged_hash) {
+ PUTMARK(flags);
+ TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
+ } else {
+ /* 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(aTHX_ cxt, key_sv);
+ } else {
+ WLEN(len);
+ if (len)
WRITE(key, len);
+ }
}
}
TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv)));
out:
- HvRITER(hv) = riter; /* Restore hash iterator state */
- HvEITER(hv) = eiter;
+ HvRITER_set(hv, riter); /* Restore hash iterator state */
+ HvEITER_set(hv, eiter);
return ret;
}
/*
+ * 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(pTHX_ stcxt_t *cxt, CV *cv)
+{
+#if PERL_VERSION < 6
+ /*
+ * retrieve_code does not work with perl 5.005 or less
+ */
+ return store_other(aTHX_ 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(aTHX_ cxt, (SV*)cv);
+ }
+
+ /*
+ * Require B::Deparse. At least B::Deparse 0.61 is needed for
+ * blessed code references.
+ */
+ /* Ownership of both SVs is passed to load_module, which frees them. */
+ 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 = SvCUR(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
* dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
* <hash object> stands for the serialization of the tied hash.
*/
-static int store_tied(stcxt_t *cxt, SV *sv)
+static int store_tied(pTHX_ 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(aTHX_ cxt, obj)))
return ret;
TRACEME(("ok (tied)"));
* SX_TIED_KEY <object> <key>
* SX_TIED_IDX <object> <index>
*/
-static int store_tied_item(stcxt_t *cxt, SV *sv)
+static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv)
{
MAGIC *mg;
int ret;
PUTMARK(SX_TIED_KEY);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
- if ((ret = store(cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
+ if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
return ret;
} else {
I32 idx = mg->mg_len;
PUTMARK(SX_TIED_IDX);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
- if ((ret = store(cxt, mg->mg_obj))) /* Idem, for -Wall */
+ if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */
return ret;
TRACEME(("store_tied_item: storing IDX %d", idx));
* any other tied variable.
*/
static int store_hook(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
SV *hook)
{
I32 len;
- char *class;
+ char *classname;
STRLEN len2;
SV *ref;
AV *av;
char mtype = '\0'; /* for blessed ref to tied structures */
unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
- TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
+ TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum));
/*
* Determine object type on 2 bits.
}
flags = SHF_NEED_RECURSE | obj_type;
- class = HvNAME(pkg);
- len = strlen(class);
+ classname = HvNAME_get(pkg);
+ len = strlen(classname);
/*
* To call the hook, we need to fake a call like:
* make the call on that reference.
*/
- TRACEME(("about to call STORABLE_freeze on class %s", class));
+ TRACEME(("about to call STORABLE_freeze on class %s", classname));
ref = newRV_noinc(sv); /* Temporary reference */
- av = array_call(ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
- SvRV(ref) = 0;
+ av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
+ SvRV_set(ref, NULL);
SvREFCNT_dec(ref); /* Reclaim temporary reference */
count = AvFILLp(av) + 1;
* They must not change their mind in the middle of a serialization.
*/
- if (hv_fetch(cxt->hclass, class, len, FALSE))
+ if (hv_fetch(cxt->hclass, classname, len, FALSE))
CROAK(("Too late to ignore hooks for %s class \"%s\"",
- (cxt->optype & ST_CLONE) ? "cloning" : "storing", class));
+ (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname));
- pkg_hide(cxt->hook, pkg, "STORABLE_freeze");
+ pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
- ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
- TRACEME(("ignoring STORABLE_freeze in class \"%s\"", class));
+ ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
+ TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname));
- return store_blessed(cxt, sv, type, pkg);
+ return store_blessed(aTHX_ cxt, sv, type, pkg);
}
/*
ary = AvARRAY(av);
pv = SvPV(ary[0], len2);
+ /* We can't use pkg_can here because it only caches one method per
+ * package */
+ {
+ GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
+ if (gv && isGV(gv)) {
+ if (count > 1)
+ CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
+ goto check_done;
+ }
+ }
/*
* 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.
*/
for (i = 1; i < count; i++) {
+#ifdef USE_PTR_TABLE
+ char *fake_tag;
+#else
SV **svh;
+#endif
SV *rsv = ary[i];
SV *xsv;
+ SV *tag;
AV *av_hook = cxt->hook_seen;
if (!SvROK(rsv))
CROAK(("Item #%d returned by STORABLE_freeze "
- "for %s is not a reference", i, class));
+ "for %s is not a reference", i, classname));
xsv = SvRV(rsv); /* Follow ref to know what to look for */
/*
* Look in hseen and see if we have a tag already.
* Serialize entry if not done already, and get its tag.
*/
-
+
+#ifdef USE_PTR_TABLE
+ /* Fakery needed because ptr_table_fetch returns zero for a
+ failure, whereas the existing code assumes that it can
+ safely store a tag zero. So for ptr_tables we store tag+1
+ */
+ if ((fake_tag = ptr_table_fetch(cxt->pseen, xsv)))
+ goto sv_seen; /* Avoid moving code too far to the right */
+#else
if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
goto sv_seen; /* Avoid moving code too far to the right */
+#endif
TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
} else
PUTMARK(flags);
- if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
+ if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */
return ret;
+#ifdef USE_PTR_TABLE
+ fake_tag = ptr_table_fetch(cxt->pseen, xsv);
+ if (!sv)
+ CROAK(("Could not serialize item #%d from hook in %s", i, classname));
+#else
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
if (!svh)
- CROAK(("Could not serialize item #%d from hook in %s", i, class));
-
+ CROAK(("Could not serialize item #%d from hook in %s", i, classname));
+#endif
/*
* It was the first time we serialized `xsv'.
*
* Replace entry with its tag (not a real SV, so no refcnt increment)
*/
- ary[i] = *svh;
+#ifdef USE_PTR_TABLE
+ tag = (SV *)--fake_tag;
+#else
+ tag = *svh;
+#endif
+ ary[i] = tag;
TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
- i-1, PTR2UV(xsv), PTR2UV(*svh)));
+ i-1, PTR2UV(xsv), PTR2UV(tag)));
}
/*
* 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));
+check_done:
+ if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
+ TRACEME(("first time we see class %s, ID = %d", classname, classnum));
classnum = -1; /* Mark: we must store classname */
} else {
- TRACEME(("already seen class %s, ID = %d", class, classnum));
+ TRACEME(("already seen class %s, ID = %d", classname, classnum));
}
/*
unsigned char clen = (unsigned char) len;
PUTMARK(clen);
}
- WRITE(class, len); /* Final \0 is omitted */
+ WRITE(classname, len); /* Final \0 is omitted */
}
/* <len2> <frozen-str> */
PUTMARK(clen);
}
if (len2)
- WRITE(pv, len2); /* Final \0 is omitted */
+ WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */
/* [<len3> <object-IDs>] */
if (flags & SHF_HAS_LIST) {
* [<magic object>]
*/
- if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
+ if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
}
* on the high-order bit in flag (same encoding as above for <len>).
*/
static int store_blessed(
+ pTHX_
stcxt_t *cxt,
SV *sv,
int type,
{
SV *hook;
I32 len;
- char *class;
+ char *classname;
I32 classnum;
- TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME(pkg)));
+ TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg)));
/*
* Look for a hook for this blessed SV and redirect to store_hook()
* if needed.
*/
- hook = pkg_can(cxt->hook, pkg, "STORABLE_freeze");
+ hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
if (hook)
- return store_hook(cxt, sv, type, pkg, hook);
+ return store_hook(aTHX_ cxt, sv, type, pkg, hook);
/*
* This is a blessed SV without any serialization hook.
*/
- class = HvNAME(pkg);
- len = strlen(class);
+ classname = HvNAME_get(pkg);
+ len = strlen(classname);
TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d",
- PTR2UV(sv), class, cxt->tagnum));
+ PTR2UV(sv), classname, cxt->tagnum));
/*
* Determine whether it is the first time we see that class name (in which
* used).
*/
- if (known_class(cxt, class, len, &classnum)) {
- TRACEME(("already seen class %s, ID = %d", class, classnum));
+ if (known_class(aTHX_ cxt, classname, len, &classnum)) {
+ TRACEME(("already seen class %s, ID = %d", classname, classnum));
PUTMARK(SX_IX_BLESS);
if (classnum <= LG_BLESS) {
unsigned char cnum = (unsigned char) classnum;
WLEN(classnum);
}
} else {
- TRACEME(("first time we see class %s, ID = %d", class, classnum));
+ TRACEME(("first time we see class %s, ID = %d", classname, classnum));
PUTMARK(SX_BLESS);
if (len <= LG_BLESS) {
unsigned char clen = (unsigned char) len;
PUTMARK(flag);
WLEN(len); /* Don't BER-encode, this should be rare */
}
- WRITE(class, len); /* Final \0 is omitted */
+ WRITE(classname, len); /* Final \0 is omitted */
}
/*
* Now emit the <object> part.
*/
- return SV_STORE(type)(cxt, sv);
+ return SV_STORE(type)(aTHX_ cxt, sv);
}
/*
* true value, then don't croak, just warn, and store a placeholder string
* instead.
*/
-static int store_other(stcxt_t *cxt, SV *sv)
+static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
{
I32 len;
- static char buf[80];
+ char buf[80];
TRACEME(("store_other"));
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;
}
* Returns the type of the SV, identified by an integer. That integer
* may then be used to index the dynamic routine dispatch table.
*/
-static int sv_type(SV *sv)
+static int sv_type(pTHX_ SV *sv)
{
switch (SvTYPE(sv)) {
case SVt_NULL:
if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
return svis_TIED;
return svis_HASH;
+ case SVt_PVCV:
+ return svis_CODE;
default:
break;
}
* object (one for which storage has started -- it may not be over if we have
* a self-referenced structure). This data set forms a stored <object>.
*/
-static int store(stcxt_t *cxt, SV *sv)
+static int store(pTHX_ stcxt_t *cxt, SV *sv)
{
SV **svh;
int ret;
int type;
+#ifdef USE_PTR_TABLE
+ struct ptr_tbl *pseen = cxt->pseen;
+#else
HV *hseen = cxt->hseen;
+#endif
TRACEME(("store (0x%"UVxf")", PTR2UV(sv)));
*
* 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
*/
+#ifdef USE_PTR_TABLE
+ svh = ptr_table_fetch(pseen, sv);
+#else
svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
+#endif
if (svh) {
- I32 tagval = htonl(LOW_32BITS(*svh));
+ I32 tagval;
+
+ if (sv == &PL_sv_undef) {
+ /* We have seen PL_sv_undef before, but fake it as
+ if we have not.
+
+ Not the simplest solution to making restricted
+ hashes work on 5.8.0, but it does mean that
+ repeated references to the one true undef will
+ take up less space in the output file.
+ */
+ /* Need to jump past the next hv_store, because on the
+ second store of undef the old hash value will be
+ SvREFCNT_dec()ed, and as Storable cheats horribly
+ by storing non-SVs in the hash a SEGV will ensure.
+ Need to increase the tag number so that the
+ receiver has no idea what games we're up to. This
+ special casing doesn't affect hooks that store
+ undef, as the hook routine does its own lookup into
+ hseen. Also this means that any references back
+ to PL_sv_undef (from the pathological case of hooks
+ storing references to it) will find the seen hash
+ entry for the first time, as if we didn't have this
+ hackery here. (That hseen lookup works even on 5.8.0
+ because it's a key of &PL_sv_undef and a value
+ which is a tag number, not a value which is
+ PL_sv_undef.) */
+ cxt->tagnum++;
+ type = svis_SCALAR;
+ goto undef_special_case;
+ }
+
+#ifdef USE_PTR_TABLE
+ tagval = htonl(LOW_32BITS(((char *)svh)-1));
+#else
+ tagval = htonl(LOW_32BITS(*svh));
+#endif
TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval)));
*/
cxt->tagnum++;
+#ifdef USE_PTR_TABLE
+ ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum));
+#else
if (!hv_store(hseen,
(char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0))
return -1;
+#endif
/*
* Store `sv' and everything beneath it, using appropriate routine.
* Abort immediately if we get a non-zero status back.
*/
- type = sv_type(sv);
+ type = sv_type(aTHX_ sv);
+undef_special_case:
TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
PTR2UV(sv), cxt->tagnum, type));
if (SvOBJECT(sv)) {
HV *pkg = SvSTASH(sv);
- ret = store_blessed(cxt, sv, type, pkg);
+ ret = store_blessed(aTHX_ cxt, sv, type, pkg);
} else
- ret = SV_STORE(type)(cxt, sv);
+ ret = SV_STORE(type)(aTHX_ cxt, sv);
TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)",
ret ? "FAILED" : "ok", PTR2UV(sv),
* Note that no byte ordering info is emitted when <network> is true, since
* integers will be emitted in network order in that case.
*/
-static int magic_write(stcxt_t *cxt)
+static int magic_write(pTHX_ 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 ? fileno(cxt->fio) : -1));
-
- if (cxt->fio)
- WRITE(magicstr, 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.
- */
-
- PUTMARK((unsigned char) STORABLE_BIN_MINOR);
+ /*
+ * 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.
+ */
+
+ /* 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, (unsigned int) 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;
}
/*
* dclone() and store() is performed to memory.
*/
static int do_store(
+ pTHX_
PerlIO *f,
SV *sv,
int optype,
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
/*
* Ensure sv is actually a reference. From perl, we called something
* like:
- * pstore(FILE, \@array);
+ * pstore(aTHX_ FILE, \@array);
* so we must get the scalar value behing that reference.
*/
* Prepare context and emit headers.
*/
- init_store_context(cxt, f, optype, network_order);
+ init_store_context(aTHX_ cxt, f, optype, network_order);
- if (-1 == magic_write(cxt)) /* Emit magic and ILP info */
+ if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */
return 0; /* Error */
/*
* Recursively store object...
*/
- ASSERT(is_storing(), ("within store operation"));
+ ASSERT(is_storing(aTHX), ("within store operation"));
- status = store(cxt, sv); /* Just do it! */
+ status = store(aTHX_ cxt, sv); /* Just do it! */
/*
* If they asked for a memory store and they provided an SV pointer,
*/
if (!cxt->fio && res)
- *res = mbuf2sv();
+ *res = mbuf2sv(aTHX);
/*
* Final cleanup.
* about to enter do_retrieve...
*/
- clean_store_context(cxt);
+ clean_store_context(aTHX_ cxt);
if (cxt->prev && !(cxt->optype & ST_CLONE))
- free_context(cxt);
+ free_context(aTHX_ cxt);
TRACEME(("do_store returns %d", status));
* Store the transitive data closure of given object to disk.
* Returns 0 on error, a true value otherwise.
*/
-int pstore(PerlIO *f, SV *sv)
+static int pstore(pTHX_ PerlIO *f, SV *sv)
{
TRACEME(("pstore"));
- return do_store(f, sv, 0, FALSE, (SV**) 0);
+ return do_store(aTHX_ f, sv, 0, FALSE, (SV**) 0);
}
* Same as pstore(), but network order is used for integers and doubles are
* emitted as strings.
*/
-int net_pstore(PerlIO *f, SV *sv)
+static int net_pstore(pTHX_ PerlIO *f, SV *sv)
{
TRACEME(("net_pstore"));
- return do_store(f, sv, 0, TRUE, (SV**) 0);
+ return do_store(aTHX_ f, sv, 0, TRUE, (SV**) 0);
}
/***
*
* Build a new SV out of the content of the internal memory buffer.
*/
-static SV *mbuf2sv(void)
+static SV *mbuf2sv(pTHX)
{
dSTCXT;
* Store the transitive data closure of given object to memory.
* Returns undef on error, a scalar value containing the data otherwise.
*/
-SV *mstore(SV *sv)
+static SV *mstore(pTHX_ SV *sv)
{
SV *out;
TRACEME(("mstore"));
- if (!do_store((PerlIO*) 0, sv, 0, FALSE, &out))
+ if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, FALSE, &out))
return &PL_sv_undef;
return out;
* Same as mstore(), but network order is used for integers and doubles are
* emitted as strings.
*/
-SV *net_mstore(SV *sv)
+static SV *net_mstore(pTHX_ SV *sv)
{
SV *out;
TRACEME(("net_mstore"));
- if (!do_store((PerlIO*) 0, sv, 0, TRUE, &out))
+ if (!do_store(aTHX_ (PerlIO*) 0, sv, 0, TRUE, &out))
return &PL_sv_undef;
return out;
* Return an error via croak, since it is not possible that we get here
* under normal conditions, when facing a file produced via pstore().
*/
-static SV *retrieve_other(stcxt_t *cxt, char *cname)
+static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname)
{
if (
cxt->ver_major != STORABLE_BIN_MAJOR &&
* Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
* <index> can be coded on either 1 or 5 bytes.
*/
-static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname)
+static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 idx;
- char *class;
+ const char *classname;
SV **sva;
SV *sv;
if (!sva)
CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
- class = SvPVX(*sva); /* We know it's a PV, by construction */
+ classname = SvPVX(*sva); /* We know it's a PV, by construction */
- TRACEME(("class ID %d => %s", idx, class));
+ TRACEME(("class ID %d => %s", idx, classname));
/*
* Retrieve object and bless it.
*/
- sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
+ sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */
return sv;
}
* Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
* <len> can be coded on either 1 or 5 bytes.
*/
-static SV *retrieve_blessed(stcxt_t *cxt, char *cname)
+static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
SV *sv;
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
- char *class = buf;
+ char *classname = buf;
TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
ASSERT(!cname, ("no bless-into class given here, got %s", cname));
if (len & 0x80) {
RLEN(len);
TRACEME(("** allocating %d bytes for class name", len+1));
- New(10003, class, len+1, char);
+ New(10003, classname, len+1, char);
}
- READ(class, len);
- class[len] = '\0'; /* Mark string end */
+ READ(classname, len);
+ classname[len] = '\0'; /* Mark string end */
/*
* It's a new classname, otherwise it would have been an SX_IX_BLESS.
*/
- TRACEME(("new class name \"%s\" will bear ID = %d", class, cxt->classnum));
+ TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum));
- if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
+ if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len)))
return (SV *) 0;
/*
* Retrieve object and bless it.
*/
- sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
- if (class != buf)
- Safefree(class);
+ sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */
+ if (classname != buf)
+ Safefree(classname);
return sv;
}
* processing (since we won't have seen the magic object by the time the hook
* is called). See comments below for why it was done that way.
*/
-static SV *retrieve_hook(stcxt_t *cxt, char *cname)
+static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
- char *class = buf;
+ char *classname = buf;
unsigned int flags;
I32 len2;
SV *frozen;
SV *hook;
SV *sv;
SV *rv;
+ GV *attach;
int obj_type;
int clone = cxt->optype & ST_CLONE;
char mtype = '\0';
mtype = 'P';
break;
default:
- return retrieve_other(cxt, 0); /* Let it croak */
+ return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
}
break;
default:
- return retrieve_other(cxt, 0); /* Let it croak */
+ return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
}
- SEEN(sv, 0); /* Don't bless yet */
+ SEEN(sv, 0, 0); /* Don't bless yet */
/*
* Whilst flags tell us to recurse, do so.
* 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) {
TRACEME(("retrieve_hook recursing..."));
- rv = retrieve(cxt, 0);
+ rv = retrieve(aTHX_ cxt, 0);
if (!rv)
return (SV *) 0;
+ SvREFCNT_dec(rv);
TRACEME(("retrieve_hook back with rv=0x%"UVxf,
PTR2UV(rv)));
GETMARK(flags);
CROAK(("Class name #%"IVdf" should have been seen already",
(IV) idx));
- class = SvPVX(*sva); /* We know it's a PV, by construction */
- TRACEME(("class ID %d => %s", idx, class));
+ classname = SvPVX(*sva); /* We know it's a PV, by construction */
+ TRACEME(("class ID %d => %s", idx, classname));
} else {
/*
if (len > LG_BLESS) {
TRACEME(("** allocating %d bytes for class name", len+1));
- New(10003, class, len+1, char);
+ New(10003, classname, len+1, char);
}
- READ(class, len);
- class[len] = '\0'; /* Mark string end */
+ READ(classname, len);
+ classname[len] = '\0'; /* Mark string end */
/*
* Record new classname.
*/
- if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
+ if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len)))
return (SV *) 0;
}
- TRACEME(("class name: %s", class));
+ TRACEME(("class name: %s", classname));
/*
* Decode user-frozen string length and read it in an SV.
READ_I32(tag);
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
- if (!svh)
- CROAK(("Object #%"IVdf" should have been retrieved already",
- (IV) tag));
+ if (!svh) {
+ if (tag == cxt->where_is_undef) {
+ /* av_fetch uses PL_sv_undef internally, hence this
+ somewhat gruesome hack. */
+ xsv = &PL_sv_undef;
+ svh = &xsv;
+ } else {
+ CROAK(("Object #%"IVdf" should have been retrieved already",
+ (IV) tag));
+ }
+ }
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
* Bless the object and look up the STORABLE_thaw hook.
*/
- BLESS(sv, class);
- hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ BLESS(sv, classname);
+
+ /* Handle attach case; again can't use pkg_can because it only
+ * caches one method */
+ attach = gv_fetchmethod_autoload(SvSTASH(sv), "STORABLE_attach", FALSE);
+ if (attach && isGV(attach)) {
+ SV* attached;
+ SV* attach_hook = newRV((SV*) GvCV(attach));
+
+ if (av)
+ CROAK(("STORABLE_attach called with unexpected references"));
+ av = newAV();
+ av_extend(av, 1);
+ AvFILLp(av) = 0;
+ AvARRAY(av)[0] = SvREFCNT_inc(frozen);
+ rv = newSVpv(classname, 0);
+ attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
+ if (attached &&
+ SvROK(attached) &&
+ sv_derived_from(attached, classname))
+ return SvRV(attached);
+ CROAK(("STORABLE_attach did not return a %s object", classname));
+ }
+
+ hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
if (!hook) {
/*
* Hook not found. Maybe they did not require the module where this
*/
SV *psv = newSVpvn("require ", 8);
- sv_catpv(psv, class);
+ sv_catpv(psv, classname);
- TRACEME(("No STORABLE_thaw defined for objects of class %s", class));
- TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv)));
+ TRACEME(("No STORABLE_thaw defined for objects of class %s", classname));
+ TRACEME(("Going to require module '%s' with '%s'", classname, SvPVX(psv)));
perl_eval_sv(psv, G_DISCARD);
sv_free(psv);
* the lookup again.
*/
- pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
- hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ hook = pkg_can(aTHX_ 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));
+ "(even after a \"require %s;\")", classname, classname));
}
/*
*/
TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)",
- class, PTR2UV(sv), AvFILLp(av) + 1));
+ classname, PTR2UV(sv), (IV) AvFILLp(av) + 1));
rv = newRV(sv);
- (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
+ (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD);
SvREFCNT_dec(rv);
/*
SvREFCNT_dec(frozen);
av_undef(av);
sv_free((SV *) av);
- if (!(flags & SHF_IDX_CLASSNAME) && class != buf)
- Safefree(class);
+ if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
+ Safefree(classname);
/*
* If we had an <extra> type, then the object was not as simple, and
TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
- rv = retrieve(cxt, 0); /* Retrieve <magic object> */
+ rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */
TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
PTR2UV(rv), PTR2UV(sv)));
* Retrieve reference to some other scalar.
* Layout is SX_REF <object>, with SX_REF already read.
*/
-static SV *retrieve_ref(stcxt_t *cxt, char *cname)
+static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *rv;
SV *sv;
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(rv, cname, 0); /* Will return if rv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* an SX_OBJECT indication, a ref count increment was done.
*/
- sv_upgrade(rv, SVt_RV);
- SvRV(rv) = sv; /* $rv = \$sv */
+ if (cname) {
+ /* No need to do anything, as rv will already be PVMG. */
+ assert (SvTYPE(rv) >= SVt_RV);
+ } else {
+ sv_upgrade(rv, SVt_RV);
+ }
+
+ SvRV_set(rv, sv); /* $rv = \$sv */
SvROK_on(rv);
TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv)));
}
/*
+ * retrieve_weakref
+ *
+ * Retrieve weak reference to some other scalar.
+ * Layout is SX_WEAKREF <object>, with SX_WEAKREF already read.
+ */
+static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_weakref (#%d)", cxt->tagnum));
+
+ sv = retrieve_ref(aTHX_ cxt, cname);
+ if (sv) {
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ WEAKREF_CROAK();
+#endif
+ }
+ return sv;
+}
+
+/*
* retrieve_overloaded
*
* Retrieve reference to some other scalar with overloading.
* Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
*/
-static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
+static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *rv;
SV *sv;
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname); /* Will return if rv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(rv, cname, 0); /* Will return if rv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
*/
sv_upgrade(rv, SVt_RV);
- SvRV(rv) = sv; /* $rv = \$sv */
+ SvRV_set(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)",
+ stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0;
+ if (!stash) {
+ CROAK(("Cannot restore overloading on %s(0x%"UVxf
+ ") (package <unknown>)",
sv_reftype(sv, FALSE),
- PTR2UV(sv),
- stash ? HvNAME(stash) : "<unknown>"));
+ PTR2UV(sv)));
+ }
+ if (!Gv_AMG(stash)) {
+ SV *psv = newSVpvn("require ", 8);
+ const char *package = HvNAME_get(stash);
+ sv_catpv(psv, package);
+
+ TRACEME(("No overloading defined for package %s", package));
+ TRACEME(("Going to require module '%s' with '%s'", package, SvPVX(psv)));
+
+ perl_eval_sv(psv, G_DISCARD);
+ sv_free(psv);
+ if (!Gv_AMG(stash)) {
+ CROAK(("Cannot restore overloading on %s(0x%"UVxf
+ ") (package %s) (even after a \"require %s;\")",
+ sv_reftype(sv, FALSE),
+ PTR2UV(sv),
+ package, package));
+ }
+ }
SvAMAGIC_on(rv);
}
/*
+ * retrieve_weakoverloaded
+ *
+ * Retrieve weak overloaded reference to some other scalar.
+ * Layout is SX_WEAKOVERLOADED <object>, with SX_WEAKOVERLOADED already read.
+ */
+static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname)
+{
+ SV *sv;
+
+ TRACEME(("retrieve_weakoverloaded (#%d)", cxt->tagnum));
+
+ sv = retrieve_overloaded(aTHX_ cxt, cname);
+ if (sv) {
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ WEAKREF_CROAK();
+#endif
+ }
+ return sv;
+}
+
+/*
* retrieve_tied_array
*
* Retrieve tied array
* Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
*/
-static SV *retrieve_tied_array(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied hash
* Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
*/
-static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* Retrieve tied scalar
* Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
*/
-static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const 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)
+ SEEN(tv, cname, 0); /* Will return if rv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
+ 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)));
* Retrieve reference to value in a tied hash.
* Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
*/
-static SV *retrieve_tied_key(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
- key = retrieve(cxt, 0); /* Retrieve <key> */
+ key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */
if (!key)
return (SV *) 0; /* Failed */
* Retrieve reference to value in a tied array.
* Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
*/
-static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname); /* Will return if tv is null */
- sv = retrieve(cxt, 0); /* Retrieve <object> */
+ SEEN(tv, cname, 0); /* Will return if tv is null */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
* The scalar is "long" in that <length> is larger than LG_SCALAR so it
* was not stored on a single byte.
*/
-static SV *retrieve_lscalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
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.
*/
sv = NEWSV(10002, len);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+
+ if (len == 0) {
+ sv_setpvn(sv, "", 0);
+ return sv;
+ }
/*
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
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;
* The scalar is "short" so <length> is single byte. If it is 0, there
* is no <data> section.
*/
-static SV *retrieve_scalar(stcxt_t *cxt, char *cname)
+static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname)
{
int len;
SV *sv;
*/
sv = NEWSV(10002, len);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
/*
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
/*
* newSV did not upgrade to SVt_PV so the scalar is undefined.
* To make it defined with an empty length, upgrade it now...
+ * Don't upgrade to a PV if the original type contains more
+ * information than a scalar.
*/
- sv_upgrade(sv, SVt_PV);
+ if (SvTYPE(sv) <= SVt_PV) {
+ sv_upgrade(sv, SVt_PV);
+ }
SvGROW(sv, 1);
*SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */
TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv)));
* 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, char *cname)
+static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname)
{
- SV *sv;
+ SV *sv;
- TRACEME(("retrieve_utf8str"));
+ TRACEME(("retrieve_utf8str"));
- sv = retrieve_scalar(cxt, cname);
- if (sv)
- SvUTF8_on(sv);
+ sv = retrieve_scalar(aTHX_ cxt, cname);
+ if (sv) {
+#ifdef HAS_UTF8_SCALARS
+ SvUTF8_on(sv);
+#else
+ if (cxt->use_bytes < 0)
+ cxt->use_bytes
+ = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+ ? 1 : 0);
+ if (cxt->use_bytes == 0)
+ UTF8_CROAK();
+#endif
+ }
- return sv;
+ return sv;
}
/*
* 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, char *cname)
+static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname)
{
- SV *sv;
+ SV *sv;
- TRACEME(("retrieve_lutf8str"));
+ TRACEME(("retrieve_lutf8str"));
- sv = retrieve_lscalar(cxt, cname);
- if (sv)
- SvUTF8_on(sv);
-
- return sv;
+ sv = retrieve_lscalar(aTHX_ cxt, cname);
+ if (sv) {
+#ifdef HAS_UTF8_SCALARS
+ SvUTF8_on(sv);
+#else
+ if (cxt->use_bytes < 0)
+ cxt->use_bytes
+ = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+ ? 1 : 0);
+ if (cxt->use_bytes == 0)
+ UTF8_CROAK();
+#endif
+ }
+ return sv;
}
/*
* Retrieve defined integer.
* Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
*/
-static SV *retrieve_integer(stcxt_t *cxt, char *cname)
+static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
IV iv;
READ(&iv, sizeof(iv));
sv = newSViv(iv);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("integer %"IVdf, iv));
TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv)));
* Retrieve defined integer in network order.
* Layout is SX_NETINT <data>, whith SX_NETINT already read.
*/
-static SV *retrieve_netint(stcxt_t *cxt, char *cname)
+static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
I32 iv;
sv = newSViv(iv);
TRACEME(("network integer (as-is) %d", iv));
#endif
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv)));
* Retrieve defined double.
* Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
*/
-static SV *retrieve_double(stcxt_t *cxt, char *cname)
+static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
NV nv;
READ(&nv, sizeof(nv));
sv = newSVnv(nv);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("double %"NVff, nv));
TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv)));
* Retrieve defined byte (small integer within the [-128, +127] range).
* Layout is SX_BYTE <data>, whith SX_BYTE already read.
*/
-static SV *retrieve_byte(stcxt_t *cxt, char *cname)
+static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
int siv;
TRACEME(("small integer read as %d", (unsigned char) siv));
tmp = (unsigned char) siv - 128;
sv = newSViv(tmp);
- SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
+ SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("byte %d", tmp));
TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv)));
*
* Return the undefined value.
*/
-static SV *retrieve_undef(stcxt_t *cxt, char *cname)
+static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname)
{
SV* sv;
TRACEME(("retrieve_undef"));
sv = newSV(0);
- SEEN(sv, cname);
+ SEEN(sv, cname, 0);
return sv;
}
*
* Return the immortal undefined value.
*/
-static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_undef;
TRACEME(("retrieve_sv_undef"));
- SEEN(sv, cname);
+ /* Special case PL_sv_undef, as av_fetch uses it internally to mark
+ deleted elements, and will return NULL (fetch failed) whenever it
+ is fetched. */
+ if (cxt->where_is_undef == -1) {
+ cxt->where_is_undef = cxt->tagnum;
+ }
+ SEEN(sv, cname, 1);
return sv;
}
*
* Return the immortal yes value.
*/
-static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_yes;
TRACEME(("retrieve_sv_yes"));
- SEEN(sv, cname);
+ SEEN(sv, cname, 1);
return sv;
}
*
* Return the immortal no value.
*/
-static SV *retrieve_sv_no(stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_no;
TRACEME(("retrieve_sv_no"));
- SEEN(sv, cname);
+ SEEN(sv, cname, 1);
return sv;
}
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *retrieve_array(stcxt_t *cxt, char *cname)
+static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 i;
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av, cname); /* Will return if array not allocated nicely */
+ SEEN(av, cname, 0); /* Will return if array not allocated nicely */
if (len)
av_extend(av, len);
else
for (i = 0; i < len; i++) {
TRACEME(("(#%d) item", i));
- sv = retrieve(cxt, 0); /* Retrieve item */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
if (!sv)
return (SV *) 0;
if (av_store(av, i, sv) == 0)
*
* When we come here, SX_HASH has been read already.
*/
-static SV *retrieve_hash(stcxt_t *cxt, char *cname)
+static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 size;
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv, cname); /* Will return if table not allocated properly */
+ SEEN(hv, cname, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */
*/
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
*/
RLEN(size); /* Get key size */
- KBUFCHK(size); /* Grow hash key read pool if needed */
+ KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
if (size)
READ(kbuf, size);
kbuf[size] = '\0'; /* Mark string end, just in case */
}
/*
+ * retrieve_hash
+ *
+ * Retrieve a whole hash table.
+ * Layout is SX_HASH <size> followed by each key/value pair, in random order.
+ * Keys are stored as <length> <data>, the <data> section being omitted
+ * if length is 0.
+ * Values are stored as <object>.
+ *
+ * When we come here, SX_HASH has been read already.
+ */
+static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
+{
+ dVAR;
+ I32 len;
+ I32 size;
+ I32 i;
+ HV *hv;
+ SV *sv;
+ int hash_flags;
+
+ GETMARK(hash_flags);
+ TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum));
+ /*
+ * Read length, allocate table.
+ */
+
+#ifndef HAS_RESTRICTED_HASHES
+ if (hash_flags & SHV_RESTRICTED) {
+ if (cxt->derestrict < 0)
+ cxt->derestrict
+ = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", TRUE))
+ ? 1 : 0);
+ if (cxt->derestrict == 0)
+ RESTRICTED_HASH_CROAK();
+ }
+#endif
+
+ RLEN(len);
+ TRACEME(("size = %d, flags = %d", len, hash_flags));
+ hv = newHV();
+ SEEN(hv, cname, 0); /* Will return if table not allocated properly */
+ if (len == 0)
+ return (SV *) hv; /* No data follow if table empty */
+ hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */
+
+ /*
+ * Now get each key/value pair in turn...
+ */
+
+ for (i = 0; i < len; i++) {
+ int flags;
+ int store_flags = 0;
+ /*
+ * Get value first.
+ */
+
+ TRACEME(("(#%d) value", i));
+ sv = retrieve(aTHX_ cxt, 0);
+ if (!sv)
+ return (SV *) 0;
+
+ GETMARK(flags);
+#ifdef HAS_RESTRICTED_HASHES
+ if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED))
+ SvREADONLY_on(sv);
+#endif
+
+ if (flags & SHV_K_ISSV) {
+ /* XXX you can't set a placeholder with an SV key.
+ Then again, you can't get an SV key.
+ Without messing around beyond what the API is supposed to do.
+ */
+ SV *keysv;
+ TRACEME(("(#%d) keysv, flags=%d", i, flags));
+ keysv = retrieve(aTHX_ cxt, 0);
+ if (!keysv)
+ return (SV *) 0;
+
+ if (!hv_store_ent(hv, keysv, sv, 0))
+ return (SV *) 0;
+ } else {
+ /*
+ * Get key.
+ * Since we're reading into kbuf, we must ensure we're not
+ * recursing between the read and the hv_store() where it's used.
+ * Hence the key comes after the value.
+ */
+
+ if (flags & SHV_K_PLACEHOLDER) {
+ SvREFCNT_dec (sv);
+ sv = &PL_sv_placeholder;
+ store_flags |= HVhek_PLACEHOLD;
+ }
+ if (flags & SHV_K_UTF8) {
+#ifdef HAS_UTF8_HASHES
+ store_flags |= HVhek_UTF8;
+#else
+ if (cxt->use_bytes < 0)
+ cxt->use_bytes
+ = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+ ? 1 : 0);
+ if (cxt->use_bytes == 0)
+ UTF8_CROAK();
+#endif
+ }
+#ifdef HAS_UTF8_HASHES
+ if (flags & SHV_K_WASUTF8)
+ store_flags |= HVhek_WASUTF8;
+#endif
+
+ RLEN(size); /* Get key size */
+ KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
+ if (size)
+ READ(kbuf, size);
+ kbuf[size] = '\0'; /* Mark string end, just in case */
+ TRACEME(("(#%d) key '%s' flags %X store_flags %X", i, kbuf,
+ flags, store_flags));
+
+ /*
+ * Enter key/value pair into hash table.
+ */
+
+#ifdef HAS_RESTRICTED_HASHES
+ if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0)
+ return (SV *) 0;
+#else
+ if (!(store_flags & HVhek_PLACEHOLD))
+ if (hv_store(hv, kbuf, size, sv, 0) == 0)
+ return (SV *) 0;
+#endif
+ }
+ }
+#ifdef HAS_RESTRICTED_HASHES
+ if (hash_flags & SHV_RESTRICTED)
+ SvREADONLY_on(hv);
+#endif
+
+ TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
+
+ return (SV *) hv;
+}
+
+/*
+ * retrieve_code
+ *
+ * Return a code reference.
+ */
+static SV *retrieve_code(pTHX_ stcxt_t *cxt, const 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, 0);
+
+ /*
+ * Retrieve the source of the code reference
+ * as a small or large scalar
+ */
+
+ GETMARK(type);
+ switch (type) {
+ case SX_SCALAR:
+ text = retrieve_scalar(aTHX_ cxt, cname);
+ break;
+ case SX_LSCALAR:
+ text = retrieve_lscalar(aTHX_ 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_setpvn(errsv, "", 0); /* 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.
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *old_retrieve_array(stcxt_t *cxt, char *cname)
+static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 i;
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av, 0); /* Will return if array not allocated nicely */
+ SEEN(av, 0, 0); /* Will return if array not allocated nicely */
if (len)
av_extend(av, len);
else
continue; /* av_extend() already filled us with undef */
}
if (c != SX_ITEM)
- (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
TRACEME(("(#%d) item", i));
- sv = retrieve(cxt, 0); /* Retrieve item */
+ sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
if (!sv)
return (SV *) 0;
if (av_store(av, i, sv) == 0)
*
* When we come here, SX_HASH has been read already.
*/
-static SV *old_retrieve_hash(stcxt_t *cxt, char *cname)
+static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 size;
HV *hv;
SV *sv = (SV *) 0;
int c;
- static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
+ SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum));
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv, 0); /* Will return if table not allocated properly */
+ SEEN(hv, 0, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len); /* pre-extend hash to save multiple splits */
sv = SvREFCNT_inc(sv_h_undef);
} else if (c == SX_VALUE) {
TRACEME(("(#%d) value", i));
- sv = retrieve(cxt, 0);
+ sv = retrieve(aTHX_ cxt, 0);
if (!sv)
return (SV *) 0;
} else
- (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
/*
* Get key.
GETMARK(c);
if (c != SX_KEY)
- (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */
+ (void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */
RLEN(size); /* Get key size */
- KBUFCHK(size); /* Grow hash key read pool if needed */
+ KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
if (size)
READ(kbuf, size);
kbuf[size] = '\0'; /* Mark string end, just in case */
* Note that there's no byte ordering info emitted when network order was
* used at store time.
*/
-static SV *magic_check(stcxt_t *cxt)
+static SV *magic_check(pTHX_ stcxt_t *cxt)
{
- char buf[256];
- char byteorder[256];
- int c;
- int use_network_order;
- int version_major;
- int version_minor = 0;
-
- TRACEME(("magic_check"));
-
- /*
- * The "magic number" is only for files, not when freezing in memory.
- */
-
- if (cxt->fio) {
- STRLEN len = sizeof(magicstr) - 1;
- STRLEN old_len;
-
- READ(buf, len); /* Not null-terminated */
- buf[len] = '\0'; /* Is now */
-
- if (0 == strcmp(buf, magicstr))
- goto magic_ok;
-
- /*
- * Try to read more bytes to check for the old magic number, which
- * was longer.
- */
-
- old_len = sizeof(old_magicstr) - 1;
- READ(&buf[len], old_len - len);
- buf[old_len] = '\0'; /* Is now null-terminated */
-
- if (strcmp(buf, old_magicstr))
- CROAK(("File is not a perl storable"));
- }
-
-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().
- */
-
+ /* 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 old_magic = 0;
+ int version_major;
+ int version_minor = 0;
+
+ TRACEME(("magic_check"));
+
+ /*
+ * 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;
+
+ READ(buf, (SSize_t)(len)); /* Not null-terminated */
+
+ /* Point at the byte after the byte we read. */
+ current = buf + --len; /* Do the -- outside of macros. */
+
+ if (memNE(buf, magicstr, len)) {
+ /*
+ * 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"));
+ old_magic++;
+ current = buf + old_len;
+ }
+ use_network_order = *current;
+ } else
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.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 (old_magic && use_network_order > 1) {
+ /* 0.1 dump - use_network_order is really byte order length */
+ version_major = -1;
+ }
+ else {
+ version_major = use_network_order >> 1;
+ }
+ cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major > 0 ? 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);
+
+ cxt->ver_major = version_major;
+ cxt->ver_minor = version_minor;
+
+ TRACEME(("binary image version is %d.%d", version_major, 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.
+ */
+
+ 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));
+ }
+ }
- cxt->ver_major = version_major;
- cxt->ver_minor = version_minor;
+ /*
+ * If they stored using network order, there's no byte ordering
+ * information to check.
+ */
- TRACEME(("binary image version is %d.%d", version_major, version_minor));
+ if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
+ return &PL_sv_undef; /* No byte ordering info */
- /*
- * 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.
- */
+ /* In C truth is 1, falsehood is 0. Very convienient. */
+ use_NV_size = version_major >= 2 && version_minor >= 2;
- if (
- version_major > STORABLE_BIN_MAJOR ||
- (version_major == STORABLE_BIN_MAJOR &&
- version_minor > STORABLE_BIN_MINOR)
- )
- 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 (version_major >= 0) {
+ GETMARK(c);
+ }
+ else {
+ c = use_network_order;
+ }
+ length = c + 3 + use_NV_size;
+ READ(buf, length); /* Not null-terminated */
+
+ TRACEME(("byte order '%.*s' %d", c, buf, c));
+
+#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 they stored using network order, there's no byte ordering
- * information to check.
- */
+ current = buf + c;
+
+ /* sizeof(int) */
+ if ((int) *current++ != sizeof(int))
+ CROAK(("Integer size is not compatible"));
- if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
- return &PL_sv_undef; /* No byte ordering info */
+ /* sizeof(long) */
+ if ((int) *current++ != sizeof(long))
+ CROAK(("Long integer size is not compatible"));
- sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
- GETMARK(c);
- READ(buf, c); /* Not null-terminated */
- buf[c] = '\0'; /* Is now */
+ /* sizeof(char *) */
+ if ((int) *current != sizeof(char *))
+ CROAK(("Pointer 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"));
- }
+ 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 */
}
/*
* root SV (which may be an AV or an HV for what we care).
* Returns null if there is a problem.
*/
-static SV *retrieve(stcxt_t *cxt, char *cname)
+static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname)
{
int type;
SV **svh;
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 */
* Okay, first time through for this one.
*/
- sv = RETRIEVE(cxt, type)(cxt, cname);
+ sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname);
if (!sv)
return (SV *) 0; /* Failed */
default:
return (SV *) 0; /* Failed */
}
- KBUFCHK(len); /* Grow buffer as necessary */
+ KBUFCHK((STRLEN)len); /* Grow buffer as necessary */
if (len)
READ(kbuf, len);
kbuf[len] = '\0'; /* Mark string end */
* Common routine for pretrieve and mretrieve.
*/
static SV *do_retrieve(
+ pTHX_
PerlIO *f,
SV *in,
int optype)
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
/*
* Now that STORABLE_xxx hooks exist, it is possible that they try to
*/
if (cxt->entry)
- cxt = allocate_context(cxt);
+ cxt = allocate_context(aTHX_ cxt);
cxt->entry++;
KBUFINIT(); /* Allocate hash key reading pool once */
- if (!f && in)
+ if (!f && in) {
+#ifdef SvUTF8_on
+ if (SvUTF8(in)) {
+ STRLEN length;
+ const char *orig = SvPV(in, length);
+ char *asbytes;
+ /* This is quite deliberate. I want the UTF8 routines
+ to encounter the '\0' which perl adds at the end
+ of all scalars, so that any new string also has
+ this.
+ */
+ STRLEN klen_tmp = length + 1;
+ bool is_utf8 = TRUE;
+
+ /* Just casting the &klen to (STRLEN) won't work
+ well if STRLEN and I32 are of different widths.
+ --jhi */
+ asbytes = (char*)bytes_from_utf8((U8*)orig,
+ &klen_tmp,
+ &is_utf8);
+ if (is_utf8) {
+ CROAK(("Frozen string corrupt - contains characters outside 0-255"));
+ }
+ if (asbytes != orig) {
+ /* String has been converted.
+ There is no need to keep any reference to
+ the old string. */
+ in = sv_newmortal();
+ /* We donate the SV the malloc()ed string
+ bytes_from_utf8 returned us. */
+ SvUPGRADE(in, SVt_PV);
+ SvPOK_on(in);
+ SvPV_set(in, asbytes);
+ SvLEN_set(in, klen_tmp);
+ SvCUR_set(in, klen_tmp - 1);
+ }
+ }
+#endif
MBUF_SAVE_AND_LOAD(in);
+ }
/*
* Magic number verifications.
cxt->fio = f; /* Where I/O are performed */
- if (!magic_check(cxt))
+ if (!magic_check(aTHX_ cxt))
CROAK(("Magic number checking on storable %s failed",
cxt->fio ? "file" : "string"));
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);
+ init_retrieve_context(aTHX_ cxt, optype, is_tainted);
- ASSERT(is_retrieving(), ("within retrieve operation"));
+ ASSERT(is_retrieving(aTHX), ("within retrieve operation"));
- sv = retrieve(cxt, 0); /* Recursively retrieve object, get root SV */
+ sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */
/*
* Final cleanup.
* The "root" context is never freed.
*/
- clean_retrieve_context(cxt);
+ clean_retrieve_context(aTHX_ cxt);
if (cxt->prev) /* This context was stacked */
- free_context(cxt); /* It was not the "root" context */
+ free_context(aTHX_ cxt); /* It was not the "root" context */
/*
* Prepare returned value.
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")",
if (pre_06_fmt) { /* Was not handling overloading by then */
SV *rv;
TRACEME(("fixing for old formats -- pre 0.6"));
- if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
+ if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
return sv;
}
*
* Retrieve data held in file and return the root object, undef on error.
*/
-SV *pretrieve(PerlIO *f)
+static SV *pretrieve(pTHX_ PerlIO *f)
{
TRACEME(("pretrieve"));
- return do_retrieve(f, Nullsv, 0);
+ return do_retrieve(aTHX_ f, Nullsv, 0);
}
/*
*
* Retrieve data held in scalar and return the root object, undef on error.
*/
-SV *mretrieve(SV *sv)
+static SV *mretrieve(pTHX_ SV *sv)
{
TRACEME(("mretrieve"));
- return do_retrieve((PerlIO*) 0, sv, 0);
+ return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0);
}
/***
* there. Not that efficient, but it should be faster than doing it from
* pure perl anyway.
*/
-SV *dclone(SV *sv)
+static SV *dclone(pTHX_ SV *sv)
{
dSTCXT;
int size;
*/
if (cxt->s_dirty)
- clean_context(cxt);
+ clean_context(aTHX_ cxt);
+
+ /*
+ * Tied elements seem to need special handling.
+ */
+
+ if (SvTYPE(sv) == SVt_PVLV && SvRMAGICAL(sv) && mg_find(sv, 'p')) {
+ mg_get(sv);
+ }
/*
* do_store() optimizes for dclone by not freeing its context, should
* we need to allocate one because we're deep cloning from a hook.
*/
- if (!do_store((PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
+ if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
return &PL_sv_undef; /* Error during store */
/*
*/
cxt->s_tainted = SvTAINTED(sv);
- out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE);
+ out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE);
TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out)));
#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();
+{
+ HV *stash = gv_stashpvn("Storable", 8, TRUE);
+ newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR));
+ newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR));
+ newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR));
+
+ init_perinterp(aTHX);
+ 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()
+ CODE:
+ init_perinterp(aTHX);
int
pstore(f,obj)
OutputStream f
SV * obj
+ CODE:
+ RETVAL = pstore(aTHX_ f, obj);
+ OUTPUT:
+ RETVAL
int
net_pstore(f,obj)
OutputStream f
SV * obj
+ CODE:
+ RETVAL = net_pstore(aTHX_ f, obj);
+ OUTPUT:
+ RETVAL
SV *
mstore(obj)
SV * obj
+ CODE:
+ RETVAL = mstore(aTHX_ obj);
+ OUTPUT:
+ RETVAL
SV *
net_mstore(obj)
SV * obj
+ CODE:
+ RETVAL = net_mstore(aTHX_ obj);
+ OUTPUT:
+ RETVAL
SV *
pretrieve(f)
InputStream f
+ CODE:
+ RETVAL = pretrieve(aTHX_ f);
+ OUTPUT:
+ RETVAL
SV *
mretrieve(sv)
SV * sv
+ CODE:
+ RETVAL = mretrieve(aTHX_ sv);
+ OUTPUT:
+ RETVAL
SV *
dclone(sv)
SV * sv
+ CODE:
+ RETVAL = dclone(aTHX_ sv);
+ OUTPUT:
+ RETVAL
int
last_op_in_netorder()
+ CODE:
+ RETVAL = last_op_in_netorder(aTHX);
+ OUTPUT:
+ RETVAL
int
is_storing()
+ CODE:
+ RETVAL = is_storing(aTHX);
+ OUTPUT:
+ RETVAL
int
is_retrieving()
-
+ CODE:
+ RETVAL = is_retrieving(aTHX);
+ OUTPUT:
+ RETVAL
https://perl5.git.perl.org / perl5.git / blobdiff