#endif
#if !defined(PERL_VERSION) || PERL_VERSION < 8
+#define NEED_load_module
+#define NEED_vload_module
#include "ppport.h" /* handle old perls */
#endif
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); \
*/
/* 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;
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
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
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;
}
* 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));
* Tied elements seem to need special handling.
*/
- if (SvTYPE(sv) == SVt_PVLV && SvRMAGICAL(sv) && mg_find(sv, 'p')) {
+ if ((SvTYPE(sv) == SVt_PVLV
+#if PERL_VERSION < 8
+ || SvTYPE(sv) == SVt_PVMG
+#endif
+ ) && SvRMAGICAL(sv) && mg_find(sv, 'p')) {
mg_get(sv);
}
BOOT:
{
- HV *stash = gv_stashpvn("Storable", 8, TRUE);
+ 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));