#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 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.
#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 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))
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 */
};
* 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>.
*/
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);
*/
switch (type) {
+ case svis_REF:
case svis_SCALAR:
obj_type = SHT_SCALAR;
break;
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;
case SVt_PVCV:
return svis_CODE;
#if PERL_VERSION > 8
- /* case SVt_BIND: */
+ /* case SVt_DUMMY: */
#endif
default:
break;
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));
}
}
/*
+ * 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.
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...
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...
#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
https://perl5.git.perl.org / perl5.git / blobdiff