#endif
#if !defined(PERL_VERSION) || PERL_VERSION < 8
+#define NEED_load_module
+#define NEED_vload_module
+#define NEED_newCONSTSUB
#include "ppport.h" /* handle old perls */
#endif
#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
#endif
#ifndef HvRITER_set
-# define HvRITER_set(hv,r) (*HvRITER(hv) = r)
+# define HvRITER_set(hv,r) (HvRITER(hv) = r)
#endif
#ifndef HvEITER_set
-# define HvEITER_set(hv,r) (*HvEITER(hv) = r)
+# define HvEITER_set(hv,r) (HvEITER(hv) = r)
#endif
#ifndef HvRITER_get
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)(pTHX_ struct stcxt *, char *); /* retrieve dispatch table */
+ 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;
STMT_START { \
SV *self = newSV(sizeof(stcxt_t) - 1); \
SV *my_sv = newRV_noinc(self); \
- sv_bless(my_sv, gv_stashpv("Storable::Cxt", TRUE)); \
+ sv_bless(my_sv, gv_stashpv("Storable::Cxt", GV_ADD)); \
cxt = (stcxt_t *)SvPVX(self); \
Zero(cxt, 1, stcxt_t); \
cxt->my_sv = my_sv; \
} \
} STMT_END
+#define MBUF_SAFEPVREAD(x,s,z) \
+ STMT_START { \
+ if ((mptr + (s)) <= mend) { \
+ memcpy(x, mptr, s); \
+ mptr += s; \
+ } else { \
+ Safefree(z); \
+ return (SV *) 0; \
+ } \
+ } STMT_END
+
#define MBUF_PUTC(c) \
STMT_START { \
if (mptr < mend) \
} \
} STMT_END
+#define SAFEPVREAD(x,y,z) \
+ STMT_START { \
+ if (!cxt->fio) \
+ MBUF_SAFEPVREAD(x,y,z); \
+ else if (PerlIO_read(cxt->fio, x, y) != y) { \
+ Safefree(z); \
+ return (SV *) 0; \
+ } \
+ } STMT_END
+
/*
* This macro 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,
SV *ref; \
HV *stash; \
TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
- stash = gv_stashpv((p), TRUE); \
+ stash = gv_stashpv((p), GV_ADD); \
ref = newRV_noinc(s); \
(void) sv_bless(ref, stash); \
SvRV_set(ref, NULL); \
#endif /* PATCHLEVEL <= 6 */
static int store(pTHX_ stcxt_t *cxt, SV *sv);
-static SV *retrieve(pTHX_ stcxt_t *cxt, char *cname);
+static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
/*
* Dynamic dispatching table for SV store.
typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv);
-static sv_store_t sv_store[] = {
+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 */
* Dynamic dispatching tables for SV retrieval.
*/
-static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, char *cname);
-static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, char *cname);
-static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_ref(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_undef(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_integer(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_double(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_byte(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_netint(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_other(pTHX_ stcxt_t *cxt, char *cname);
-
-typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, char *name);
+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 */
(sv_retrieve_t)retrieve_other, /* SX_ERROR */
};
-static SV *retrieve_array(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_hash(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_hook(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, char *cname);
-static SV *retrieve_weakoverloaded(pTHX_ 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 */
*
* Tells whether we're in the middle of a store operation.
*/
-int is_storing(pTHX)
+static int is_storing(pTHX)
{
dSTCXT;
*
* Tells whether we're in the middle of a retrieve operation.
*/
-int is_retrieving(pTHX)
+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(pTHX)
+static int last_op_in_netorder(pTHX)
{
dSTCXT;
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
GV *gv;
SV *sv;
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
const char *hvname = HvNAME_get(pkg);
(void) hv_store(cache,
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
const char *hvname = HvNAME_get(pkg);
(void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
SV **svh;
SV *sv;
#else
HE *he = hv_iternext(hv);
#endif
- SV *key = hv_iterkeysv(he);
+ SV *key;
+
+ if (!he)
+ CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, len, i));
+ key = hv_iterkeysv(he);
av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
}
*/
for (i = 0; i < len; i++) {
- char *key;
+ char *key = 0;
I32 len;
unsigned char flags;
#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
*/
/* Ownership of both SVs is passed to load_module, which frees them. */
load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
+ SPAGAIN;
ENTER;
SAVETMPS;
CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
text = POPs;
- len = SvLEN(text);
+ len = SvCUR(text);
reallen = strlen(SvPV_nolen(text));
/*
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))
+ if ((fake_tag = (char *)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)))
return ret;
#ifdef USE_PTR_TABLE
- fake_tag = ptr_table_fetch(cxt->pseen, xsv);
+ fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
if (!sv)
CROAK(("Could not serialize item #%d from hook in %s", i, classname));
#else
#else
tag = *svh;
#endif
- ary[i] = tag
+ ary[i] = tag;
TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
i-1, PTR2UV(xsv), PTR2UV(tag)));
}
{
switch (SvTYPE(sv)) {
case SVt_NULL:
+#if PERL_VERSION <= 10
case SVt_IV:
+#endif
case SVt_NV:
/*
* No need to check for ROK, that can't be set here since there
*/
return svis_SCALAR;
case SVt_PV:
+#if PERL_VERSION <= 10
case SVt_RV:
+#else
+ case SVt_IV:
+#endif
case SVt_PVIV:
case SVt_PVNV:
/*
if (SvRMAGICAL(sv) && (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')))
return svis_TIED;
return SvROK(sv) ? svis_REF : svis_SCALAR;
return svis_HASH;
case SVt_PVCV:
return svis_CODE;
+#if PERL_VERSION > 8
+ /* case SVt_BIND: */
+#endif
default:
break;
}
*/
#ifdef USE_PTR_TABLE
- svh = ptr_table_fetch(pseen, sv);
+ svh = (SV **)ptr_table_fetch(pseen, sv);
#else
svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
#endif
* Store the transitive data closure of given object to disk.
* Returns 0 on error, a true value otherwise.
*/
-int pstore(pTHX_ PerlIO *f, SV *sv)
+static int pstore(pTHX_ PerlIO *f, SV *sv)
{
TRACEME(("pstore"));
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(pTHX_ PerlIO *f, SV *sv)
+static int net_pstore(pTHX_ PerlIO *f, SV *sv)
{
TRACEME(("net_pstore"));
return do_store(aTHX_ f, sv, 0, TRUE, (SV**) 0);
* Store the transitive data closure of given object to memory.
* Returns undef on error, a scalar value containing the data otherwise.
*/
-SV *mstore(pTHX_ SV *sv)
+static SV *mstore(pTHX_ SV *sv)
{
SV *out;
* Same as mstore(), but network order is used for integers and doubles are
* emitted as strings.
*/
-SV *net_mstore(pTHX_ SV *sv)
+static SV *net_mstore(pTHX_ SV *sv)
{
SV *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(pTHX_ 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(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 idx;
- char *classname;
+ const char *classname;
SV **sva;
SV *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(pTHX_ 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 *classname = buf;
+ char *malloced_classname = NULL;
TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
ASSERT(!cname, ("no bless-into class given here, got %s", cname));
RLEN(len);
TRACEME(("** allocating %d bytes for class name", len+1));
New(10003, classname, len+1, char);
+ malloced_classname = classname;
}
- READ(classname, len);
+ SAFEPVREAD(classname, len, malloced_classname);
classname[len] = '\0'; /* Mark string end */
/*
TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum));
- if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len)))
+ if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
+ Safefree(malloced_classname);
return (SV *) 0;
+ }
/*
* Retrieve object and bless it.
*/
sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */
- if (classname != buf)
- Safefree(classname);
+ if (malloced_classname)
+ Safefree(malloced_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(pTHX_ 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 */
* on the stack. Just like retrieve_blessed(), we limit the name to
* LG_BLESS bytes. This is an arbitrary decision.
*/
+ char *malloced_classname = NULL;
if (flags & SHF_LARGE_CLASSLEN)
RLEN(len);
if (len > LG_BLESS) {
TRACEME(("** allocating %d bytes for class name", len+1));
New(10003, classname, len+1, char);
+ malloced_classname = classname;
}
- READ(classname, len);
+ SAFEPVREAD(classname, len, malloced_classname);
classname[len] = '\0'; /* Mark string end */
/*
* Record new classname.
*/
- if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len)))
+ if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
+ Safefree(malloced_classname);
return (SV *) 0;
+ }
}
TRACEME(("class name: %s", classname));
* Hook not found. Maybe they did not require the module where this
* hook is defined yet?
*
- * If the require below succeeds, we'll be able to find the hook.
+ * If the load below succeeds, we'll be able to find the hook.
* Still, it only works reliably when each class is defined in a
* file of its own.
*/
- SV *psv = newSVpvn("require ", 8);
- sv_catpv(psv, classname);
-
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);
+ TRACEME(("Going to load module '%s'", classname));
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv);
/*
* We cache results of pkg_can, so we need to uncache before attempting
* into the existing design. -- RAM, 17/02/2001
*/
- sv_magic(sv, rv, mtype, Nullch, 0);
+ sv_magic(sv, rv, mtype, (char *)NULL, 0);
SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */
return sv;
* Retrieve reference to some other scalar.
* Layout is SX_REF <object>, with SX_REF already read.
*/
-static SV *retrieve_ref(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *rv;
SV *sv;
if (cname) {
/* No need to do anything, as rv will already be PVMG. */
- assert (SvTYPE(rv) >= SVt_RV);
+ assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV);
} else {
sv_upgrade(rv, SVt_RV);
}
* 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, char *cname)
+static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
* Retrieve reference to some other scalar with overloading.
* Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
*/
-static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *rv;
SV *sv;
* WARNING: breaks RV encapsulation.
*/
- sv_upgrade(rv, SVt_RV);
+ SvUPGRADE(rv, SVt_RV);
SvRV_set(rv, sv); /* $rv = \$sv */
SvROK_on(rv);
PTR2UV(sv)));
}
if (!Gv_AMG(stash)) {
- SV *psv = newSVpvn("require ", 8);
- const char *package = HvNAME_get(stash);
- sv_catpv(psv, package);
-
+ const char *package = HvNAME_get(stash);
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);
+ TRACEME(("Going to load module '%s'", package));
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv);
if (!Gv_AMG(stash)) {
CROAK(("Cannot restore overloading on %s(0x%"UVxf
") (package %s) (even after a \"require %s;\")",
* 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, char *cname)
+static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
* Retrieve tied array
* Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
*/
-static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
sv_upgrade(tv, SVt_PVAV);
AvREAL_off((AV *)tv);
- sv_magic(tv, sv, 'P', Nullch, 0);
+ sv_magic(tv, sv, 'P', (char *)NULL, 0);
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv)));
* Retrieve tied hash
* Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
*/
-static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
return (SV *) 0; /* Failed */
sv_upgrade(tv, SVt_PVHV);
- sv_magic(tv, sv, 'P', Nullch, 0);
+ sv_magic(tv, sv, 'P', (char *)NULL, 0);
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv)));
* Retrieve tied scalar
* Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
*/
-static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv, *obj = NULL;
}
sv_upgrade(tv, SVt_PVMG);
- sv_magic(tv, obj, 'q', Nullch, 0);
+ sv_magic(tv, obj, 'q', (char *)NULL, 0);
if (obj) {
/* Undo refcnt inc from sv_magic() */
* 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(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
* 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(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *tv;
SV *sv;
RLEN(idx); /* Retrieve <idx> */
sv_upgrade(tv, SVt_PVMG);
- sv_magic(tv, sv, 'p', Nullch, idx);
+ sv_magic(tv, sv, 'p', (char *)NULL, idx);
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
return tv;
* 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(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
SV *sv;
sv = NEWSV(10002, len);
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.
*
* The scalar is "short" so <length> is single byte. If it is 0, there
* is no <data> section.
*/
-static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname)
{
int len;
SV *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(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *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(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
* Retrieve defined integer.
* Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
*/
-static SV *retrieve_integer(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
IV iv;
* Retrieve defined integer in network order.
* Layout is SX_NETINT <data>, whith SX_NETINT already read.
*/
-static SV *retrieve_netint(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
I32 iv;
* Retrieve defined double.
* Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
*/
-static SV *retrieve_double(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
NV nv;
* Retrieve defined byte (small integer within the [-128, +127] range).
* Layout is SX_BYTE <data>, whith SX_BYTE already read.
*/
-static SV *retrieve_byte(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv;
int siv;
*
* Return the undefined value.
*/
-static SV *retrieve_undef(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname)
{
SV* sv;
*
* Return the immortal undefined value.
*/
-static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_undef;
*
* Return the immortal yes value.
*/
-static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_yes;
*
* Return the immortal no value.
*/
-static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname)
{
SV *sv = &PL_sv_no;
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *retrieve_array(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 i;
*
* When we come here, SX_HASH has been read already.
*/
-static SV *retrieve_hash(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 size;
*
* When we come here, SX_HASH has been read already.
*/
-static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
dVAR;
I32 len;
*
* Return a code reference.
*/
-static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname)
+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"));
*
* When we come here, SX_ARRAY has been read already.
*/
-static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, char *cname)
+static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 i;
*
* When we come here, SX_HASH has been read already.
*/
-static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, char *cname)
+static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
{
I32 len;
I32 size;
int length;
int use_network_order;
int use_NV_size;
+ int old_magic = 0;
int version_major;
int version_minor = 0;
if (memNE(buf, old_magicstr, old_len))
CROAK(("File is not a perl storable"));
+ old_magic++;
current = buf + old_len;
}
use_network_order = *current;
* indicate the version number of the binary, and therefore governs the
* setting of sv_retrieve_vtbl. See magic_write().
*/
-
- version_major = use_network_order >> 1;
- cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, char *cname)) (version_major ? sv_retrieve : sv_old_retrieve);
+ 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));
/* In C truth is 1, falsehood is 0. Very convienient. */
use_NV_size = version_major >= 2 && version_minor >= 2;
- GETMARK(c);
+ if (version_major >= 0) {
+ GETMARK(c);
+ }
+ else {
+ c = use_network_order;
+ }
length = c + 3 + use_NV_size;
READ(buf, length); /* Not null-terminated */
* root SV (which may be an AV or an HV for what we care).
* Returns null if there is a problem.
*/
-static SV *retrieve(pTHX_ stcxt_t *cxt, char *cname)
+static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname)
{
int type;
SV **svh;
*
* Retrieve data held in file and return the root object, undef on error.
*/
-SV *pretrieve(pTHX_ PerlIO *f)
+static SV *pretrieve(pTHX_ PerlIO *f)
{
TRACEME(("pretrieve"));
return do_retrieve(aTHX_ f, Nullsv, 0);
*
* Retrieve data held in scalar and return the root object, undef on error.
*/
-SV *mretrieve(pTHX_ SV *sv)
+static SV *mretrieve(pTHX_ SV *sv)
{
TRACEME(("mretrieve"));
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(pTHX_ SV *sv)
+static SV *dclone(pTHX_ SV *sv)
{
dSTCXT;
int size;
clean_context(aTHX_ cxt);
/*
+ * Tied elements seem to need special handling.
+ */
+
+ if ((SvTYPE(sv) == SVt_PVLV
+#if PERL_VERSION < 8
+ || SvTYPE(sv) == SVt_PVMG
+#endif
+ ) && 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.
*/
PROTOTYPES: ENABLE
BOOT:
+{
+ HV *stash = gv_stashpvn("Storable", 8, GV_ADD);
+ 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
#ifdef USE_56_INTERWORK_KLUDGE
gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
#endif
+}
void
init_perinterp()
projects / p5sagit/p5-mst-13.2.git / blobdiff