# define HvTOTALKEYS(hv) HvKEYS(hv)
#endif
+#ifdef SVf_IsCOW
+# define SvTRULYREADONLY(sv) SvREADONLY(sv)
+#else
+# define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv))
+#endif
+
#ifdef DEBUGME
#ifndef DASSERT
#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 */
+#define SX_VSTRING C(29) /* vstring forthcoming (small) */
+#define SX_LVSTRING C(30) /* vstring forthcoming (large) */
+#define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */
+#define SX_ERROR C(32) /* Error */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
#ifndef SvWEAKREF
#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
#endif
+#ifndef SvVOK
+#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl"))
+#endif
#ifdef HvPLACEHOLDERS
#define HAS_RESTRICTED_HASHES
int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
} stcxt_t;
+static int storable_free(pTHX_ SV *sv, MAGIC* mg);
+
+static MGVTBL vtbl_storable = {
+ NULL, /* get */
+ NULL, /* set */
+ NULL, /* len */
+ NULL, /* clear */
+ storable_free,
+#ifdef MGf_COPY
+ NULL, /* copy */
+#endif
+#ifdef MGf_DUP
+ NULL, /* dup */
+#endif
+#ifdef MGf_LOCAL
+ NULL /* local */
+#endif
+};
+
+/* From Digest::MD5. */
+#ifndef sv_magicext
+# define sv_magicext(sv, obj, type, vtbl, name, namlen) \
+ THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen)
+static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type,
+ MGVTBL const *vtbl, char const *name, I32 namlen)
+{
+ MAGIC *mg;
+ if (obj || namlen)
+ /* exceeded intended usage of this reserve implementation */
+ return NULL;
+ Newxz(mg, 1, MAGIC);
+ mg->mg_virtual = (MGVTBL*)vtbl;
+ mg->mg_type = type;
+ mg->mg_ptr = (char *)name;
+ mg->mg_len = -1;
+ (void) SvUPGRADE(sv, SVt_PVMG);
+ mg->mg_moremagic = SvMAGIC(sv);
+ SvMAGIC_set(sv, mg);
+ SvMAGICAL_off(sv);
+ mg_magical(sv);
+ return mg;
+}
+#endif
+
#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", GV_ADD)); \
+ sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \
cxt = (stcxt_t *)SvPVX(self); \
Zero(cxt, 1, stcxt_t); \
cxt->my_sv = my_sv; \
#endif
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 8 /* Binary minor "version" */
+#define STORABLE_BIN_MINOR 10 /* Binary minor "version" */
#if (PATCHLEVEL <= 5)
#define STORABLE_BIN_WRITE_MINOR 4
-#else
+#elif !defined (SvVOK)
/*
- * Perl 5.6.0 onwards can do weak references.
+ * Perl 5.6.0-5.8.0 can do weak references, but not vstring magic.
*/
#define STORABLE_BIN_WRITE_MINOR 8
+#elif PATCHLEVEL >= 19
+/* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */
+#define STORABLE_BIN_WRITE_MINOR 10
+#else
+#define STORABLE_BIN_WRITE_MINOR 9
#endif /* (PATCHLEVEL <= 5) */
#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
#ifdef HAS_HTONL
#define WLEN(x) \
STMT_START { \
+ ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \
if (cxt->netorder) { \
int y = (int) htonl(x); \
if (!cxt->fio) \
#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
/*
- * Store &PL_sv_undef in arrays without recursing through store().
+ * Store &PL_sv_undef in arrays without recursing through store(). We
+ * actually use this to represent nonexistent elements, for historical
+ * reasons.
*/
#define STORE_SV_UNDEF() \
STMT_START { \
} STMT_END
/*
- * This macro is used at retrieve time, to remember where object 'y', bearing a
+ * SEEN() is used at retrieve time, to remember where object 'y', bearing a
* given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
* we'll therefore know where it has been retrieved and will be able to
* share the same reference, as in the original stored memory image.
* will bless the object.
*
* i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
+ *
+ * SEEN0() is a short-cut where stash is always NULL.
+ *
+ * The _NN variants dont check for y being null
*/
-#define SEEN(y,c,i) \
- STMT_START { \
- if (!y) \
- return (SV *) 0; \
+#define SEEN0_NN(y,i) \
+ STMT_START { \
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); \
- } STMT_END
+ TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
+ PTR2UV(y), SvREFCNT(y)-1)); \
+ } STMT_END
+
+#define SEEN0(y,i) \
+ STMT_START { \
+ if (!y) \
+ return (SV *) 0; \
+ SEEN0_NN(y,i) \
+ } STMT_END
+
+#define SEEN_NN(y,stash,i) \
+ STMT_START { \
+ SEEN0_NN(y,i); \
+ if (stash) \
+ BLESS((SV *) (y), (HV *)(stash)); \
+ } STMT_END
+
+#define SEEN(y,stash,i) \
+ STMT_START { \
+ if (!y) \
+ return (SV *) 0; \
+ SEEN_NN(y,stash, i); \
+ } STMT_END
/*
* Bless 's' in 'p', via a temporary reference, required by sv_bless().
* "A" magic is added before the sv_bless for overloaded classes, this avoids
* an expensive call to S_reset_amagic in sv_bless.
*/
-#define BLESS(s,p) \
+#define BLESS(s,stash) \
STMT_START { \
SV *ref; \
- HV *stash; \
- TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
- stash = gv_stashpv((p), GV_ADD); \
+ TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (HvNAME_get(stash)))); \
ref = newRV_noinc(s); \
if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) \
{ \
(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_tied_array, /* SX_TIED_ARRAY */
+ (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */
+ (sv_retrieve_t)retrieve_tied_scalar, /* SX_TIED_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_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_VSTRING not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */
+ (sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */
(sv_retrieve_t)retrieve_other, /* SX_ERROR */
};
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 SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname);
static const sv_retrieve_t sv_retrieve[] = {
0, /* SX_OBJECT -- entry unused dynamically */
(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_tied_array, /* SX_TIED_ARRAY */
+ (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */
+ (sv_retrieve_t)retrieve_tied_scalar, /* SX_TIED_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_code, /* SX_CODE */
(sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */
(sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */
+ (sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */
+ (sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */
+ (sv_retrieve_t)retrieve_svundef_elem, /* SX_SVUNDEF_ELEM */
(sv_retrieve_t)retrieve_other, /* SX_ERROR */
};
*** Predicates.
***/
+/* these two functions are currently only used within asserts */
+#ifdef DASSERT
/*
* is_storing
*
return cxt->entry && (cxt->optype & ST_RETRIEVE);
}
+#endif
/*
* last_op_in_netorder
{
dSTCXT;
+ assert(cxt);
return cxt->netorder;
}
* SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings.
* The <data> section is omitted if <length> is 0.
*
+ * For vstrings, the vstring portion is stored first with
+ * SX_LVSTRING <length> <data> or SX_VSTRING <length> <data>, followed by
+ * SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV.
+ *
* 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>.
*/
TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
} else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
+#ifdef SvVOK
+ MAGIC *mg;
+#endif
I32 wlen; /* For 64-bit machines */
string_readlen:
*/
string:
+#ifdef SvVOK
+ if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) {
+ /* The macro passes this by address, not value, and a lot of
+ called code assumes that it's 32 bits without checking. */
+ const int len = mg->mg_len;
+ STORE_PV_LEN((const char *)mg->mg_ptr,
+ len, SX_VSTRING, SX_LVSTRING);
+ }
+#endif
+
wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
if (SvUTF8 (sv))
STORE_UTF8STR(pv, wlen);
for (i = 0; i < len; i++) {
sav = av_fetch(av, i, 0);
if (!sav) {
- TRACEME(("(#%d) undef item", i));
+ TRACEME(("(#%d) nonexistent item", i));
STORE_SV_UNDEF();
continue;
}
+#if PATCHLEVEL >= 19
+ /* In 5.19.3 and up, &PL_sv_undef can actually be stored in
+ * an array; it no longer represents nonexistent elements.
+ * Historically, we have used SX_SV_UNDEF in arrays for
+ * nonexistent elements, so we use SX_SVUNDEF_ELEM for
+ * &PL_sv_undef itself. */
+ if (*sav == &PL_sv_undef) {
+ TRACEME(("(#%d) undef item", i));
+ cxt->tagnum++;
+ PUTMARK(SX_SVUNDEF_ELEM);
+ continue;
+ }
+#endif
TRACEME(("(#%d) item", i));
if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */
return ret;
/* Implementation of restricted hashes isn't nicely
abstracted: */
if ((hash_flags & SHV_RESTRICTED)
- && SvREADONLY(val) && !SvIsCOW(val)) {
+ && SvTRULYREADONLY(val)) {
flags |= SHV_K_LOCKED;
}
abstracted: */
flags
= (((hash_flags & SHV_RESTRICTED)
- && SvREADONLY(val) && !SvIsCOW(val))
+ && SvTRULYREADONLY(val))
? SHV_K_LOCKED : 0);
if (val == &PL_sv_placeholder) {
TRACEME(("(#%d) key '%s'", i, key));
}
if (flags & SHV_K_ISSV) {
- store(aTHX_ cxt, key_sv);
+ int ret;
+ if ((ret = store(aTHX_ cxt, key_sv)))
+ goto out;
} else {
WLEN(len);
if (len)
* 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));
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("B::Deparse"), newSVnv(0.61));
SPAGAIN;
ENTER;
*/
if (!count) {
+ /* free empty list returned by the hook */
+ av_undef(av);
+ sv_free((SV *) av);
+
/*
* They must not change their mind in the middle of a serialization.
*/
return SvROK(sv) ? svis_REF : svis_SCALAR;
case SVt_PVMG:
case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */
- if (SvRMAGICAL(sv) && (mg_find(sv, 'p')))
+ if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) ==
+ (SVs_GMG|SVs_SMG|SVs_RMG) &&
+ (mg_find(sv, 'p')))
return svis_TIED_ITEM;
/* FALL THROUGH */
#if PERL_VERSION < 9
case SVt_PVBM:
#endif
- if (SvRMAGICAL(sv) && (mg_find(sv, 'q')))
+ if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) ==
+ (SVs_GMG|SVs_SMG|SVs_RMG) &&
+ (mg_find(sv, 'q')))
return svis_TIED;
return SvROK(sv) ? svis_REF : svis_SCALAR;
case SVt_PVAV:
case SVt_PVCV:
return svis_CODE;
#if PERL_VERSION > 8
- /* case SVt_BIND: */
+ /* case SVt_INVLIST: */
#endif
default:
break;
* Write magic number and system information into the file.
* Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long>
* <sizeof ptr>] where <len> is the length of the byteorder hexa string.
- * All size and lenghts are written as single characters here.
+ * All size and lengths are written as single characters here.
*
* Note that no byte ordering info is emitted when <network> is true, since
* integers will be emitted in network order in that case.
* free up memory for them now.
*/
+ assert(cxt);
if (cxt->s_dirty)
clean_context(aTHX_ cxt);
{
dSTCXT;
+ assert(cxt);
return newSVpv(mbase, MBUF_SIZE());
}
SV *sv;
SV *rv;
GV *attach;
+ HV *stash;
int obj_type;
int clone = cxt->optype & ST_CLONE;
char mtype = '\0';
default:
return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
}
- SEEN(sv, 0, 0); /* Don't bless yet */
+ SEEN0_NN(sv, 0); /* Don't bless yet */
/*
* Whilst flags tell us to recurse, do so.
}
/*
- * Bless the object and look up the STORABLE_thaw hook.
+ * Look up the STORABLE_attach hook
*/
-
- BLESS(sv, classname);
+ stash = gv_stashpv(classname, GV_ADD);
/* Handle attach case; again can't use pkg_can because it only
* caches one method */
- attach = gv_fetchmethod_autoload(SvSTASH(sv), "STORABLE_attach", FALSE);
+ attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE);
if (attach && isGV(attach)) {
SV* attached;
SV* attach_hook = newRV((SV*) GvCV(attach));
AvARRAY(av)[0] = SvREFCNT_inc(frozen);
rv = newSVpv(classname, 0);
attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
+ /* Free memory after a call */
+ SvREFCNT_dec(rv);
+ SvREFCNT_dec(frozen);
+ av_undef(av);
+ sv_free((SV *) av);
+ SvREFCNT_dec(attach_hook);
if (attached &&
SvROK(attached) &&
sv_derived_from(attached, classname)
) {
UNSEE();
- SEEN(SvRV(attached), 0, 0);
- return SvRV(attached);
- }
+ /* refcnt of unneeded sv is 2 at this point (one from newHV, second from SEEN call) */
+ SvREFCNT_dec(sv);
+ SvREFCNT_dec(sv);
+ /* we need to free RV but preserve value that RV point to */
+ sv = SvRV(attached);
+ SEEN0_NN(sv, 0);
+ SvRV_set(attached, NULL);
+ SvREFCNT_dec(attached);
+ if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
+ Safefree(classname);
+ return sv;
+ }
CROAK(("STORABLE_attach did not return a %s object", classname));
}
- hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+ /*
+ * Bless the object and look up the STORABLE_thaw hook.
+ */
+
+ BLESS(sv, stash);
+
+ hook = pkg_can(aTHX_ cxt->hook, stash, "STORABLE_thaw");
if (!hook) {
/*
* Hook not found. Maybe they did not require the module where this
{
SV *rv;
SV *sv;
+ HV *stash;
TRACEME(("retrieve_ref (#%d)", cxt->tagnum));
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname, 0); /* Will return if rv is null */
+ if (cname)
+ stash = gv_stashpv(cname, GV_ADD);
+ else
+ stash = 0;
+ SEEN_NN(rv, stash, 0); /* Will return if rv is null */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
*/
rv = NEWSV(10002, 0);
- SEEN(rv, cname, 0); /* Will return if rv is null */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(rv, stash, 0); /* Will return if rv is null */
cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
cxt->in_retrieve_overloaded = 0;
{
SV *tv;
SV *sv;
+ HV *stash;
TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname, 0); /* Will return if tv is null */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(tv, stash, 0); /* Will return if tv is null */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
{
SV *tv;
SV *sv;
+ HV *stash;
TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname, 0); /* Will return if tv is null */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(tv, stash, 0); /* Will return if tv is null */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
{
SV *tv;
SV *sv, *obj = NULL;
+ HV *stash;
TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname, 0); /* Will return if rv is null */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(tv, stash, 0); /* Will return if rv is null */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv) {
return (SV *) 0; /* Failed */
SV *tv;
SV *sv;
SV *key;
+ HV *stash;
TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname, 0); /* Will return if tv is null */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(tv, stash, 0); /* Will return if tv is null */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
{
SV *tv;
SV *sv;
+ HV *stash;
I32 idx;
TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
tv = NEWSV(10002, 0);
- SEEN(tv, cname, 0); /* Will return if tv is null */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(tv, stash, 0); /* Will return if tv is null */
sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
if (!sv)
return (SV *) 0; /* Failed */
{
I32 len;
SV *sv;
+ HV *stash;
RLEN(len);
TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len));
*/
sv = NEWSV(10002, len);
- SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
if (len == 0) {
sv_setpvn(sv, "", 0);
{
int len;
SV *sv;
+ HV *stash;
GETMARK(len);
TRACEME(("retrieve_scalar (#%d), len = %d", cxt->tagnum, len));
*/
sv = NEWSV(10002, len);
- SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
/*
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
}
/*
+ * retrieve_vstring
+ *
+ * Retrieve a vstring, and then retrieve the stringy scalar following it,
+ * attaching the vstring to the scalar via magic.
+ * If we're retrieving a vstring in a perl without vstring magic, croaks.
+ *
+ * The vstring layout mirrors an SX_SCALAR string:
+ * SX_VSTRING <length> <data> with SX_VSTRING already read.
+ */
+static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname)
+{
+#ifdef SvVOK
+ char s[256];
+ int len;
+ SV *sv;
+
+ GETMARK(len);
+ TRACEME(("retrieve_vstring (#%d), len = %d", cxt->tagnum, len));
+
+ READ(s, len);
+
+ sv = retrieve(aTHX_ cxt, cname);
+
+ sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len);
+ /* 5.10.0 and earlier seem to need this */
+ SvRMAGICAL_on(sv);
+
+ TRACEME(("ok (retrieve_vstring at 0x%"UVxf")", PTR2UV(sv)));
+ return sv;
+#else
+ VSTRING_CROAK();
+ return Nullsv;
+#endif
+}
+
+/*
+ * retrieve_lvstring
+ *
+ * Like retrieve_vstring, but for longer vstrings.
+ */
+static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname)
+{
+#ifdef SvVOK
+ char *s;
+ I32 len;
+ SV *sv;
+
+ RLEN(len);
+ TRACEME(("retrieve_lvstring (#%d), len = %"IVdf,
+ cxt->tagnum, (IV)len));
+
+ New(10003, s, len+1, char);
+ SAFEPVREAD(s, len, s);
+
+ sv = retrieve(aTHX_ cxt, cname);
+
+ sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len);
+ /* 5.10.0 and earlier seem to need this */
+ SvRMAGICAL_on(sv);
+
+ Safefree(s);
+
+ TRACEME(("ok (retrieve_lvstring at 0x%"UVxf")", PTR2UV(sv)));
+ return sv;
+#else
+ VSTRING_CROAK();
+ return Nullsv;
+#endif
+}
+
+/*
* retrieve_integer
*
* Retrieve defined integer.
static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
+ HV *stash;
IV iv;
TRACEME(("retrieve_integer (#%d)", cxt->tagnum));
READ(&iv, sizeof(iv));
sv = newSViv(iv);
- SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("integer %"IVdf, iv));
TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv)));
static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
+ HV *stash;
I32 iv;
TRACEME(("retrieve_netint (#%d)", cxt->tagnum));
sv = newSViv(iv);
TRACEME(("network integer (as-is) %d", iv));
#endif
- SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv)));
static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
+ HV *stash;
NV nv;
TRACEME(("retrieve_double (#%d)", cxt->tagnum));
READ(&nv, sizeof(nv));
sv = newSVnv(nv);
- SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("double %"NVff, nv));
TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv)));
static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
+ HV *stash;
int siv;
signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */
TRACEME(("small integer read as %d", (unsigned char) siv));
tmp = (unsigned char) siv - 128;
sv = newSViv(tmp);
- SEEN(sv, cname, 0); /* Associate this new scalar with tag "tagnum" */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
TRACEME(("byte %d", tmp));
TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv)));
*/
static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname)
{
- SV* sv;
+ SV *sv;
+ HV *stash;
TRACEME(("retrieve_undef"));
sv = newSV(0);
- SEEN(sv, cname, 0);
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0);
return sv;
}
static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_undef;
+ HV *stash;
TRACEME(("retrieve_sv_undef"));
if (cxt->where_is_undef == -1) {
cxt->where_is_undef = cxt->tagnum;
}
- SEEN(sv, cname, 1);
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 1);
return sv;
}
static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_yes;
+ HV *stash;
TRACEME(("retrieve_sv_yes"));
- SEEN(sv, cname, 1);
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 1);
return sv;
}
static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_no;
+ HV *stash;
TRACEME(("retrieve_sv_no"));
- SEEN(sv, cname, 1);
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 1);
return sv;
}
/*
+ * retrieve_svundef_elem
+ *
+ * Return &PL_sv_placeholder, representing &PL_sv_undef in an array. This
+ * is a bit of a hack, but we already use SX_SV_UNDEF to mean a nonexistent
+ * element, for historical reasons.
+ */
+static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname)
+{
+ TRACEME(("retrieve_svundef_elem"));
+
+ /* SEEN reads the contents of its SV argument, which we are not
+ supposed to do with &PL_sv_placeholder. */
+ SEEN_NN(&PL_sv_undef, cname, 1);
+
+ return &PL_sv_placeholder;
+}
+
+/*
* retrieve_array
*
* Retrieve a whole array.
I32 i;
AV *av;
SV *sv;
+ HV *stash;
+ bool seen_null = FALSE;
TRACEME(("retrieve_array (#%d)", cxt->tagnum));
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av, cname, 0); /* Will return if array not allocated nicely */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */
if (len)
av_extend(av, len);
else
sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
if (!sv)
return (SV *) 0;
+ if (sv == &PL_sv_undef) {
+ seen_null = TRUE;
+ continue;
+ }
+ if (sv == &PL_sv_placeholder)
+ sv = &PL_sv_undef;
if (av_store(av, i, sv) == 0)
return (SV *) 0;
}
+ if (seen_null) av_fill(av, len-1);
TRACEME(("ok (retrieve_array at 0x%"UVxf")", PTR2UV(av)));
I32 i;
HV *hv;
SV *sv;
+ HV *stash;
TRACEME(("retrieve_hash (#%d)", cxt->tagnum));
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv, cname, 0); /* Will return if table not allocated properly */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */
I32 i;
HV *hv;
SV *sv;
+ HV *stash;
int hash_flags;
GETMARK(hash_flags);
RLEN(len);
TRACEME(("size = %d, flags = %d", len, hash_flags));
hv = newHV();
- SEEN(hv, cname, 0); /* Will return if table not allocated properly */
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */
int type, count, tagnum;
SV *cv;
SV *sv, *text, *sub, *errsv;
+ HV *stash;
TRACEME(("retrieve_code (#%d)", cxt->tagnum));
*/
tagnum = cxt->tagnum;
sv = newSViv(0);
- SEEN(sv, cname, 0);
+ stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+ SEEN_NN(sv, stash, 0);
/*
* Retrieve the source of the code reference
* prepend "sub " to the source
*/
- sub = newSVpvn("sub ", 4);
+ sub = newSVpvs("sub ");
if (SvUTF8(text))
SvUTF8_on(sub);
sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
RLEN(len);
TRACEME(("size = %d", len));
av = newAV();
- SEEN(av, 0, 0); /* Will return if array not allocated nicely */
+ SEEN0_NN(av, 0); /* Will return if array not allocated nicely */
if (len)
av_extend(av, len);
else
RLEN(len);
TRACEME(("size = %d", len));
hv = newHV();
- SEEN(hv, 0, 0); /* Will return if table not allocated properly */
+ SEEN0_NN(hv, 0); /* Will return if table not allocated properly */
if (len == 0)
return (SV *) hv; /* No data follow if table empty */
hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */
if (cxt->ver_major < 2) {
while ((type = GETCHAR()) != SX_STORED) {
I32 len;
+ HV* stash;
switch (type) {
case SX_CLASS:
GETMARK(len); /* Length coded on a single char */
if (len)
READ(kbuf, len);
kbuf[len] = '\0'; /* Mark string end */
- BLESS(sv, kbuf);
+ stash = gv_stashpvn(kbuf, len, GV_ADD);
+ BLESS(sv, stash);
}
}
* free up memory for them now.
*/
+ assert(cxt);
if (cxt->s_dirty)
clean_context(aTHX_ cxt);
* free up memory for them now.
*/
+ assert(cxt);
if (cxt->s_dirty)
clean_context(aTHX_ cxt);
#if PERL_VERSION < 8
|| SvTYPE(sv) == SVt_PVMG
#endif
- ) && SvRMAGICAL(sv) && mg_find(sv, 'p')) {
+ ) && (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) ==
+ (SVs_GMG|SVs_SMG|SVs_RMG) &&
+ mg_find(sv, 'p')) {
mg_get(sv);
}
* Now, 'cxt' may refer to a new context.
*/
+ assert(cxt);
ASSERT(!cxt->s_dirty, ("clean context"));
ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
#define InputStream PerlIO *
#endif /* !OutputStream */
-MODULE = Storable PACKAGE = Storable::Cxt
+static int
+storable_free(pTHX_ SV *sv, MAGIC* mg) {
+ stcxt_t *cxt = (stcxt_t *)SvPVX(sv);
-void
-DESTROY(self)
- SV *self
-PREINIT:
- stcxt_t *cxt = (stcxt_t *)SvPVX(SvRV(self));
-PPCODE:
+ PERL_UNUSED_ARG(mg);
if (kbuf)
Safefree(kbuf);
if (!cxt->membuf_ro && mbase)
Safefree(mbase);
if (cxt->membuf_ro && (cxt->msaved).arena)
Safefree((cxt->msaved).arena);
-
+ return 0;
+}
MODULE = Storable PACKAGE = Storable
if (ix) {
dSTCXT;
+ assert(cxt);
result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE;
} else {
result = !!last_op_in_netorder(aTHX);
https://perl5.git.perl.org / perl5.git / blobdiff