X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=d3c0fab3866d96365a6830f82123c74e41828282;hb=e9d185f8391f09209c11be82e97358d853f1ba30;hp=a8beda151df9141118d4e249bd21aafbcfe5eb86;hpb=0d3260984663aa39a4c25834f566132d81a03c27;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index a8beda1..d3c0fab 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -18,6 +18,8 @@
 #endif
 
 #if !defined(PERL_VERSION) || PERL_VERSION < 8
+#define NEED_load_module
+#define NEED_vload_module
 #include "ppport.h"             /* handle old perls */
 #endif
 
@@ -388,7 +390,7 @@ typedef struct stcxt {
   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;								\
@@ -656,6 +658,17 @@ static stcxt_t *Context_ptr = NULL;
 	}								\
   } 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)				\
@@ -986,6 +999,16 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 	}											\
   } 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,
@@ -1026,7 +1049,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 	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);						\
@@ -2606,6 +2629,7 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
 	 */
 	/* 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;
@@ -3028,7 +3052,7 @@ static int store_hook(
 		   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)))
@@ -3061,7 +3085,7 @@ static int store_hook(
 			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
@@ -3435,7 +3459,9 @@ static int sv_type(pTHX_ SV *sv)
 		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;
@@ -3449,6 +3475,9 @@ static int sv_type(pTHX_ SV *sv)
 		return svis_HASH;
 	case SVt_PVCV:
 		return svis_CODE;
+#if PERL_VERSION > 8
+	/* case SVt_BIND: */
+#endif
 	default:
 		break;
 	}
@@ -3491,7 +3520,7 @@ static int store(pTHX_ stcxt_t *cxt, SV *sv)
 	 */
 
 #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
@@ -3963,6 +3992,7 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
 	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));
@@ -3979,8 +4009,9 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *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 */
 
 	/*
@@ -3989,16 +4020,18 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
 
 	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;
 }
@@ -4150,6 +4183,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
 		 * 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);
@@ -4159,17 +4193,20 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
 		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));
@@ -6254,7 +6291,11 @@ static SV *dclone(pTHX_ SV *sv)
 	 * 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);
 	}
 
@@ -6342,7 +6383,7 @@ PROTOTYPES: ENABLE
 
 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));