#include <patchlevel.h> /* Perl's one, needed since 5.6 */
#endif
-#if !defined(PERL_VERSION) || PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 9) || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
+#if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
#define NEED_load_module
#define NEED_vload_module
#define NEED_newCONSTSUB
#define NEED_newSVpvn_flags
+#define NEED_newRV_noinc
#include "ppport.h" /* handle old perls */
#endif
* Earlier versions of perl might be used, we can't assume they have the latest!
*/
-#ifndef PERL_VERSION /* For perls < 5.6 */
-#define PERL_VERSION PATCHLEVEL
-#ifndef newRV_noinc
-#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
-#endif
-#if (PATCHLEVEL <= 4) /* Older perls (<= 5.004) lack PL_ namespace */
-#define PL_sv_yes sv_yes
-#define PL_sv_no sv_no
-#define PL_sv_undef sv_undef
-#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */
-#define newSVpvn newSVpv
-#endif
-#endif /* PATCHLEVEL <= 4 */
#ifndef HvSHAREKEYS_off
#define HvSHAREKEYS_off(hv) /* Ignore */
#endif
-#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
-#define AvFILLp AvFILL
-#endif
-typedef double NV; /* Older perls lack the NV type */
-#define IVdf "ld" /* Various printf formats for Perl types */
-#define UVuf "lu"
-#define UVof "lo"
-#define UVxf "lx"
-#define INT2PTR(t,v) (t)(IV)(v)
-#define PTR2UV(v) (unsigned long)(v)
-#endif /* PERL_VERSION -- perls < 5.6 */
-
-#ifndef NVef /* The following were not part of perl 5.6 */
-#if defined(USE_LONG_DOUBLE) && \
- defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
-#define NVef PERL_PRIeldbl
-#define NVff PERL_PRIfldbl
-#define NVgf PERL_PRIgldbl
-#else
-#define NVef "e"
-#define NVff "f"
-#define NVgf "g"
-#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
+/* perl <= 5.8.2 needs this */
+#ifndef SvIsCOW
+# define SvIsCOW(sv) 0
#endif
#ifndef HvRITER_set
# define HvEITER_get HvEITER
#endif
-#ifndef HvNAME_get
-#define HvNAME_get HvNAME
-#endif
-
#ifndef HvPLACEHOLDERS_get
# define HvPLACEHOLDERS_get HvPLACEHOLDERS
#endif
+#ifndef HvTOTALKEYS
+# define HvTOTALKEYS(hv) HvKEYS(hv)
+#endif
+
#ifdef DEBUGME
#ifndef DASSERT
#define SX_OBJECT C(0) /* Already stored object */
#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
-#define SX_ARRAY C(2) /* Array forthcominng (size, item list) */
+#define SX_ARRAY C(2) /* Array forthcoming (size, item list) */
#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
#define SX_REF C(4) /* Reference to object forthcoming */
#define SX_UNDEF C(5) /* Undefined scalar */
#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_ERROR C(31) /* Error */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
* keys are not enough a motivation to reclaim that space).
*
* This structure is also used for memory store/retrieve operations which
- * happen in a fixed place before being malloc'ed elsewhere if persistency
+ * happen in a fixed place before being malloc'ed elsewhere if persistence
* is required. Hence the aptr pointer.
*/
struct extendable {
char *arena; /* Will hold hash key strings, resized as needed */
- STRLEN asiz; /* Size of aforementionned buffer */
+ STRLEN asiz; /* Size of aforementioned buffer */
char *aptr; /* Arena pointer, for in-place read/write ops */
char *aend; /* First invalid address */
};
*
* At retrieve time:
* An array table records the objects which have already been retrieved,
- * as seen by the tag determind by counting the objects themselves. The
+ * as seen by the tag determined by counting the objects themselves. The
* reference to that retrieved object is kept in the table, and is returned
* when an SX_OBJECT is found bearing that same tag.
*
#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
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 */
+ int derestrict; /* whether to downgrade restricted hashes */
#endif
#ifndef HAS_UTF8_ALL
int use_bytes; /* whether to bytes-ify utf8 */
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; \
/* 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
+ explicitly 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.8 is consistent - the following redefinition 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.
#endif
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
-#define STORABLE_BIN_MINOR 8 /* Binary minor "version" */
+#define STORABLE_BIN_MINOR 9 /* 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
+#else
+#define STORABLE_BIN_WRITE_MINOR 9
#endif /* (PATCHLEVEL <= 5) */
#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
} STMT_END
/*
- * Bless `s' in `p', via a temporary reference, required by sv_bless().
+ * 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.
*/
static int store(pTHX_ stcxt_t *cxt, SV *sv);
static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
+#define UNSEE() \
+ STMT_START { \
+ av_pop(cxt->aseen); \
+ cxt->tagnum--; \
+ } STMT_END
+
/*
* Dynamic dispatching table for SV store.
*/
(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_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 const sv_retrieve_t sv_retrieve[] = {
0, /* SX_OBJECT -- entry unused dynamically */
(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_other, /* SX_ERROR */
};
cxt->entry = 1; /* No recursion yet */
/*
- * The `hseen' table is used to keep track of each SV stored and their
+ * The 'hseen' table is used to keep track of each SV stored and their
* associated tag numbers is special. It is "abused" because the
* values stored are not real SV, just integers cast to (SV *),
* which explains the freeing below.
*
- * It is also one possible bottlneck to achieve good storing speed,
+ * It is also one possible bottleneck to achieve good storing speed,
* so the "shared keys" optimization is turned off (unlikely to be
* of any use here), and the hash table is "pre-extended". Together,
* those optimizations increase the throughput by 12%.
#endif
/*
- * The `hclass' hash uses the same settings as `hseen' above, but it is
+ * The 'hclass' hash uses the same settings as 'hseen' above, but it is
* used to assign sequential tags (numbers) to class names for blessed
* objects.
*
#endif
/*
- * The `hook' hash table is used to keep track of the references on
+ * The 'hook' hash table is used to keep track of the references on
* the STORABLE_freeze hook routines, when found in some class name.
*
* It is assumed that the inheritance tree will not be changed during
cxt->hook = newHV(); /* Table where hooks are cached */
/*
- * The `hook_seen' array keeps track of all the SVs returned by
+ * The 'hook_seen' array keeps track of all the SVs returned by
* STORABLE_freeze hooks for us to serialize, so that they are not
* reclaimed until the end of the serialization process. Each SV is
* only stored once, the first time it is seen.
*
* The surrounding if() protection has been added because there might be
* some cases where this routine is called more than once, during
- * exceptionnal events. This was reported by Marc Lehmann when Storable
+ * exceptional events. This was reported by Marc Lehmann when Storable
* is executed from mod_perl, and the fix was suggested by him.
* -- RAM, 20/12/2000
*/
/*
* 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
- * the correspondance between the tags and the tag number used by the
+ * the correspondence between the tags and the tag number used by the
* new retrieve routines.
*/
const char *method)
{
const char *hvname = HvNAME_get(pkg);
+ PERL_UNUSED_ARG(method);
(void) hv_store(cache,
hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0);
}
const char *method)
{
const char *hvname = HvNAME_get(pkg);
+ PERL_UNUSED_ARG(method);
(void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
}
* Look into the cache to see whether we already have determined
* where the routine was, if any.
*
- * NOTA BENE: we don't use `method' at all in our lookup, since we know
+ * NOTA BENE: we don't use 'method' at all in our lookup, since we know
* that only one hook (i.e. always the same) is cached in a given cache.
*/
/*
* known_class
*
- * Lookup the class name in the `hclass' table and either assign it a new ID
- * or return the existing one, by filling in `classnum'.
+ * Lookup the class name in the 'hclass' table and either assign it a new ID
+ * or return the existing one, by filling in 'classnum'.
*
* Return true if the class was known, false if the ID was just generated.
*/
}
/***
- *** Sepcific store routines.
+ *** Specific store routines.
***/
/*
* Store a scalar.
*
* Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
+ * 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>.
*/
if (
#ifdef SVf_IVisUV
/* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
- ((flags & SVf_IVisUV) && SvUV(sv) > 0x7FFFFFFF) ||
+ ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) ||
#endif
- (iv > 0x7FFFFFFF) || (iv < -0x80000000)) {
+ (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) {
/* Bigger than 32 bits. */
TRACEME(("large network order integer as string, value = %"IVdf, iv));
goto string_readlen;
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')))
+ STORE_PV_LEN((const char *)mg->mg_ptr,
+ mg->mg_len, SX_VSTRING, SX_LVSTRING);
+#endif
+
wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
if (SvUTF8 (sv))
STORE_UTF8STR(pv, wlen);
*
* Store an array.
*
- * Layout is SX_ARRAY <size> followed by each item, in increading index order.
+ * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
* Each item is stored as <object>.
*/
static int store_array(pTHX_ stcxt_t *cxt, AV *av)
* 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"
+ * Currently the only hash flag is "restricted"
* Key flags are as for hv.h
*/
static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
{
dVAR;
- I32 len =
-#ifdef HAS_RESTRICTED_HASHES
- HvTOTALKEYS(hv);
-#else
- HvKEYS(hv);
-#endif
+ I32 len = HvTOTALKEYS(hv);
I32 i;
int ret = 0;
I32 riter;
SV *key;
if (!he)
- CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, len, i));
+ CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, (int)len, (int)i));
key = hv_iterkeysv(he);
av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
}
/* Implementation of restricted hashes isn't nicely
abstracted: */
- if ((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) {
+ if ((hash_flags & SHV_RESTRICTED)
+ && SvREADONLY(val) && !SvIsCOW(val)) {
flags |= SHV_K_LOCKED;
}
abstracted: */
flags
= (((hash_flags & SHV_RESTRICTED)
- && SvREADONLY(val))
+ && SvREADONLY(val) && !SvIsCOW(val))
? SHV_K_LOCKED : 0);
if (val == &PL_sv_placeholder) {
* Note that we store the Perl object as-is. We don't call its FETCH
* method along the way. At retrieval time, we won't call its STORE
* method either, but the tieing magic will be re-installed. In itself,
- * that ensures that the tieing semantics are preserved since futher
+ * that ensures that the tieing semantics are preserved since further
* accesses on the retrieved object will indeed call the magic methods...
*/
*/
switch (type) {
+ case svis_REF:
case svis_SCALAR:
obj_type = SHT_SCALAR;
break;
* Signal the tie-ing magic by setting the object type as SHT_EXTRA
* (since we have only 2 bits in <flags> to store the type), and an
* <extra> byte flag will be emitted after the FIRST <flags> in the
- * stream, carrying what we put in `eflags'.
+ * stream, carrying what we put in 'eflags'.
*/
obj_type = SHT_EXTRA;
switch (SvTYPE(sv)) {
* $object->STORABLE_freeze($cloning);
*
* but we don't have the $object here. For instance, if $object is
- * a blessed array, what we have in `sv' is the array, and we can't
+ * a blessed array, what we have in 'sv' is the array, and we can't
* call a method on those.
*
* Therefore, we need to create a temporary reference to the object and
TRACEME(("about to call STORABLE_freeze on class %s", classname));
- ref = newRV_noinc(sv); /* Temporary reference */
+ ref = newRV_inc(sv); /* Temporary reference */
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;
CROAK(("Could not serialize item #%d from hook in %s", i, classname));
#endif
/*
- * It was the first time we serialized `xsv'.
+ * It was the first time we serialized 'xsv'.
*
* Keep this SV alive until the end of the serialization: if we
* disposed of it right now by decrementing its refcount, and it was
sv_seen:
/*
- * Dispose of the REF they returned. If we saved the `xsv' away
+ * Dispose of the REF they returned. If we saved the 'xsv' away
* in the array of returned SVs, that will not cause the underlying
* referenced SV to be reclaimed.
*/
* We don't know how to store the item we reached, so return an error condition.
* (it's probably a GLOB, some CODE reference, etc...)
*
- * If they defined the `forgive_me' variable at the Perl level to some
+ * If they defined the 'forgive_me' variable at the Perl level to some
* true value, then don't croak, just warn, and store a placeholder string
* instead.
*/
case SVt_PVCV:
return svis_CODE;
#if PERL_VERSION > 8
- /* case SVt_BIND: */
+ /* case SVt_DUMMY: */
#endif
default:
break;
#endif
/*
- * Store `sv' and everything beneath it, using appropriate routine.
+ * Store 'sv' and everything beneath it, using appropriate routine.
* Abort immediately if we get a non-zero status back.
*/
* Common code for store operations.
*
* When memory store is requested (f = NULL) and a non null SV* is given in
- * `res', it is filled with a new SV created out of the memory buffer.
+ * 'res', it is filled with a new SV created out of the memory buffer.
*
- * It is required to provide a non-null `res' when the operation type is not
+ * It is required to provide a non-null 'res' when the operation type is not
* dclone() and store() is performed to memory.
*/
static int do_store(
* Ensure sv is actually a reference. From perl, we called something
* like:
* pstore(aTHX_ FILE, \@array);
- * so we must get the scalar value behing that reference.
+ * so we must get the scalar value behind that reference.
*/
if (!SvROK(sv))
*/
static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname)
{
+ PERL_UNUSED_ARG(cname);
if (
cxt->ver_major != STORABLE_BIN_MAJOR &&
cxt->ver_minor != STORABLE_BIN_MINOR
SV **sva;
SV *sv;
+ PERL_UNUSED_ARG(cname);
TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
ASSERT(!cname, ("no bless-into class given here, got %s", cname));
RLEN(idx);
/*
- * Fetch classname in `aclass'
+ * Fetch classname in 'aclass'
*/
sva = av_fetch(cxt->aclass, idx, FALSE);
char *classname = buf;
char *malloced_classname = NULL;
+ PERL_UNUSED_ARG(cname);
TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
ASSERT(!cname, ("no bless-into class given here, got %s", cname));
char mtype = '\0';
unsigned int extra_type = 0;
+ PERL_UNUSED_ARG(cname);
TRACEME(("retrieve_hook (#%d)", cxt->tagnum));
ASSERT(!cname, ("no bless-into class given here, got %s", cname));
I32 idx;
/*
- * Fetch index from `aclass'
+ * Fetch index from 'aclass'
*/
if (flags & SHF_LARGE_CLASSLEN)
*
* We read object tags and we can convert them into SV* on the fly
* because we know all the references listed in there (as tags)
- * have been already serialized, hence we have a valid correspondance
+ * have been already serialized, hence we have a valid correspondence
* between each of those tags and the recreated SV.
*/
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))
- return SvRV(attached);
+ sv_derived_from(attached, classname)
+ ) {
+ UNSEE();
+ /* 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);
+ SEEN(sv, 0, 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));
}
}
/*
- * If we don't have an `av' yet, prepare one.
+ * If we don't have an 'av' yet, prepare one.
* Then insert the frozen string as item [0].
*/
}
/*
+ * 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
+ MAGIC *mg;
+ 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
+ MAGIC *mg;
+ 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.
* retrieve_array
*
* Retrieve a whole array.
- * Layout is SX_ARRAY <size> followed by each item, in increading index order.
+ * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
* Each item is stored as <object>.
*
* When we come here, SX_ARRAY has been read already.
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 */
+ hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */
/*
* Now get each key/value pair in turn...
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 */
+ hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */
/*
* Now get each key/value pair in turn...
*
* Retrieve a whole array in pre-0.6 binary format.
*
- * Layout is SX_ARRAY <size> followed by each item, in increading index order.
+ * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
* Each item is stored as SX_ITEM <object> or SX_IT_UNDEF for "holes".
*
* When we come here, SX_ARRAY has been read already.
SV *sv;
int c;
+ PERL_UNUSED_ARG(cname);
TRACEME(("old_retrieve_array (#%d)", cxt->tagnum));
/*
int c;
SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
+ PERL_UNUSED_ARG(cname);
TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum));
/*
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 */
+ hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */
/*
* Now get each key/value pair in turn...
if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
return &PL_sv_undef; /* No byte ordering info */
- /* In C truth is 1, falsehood is 0. Very convienient. */
+ /* In C truth is 1, falsehood is 0. Very convenient. */
use_NV_size = version_major >= 2 && version_minor >= 2;
if (version_major >= 0) {
/*
* Grab address tag which identifies the object if we are retrieving
* an older format. Since the new binary format counts objects and no
- * longer explicitely tags them, we must keep track of the correspondance
+ * longer explicitly tags them, we must keep track of the correspondence
* ourselves.
*
* The following section will disappear one day when the old format is
/*
* Prepare context.
*
- * Data is loaded into the memory buffer when f is NULL, unless `in' is
+ * Data is loaded into the memory buffer when f is NULL, unless 'in' is
* also NULL, in which case we're expecting the data to already lie
* in the buffer (dclone case).
*/
* Check whether input source is tainted, so that we don't wrongly
* taint perfectly good values...
*
- * We assume file input is always tainted. If both `f' and `in' are
+ * We assume file input is always tainted. If both 'f' and 'in' are
* NULL, then we come from dclone, and tainted is already filled in
* the context. That's a kludge, but the whole dclone() thing is
* already quite a kludge anyway! -- RAM, 15/09/2000.
* so that we can croak when behaviour cannot be re-installed, and also
* avoid testing for overloading magic at each reference retrieval.
*
- * Unfortunately, the root reference is implicitely stored, so we must
+ * Unfortunately, the root reference is implicitly stored, so we must
* check for possible overloading now. Furthermore, if we don't restore
* overloading, we cannot croak as if the original ref was, because we
* have no way to determine whether it was an overloaded ref or not in
cxt = real_context; /* And we need this temporary... */
/*
- * Now, `cxt' may refer to a new context.
+ * Now, 'cxt' may refer to a new context.
*/
ASSERT(!cxt->s_dirty, ("clean context"));
#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:
+static int
+storable_free(pTHX_ SV *sv, MAGIC* mg) {
+ stcxt_t *cxt = (stcxt_t *)SvPVX(sv);
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
# Same as pstore(), but network order is used for integers and doubles are
# emitted as strings.
-void
+SV *
pstore(f,obj)
OutputStream f
SV * obj
ALIAS:
net_pstore = 1
PPCODE:
- ST(0) = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef;
+ RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef;
+ /* do_store() can reallocate the stack, so need a sequence point to ensure
+ that ST(0) knows about it. Hence using two statements. */
+ ST(0) = RETVAL;
XSRETURN(1);
# mstore
OUTPUT:
RETVAL
-bool
+void
last_op_in_netorder()
- CODE:
- RETVAL = !!last_op_in_netorder(aTHX);
- OUTPUT:
- RETVAL
-
-bool
-is_storing()
ALIAS:
is_storing = ST_STORE
is_retrieving = ST_RETRIEVE
- CODE:
- {
- dSTCXT;
-
- RETVAL = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE;
- }
- OUTPUT:
- RETVAL
+ PREINIT:
+ bool result;
+ PPCODE:
+ if (ix) {
+ dSTCXT;
+
+ result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE;
+ } else {
+ result = !!last_op_in_netorder(aTHX);
+ }
+ ST(0) = boolSV(result);
+ XSRETURN(1);
https://perl5.git.perl.org / perl5.git / blobdiff