X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=d3c0fab3866d96365a6830f82123c74e41828282;hb=e9d185f8391f09209c11be82e97358d853f1ba30;hp=628dd0a106e98aa6386db2e8ad123b883dec4edd;hpb=c69006e4a4556d3b1d6e1a57c49a95b1d16efeb0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 628dd0a..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 @@ -86,14 +88,24 @@ typedef double NV; /* Older perls lack the NV type */ #endif #endif -#ifdef HASATTRIBUTE -# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) -# define PERL_UNUSED_DECL +#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 +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif # else -# define PERL_UNUSED_DECL __attribute__((unused)) +# define PERL_UNUSED_DECL # endif -#else -# define PERL_UNUSED_DECL #endif #ifndef dNOOP @@ -104,6 +116,28 @@ typedef double NV; /* Older perls lack the NV type */ #define dVAR dNOOP #endif +#ifndef HvRITER_set +# define HvRITER_set(hv,r) (HvRITER(hv) = r) +#endif +#ifndef HvEITER_set +# define HvEITER_set(hv,r) (HvEITER(hv) = r) +#endif + +#ifndef HvRITER_get +# define HvRITER_get HvRITER +#endif +#ifndef HvEITER_get +# define HvEITER_get HvEITER +#endif + +#ifndef HvNAME_get +#define HvNAME_get HvNAME +#endif + +#ifndef HvPLACEHOLDERS_get +# define HvPLACEHOLDERS_get HvPLACEHOLDERS +#endif + #ifdef DEBUGME #ifndef DASSERT @@ -347,7 +381,7 @@ typedef struct stcxt { 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; @@ -356,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; \ @@ -624,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) \ @@ -954,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, @@ -994,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); \ @@ -1032,7 +1087,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #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. @@ -1067,24 +1122,24 @@ static const sv_store_t sv_store[] = { * 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 */ @@ -1119,21 +1174,21 @@ static const sv_retrieve_t sv_old_retrieve[] = { (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 */ @@ -1576,7 +1631,7 @@ static void free_context(pTHX_ stcxt_t *cxt) * * Tells whether we're in the middle of a store operation. */ -int is_storing(pTHX) +static int is_storing(pTHX) { dSTCXT; @@ -1588,7 +1643,7 @@ int is_storing(pTHX) * * Tells whether we're in the middle of a retrieve operation. */ -int is_retrieving(pTHX) +static int is_retrieving(pTHX) { dSTCXT; @@ -1603,7 +1658,7 @@ int is_retrieving(pTHX) * 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; @@ -1630,6 +1685,8 @@ static SV *pkg_fetchmeth( { GV *gv; SV *sv; + const char *hvname = HvNAME_get(pkg); + /* * The following code is the same as the one performed by UNIVERSAL::can @@ -1639,10 +1696,10 @@ static SV *pkg_fetchmeth( gv = gv_fetchmethod_autoload(pkg, method, FALSE); if (gv && isGV(gv)) { sv = newRV((SV*) GvCV(gv)); - TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv))); + TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv))); } else { sv = newSVsv(&PL_sv_undef); - TRACEME(("%s->%s: not found", HvNAME(pkg), method)); + TRACEME(("%s->%s: not found", hvname, method)); } /* @@ -1650,7 +1707,7 @@ static SV *pkg_fetchmeth( * it just won't be cached. */ - (void) hv_store(cache, HvNAME(pkg), strlen(HvNAME(pkg)), sv, 0); + (void) hv_store(cache, hvname, strlen(hvname), sv, 0); return SvOK(sv) ? sv : (SV *) 0; } @@ -1666,8 +1723,9 @@ static void pkg_hide( HV *pkg, char *method) { + const char *hvname = HvNAME_get(pkg); (void) hv_store(cache, - HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0); + hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); } /* @@ -1681,7 +1739,8 @@ static void pkg_uncache( HV *pkg, char *method) { - (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD); + const char *hvname = HvNAME_get(pkg); + (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); } /* @@ -1700,8 +1759,9 @@ static SV *pkg_can( { SV **svh; SV *sv; + const char *hvname = HvNAME_get(pkg); - TRACEME(("pkg_can for %s->%s", HvNAME(pkg), method)); + TRACEME(("pkg_can for %s->%s", hvname, method)); /* * Look into the cache to see whether we already have determined @@ -1711,15 +1771,15 @@ static SV *pkg_can( * that only one hook (i.e. always the same) is cached in a given cache. */ - svh = hv_fetch(cache, HvNAME(pkg), strlen(HvNAME(pkg)), FALSE); + svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); if (svh) { sv = *svh; if (!SvOK(sv)) { - TRACEME(("cached %s->%s: not found", HvNAME(pkg), method)); + TRACEME(("cached %s->%s: not found", hvname, method)); return (SV *) 0; } else { TRACEME(("cached %s->%s: 0x%"UVxf, - HvNAME(pkg), method, PTR2UV(sv))); + hvname, method, PTR2UV(sv))); return sv; } } @@ -2253,8 +2313,8 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) * Save possible iteration state via each() on that table. */ - riter = HvRITER(hv); - eiter = HvEITER(hv); + riter = HvRITER_get(hv); + eiter = HvEITER_get(hv); hv_iterinit(hv); /* @@ -2292,7 +2352,11 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) #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 */ } @@ -2300,7 +2364,7 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) for (i = 0; i < len; i++) { #ifdef HAS_RESTRICTED_HASHES - int placeholders = (int)HvPLACEHOLDERS(hv); + int placeholders = (int)HvPLACEHOLDERS_get(hv); #endif unsigned char flags = 0; char *keyval; @@ -2430,7 +2494,7 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) */ for (i = 0; i < len; i++) { - char *key; + char *key = 0; I32 len; unsigned char flags; #ifdef HV_ITERNEXT_WANTPLACEHOLDERS @@ -2522,8 +2586,8 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv))); out: - HvRITER(hv) = riter; /* Restore hash iterator state */ - HvEITER(hv) = eiter; + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); return ret; } @@ -2565,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; @@ -2596,7 +2661,7 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv) CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); text = POPs; - len = SvLEN(text); + len = SvCUR(text); reallen = strlen(SvPV_nolen(text)); /* @@ -2828,7 +2893,7 @@ static int store_hook( char mtype = '\0'; /* for blessed ref to tied structures */ unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ - TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum)); + TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum)); /* * Determine object type on 2 bits. @@ -2879,7 +2944,7 @@ static int store_hook( } flags = SHF_NEED_RECURSE | obj_type; - classname = HvNAME(pkg); + classname = HvNAME_get(pkg); len = strlen(classname); /* @@ -2987,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))) @@ -3020,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 @@ -3062,7 +3127,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))); } @@ -3247,7 +3312,7 @@ static int store_blessed( char *classname; I32 classnum; - TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME(pkg))); + TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg))); /* * Look for a hook for this blessed SV and redirect to store_hook() @@ -3262,7 +3327,7 @@ static int store_blessed( * This is a blessed SV without any serialization hook. */ - classname = HvNAME(pkg); + classname = HvNAME_get(pkg); len = strlen(classname); TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d", @@ -3394,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; @@ -3408,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; } @@ -3450,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 @@ -3769,7 +3839,7 @@ static int do_store( * 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); @@ -3782,7 +3852,7 @@ int pstore(pTHX_ PerlIO *f, SV *sv) * 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); @@ -3810,7 +3880,7 @@ static SV *mbuf2sv(pTHX) * 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; @@ -3828,7 +3898,7 @@ SV *mstore(pTHX_ SV *sv) * 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; @@ -3850,7 +3920,7 @@ SV *net_mstore(pTHX_ SV *sv) * 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 && @@ -3875,10 +3945,10 @@ static SV *retrieve_other(pTHX_ stcxt_t *cxt, char *cname) * Layout is SX_IX_BLESS with SX_IX_BLESS already read. * 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; @@ -3916,12 +3986,13 @@ static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, char *cname) * Layout is SX_BLESS with SX_BLESS already read. * 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)); @@ -3938,8 +4009,9 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, 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 */ /* @@ -3948,16 +4020,18 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, 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; } @@ -3982,7 +4056,7 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, char *cname) * 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 */ @@ -4109,6 +4183,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, 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); @@ -4118,17 +4193,20 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, 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)); @@ -4246,19 +4324,14 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, 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 @@ -4382,7 +4455,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, char *cname) * Retrieve reference to some other scalar. * Layout is SX_REF , 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; @@ -4442,7 +4515,7 @@ static SV *retrieve_ref(pTHX_ stcxt_t *cxt, char *cname) * Retrieve weak reference to some other scalar. * Layout is SX_WEAKREF , 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; @@ -4465,7 +4538,7 @@ static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, char *cname) * Retrieve reference to some other scalar with overloading. * Layout is SX_OVERLOAD , 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; @@ -4503,15 +4576,10 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname) PTR2UV(sv))); } if (!Gv_AMG(stash)) { - SV *psv = newSVpvn("require ", 8); - const char *package = HvNAME(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;\")", @@ -4534,7 +4602,7 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname) * Retrieve weak overloaded reference to some other scalar. * Layout is SX_WEAKOVERLOADED , 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; @@ -4557,7 +4625,7 @@ static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, char *cname) * Retrieve tied array * Layout is SX_TIED_ARRAY , 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; @@ -4586,7 +4654,7 @@ static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, char *cname) * Retrieve tied hash * Layout is SX_TIED_HASH , 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; @@ -4614,7 +4682,7 @@ static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, char *cname) * Retrieve tied scalar * Layout is SX_TIED_SCALAR , 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; @@ -4650,7 +4718,7 @@ static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, char *cname) * Retrieve reference to value in a tied hash. * Layout is SX_TIED_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; @@ -4682,7 +4750,7 @@ static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, char *cname) * Retrieve reference to value in a tied array. * Layout is SX_TIED_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; @@ -4715,7 +4783,7 @@ static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, char *cname) * The scalar is "long" in that 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; @@ -4730,6 +4798,11 @@ static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, 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. * @@ -4761,7 +4834,7 @@ static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, char *cname) * The scalar is "short" so is single byte. If it is 0, there * is no 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; @@ -4820,7 +4893,7 @@ static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, char *cname) * 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; @@ -4849,7 +4922,7 @@ static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, char *cname) * 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; @@ -4877,7 +4950,7 @@ static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, char *cname) * Retrieve defined integer. * Layout is SX_INTEGER , 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; @@ -4900,7 +4973,7 @@ static SV *retrieve_integer(pTHX_ stcxt_t *cxt, char *cname) * Retrieve defined integer in network order. * Layout is SX_NETINT , 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; @@ -4928,7 +5001,7 @@ static SV *retrieve_netint(pTHX_ stcxt_t *cxt, char *cname) * Retrieve defined double. * Layout is SX_DOUBLE , 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; @@ -4951,7 +5024,7 @@ static SV *retrieve_double(pTHX_ stcxt_t *cxt, char *cname) * Retrieve defined byte (small integer within the [-128, +127] range). * Layout is SX_BYTE , 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; @@ -4976,7 +5049,7 @@ static SV *retrieve_byte(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -4993,7 +5066,7 @@ static SV *retrieve_undef(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5014,7 +5087,7 @@ static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5029,7 +5102,7 @@ static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5048,7 +5121,7 @@ static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5099,7 +5172,7 @@ static SV *retrieve_array(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5173,7 +5246,7 @@ static SV *retrieve_hash(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5310,7 +5383,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname) * * 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")); @@ -5431,7 +5504,7 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5491,7 +5564,7 @@ static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, char *cname) * * 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; @@ -5604,6 +5677,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; @@ -5637,6 +5711,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; @@ -5648,9 +5723,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, 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)); @@ -5713,7 +5793,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 */ @@ -5763,7 +5848,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) * 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; @@ -6155,7 +6240,7 @@ static SV *do_retrieve( * * 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); @@ -6166,7 +6251,7 @@ SV *pretrieve(pTHX_ PerlIO *f) * * 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); @@ -6185,7 +6270,7 @@ SV *mretrieve(pTHX_ SV *sv) * 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; @@ -6203,6 +6288,18 @@ SV *dclone(pTHX_ SV *sv) 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. */ @@ -6285,6 +6382,12 @@ MODULE = Storable PACKAGE = Storable 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 @@ -6294,6 +6397,7 @@ BOOT: #ifdef USE_56_INTERWORK_KLUDGE gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); #endif +} void init_perinterp()