X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=84d76aa2fbcd42d65f5dc08865fa4a6c4b1eb8c9;hb=2018a5c31a07546d28320839d66a2fd3f203fa85;hp=c63864810c4b383cd979aea223b081a781c59ea9;hpb=c3551ae488bc41433f726ac687c347d8d300ac17;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index c638648..84d76aa 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -1082,7 +1082,7 @@ static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg);
 
 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 */
@@ -3099,7 +3099,7 @@ static int store_hook(
 #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)));
 	}
@@ -4283,19 +4283,14 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
 		 * 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
@@ -4540,15 +4535,10 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname)
 		       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;\")",
@@ -4767,6 +4757,11 @@ static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname)
 	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.
 	 *
@@ -5641,6 +5636,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
     int length;
     int use_network_order;
     int use_NV_size;
+    int old_magic = 0;
     int version_major;
     int version_minor = 0;
 
@@ -5674,6 +5670,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
             
             if (memNE(buf, old_magicstr, old_len))
                 CROAK(("File is not a perl storable"));
+	    old_magic++;
             current = buf + old_len;
         }
         use_network_order = *current;
@@ -5685,9 +5682,14 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
      * 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, const 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));
 
@@ -5750,7 +5752,12 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
     /* 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 */
 
@@ -6240,6 +6247,14 @@ static SV *dclone(pTHX_ SV *sv)
 		clean_context(aTHX_ cxt);
 
 	/*
+	 * Tied elements seem to need special handling.
+	 */
+
+	if (SvTYPE(sv) == SVt_PVLV && 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.
 	 */
@@ -6322,6 +6337,12 @@ MODULE = Storable	PACKAGE = Storable
 PROTOTYPES: ENABLE
 
 BOOT:
+{
+    HV *stash = gv_stashpvn("Storable", 8, TRUE);
+    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
@@ -6331,6 +6352,7 @@ BOOT:
 #ifdef USE_56_INTERWORK_KLUDGE
     gv_fetchpv("Storable::interwork_56_64bit",   GV_ADDMULTI, SVt_PV);
 #endif
+}
 
 void
 init_perinterp()