X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=d3c0fab3866d96365a6830f82123c74e41828282;hb=e9d185f8391f09209c11be82e97358d853f1ba30;hp=cd3a41a92e7fbd99d6c572cc85dbe70e54f46433;hpb=d4b9b6e4cc25d0e932fd120c48e967f642ccbc07;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index cd3a41a..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); \ @@ -2329,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 */ } @@ -2602,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; @@ -3024,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))) @@ -3057,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 @@ -3099,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))); } @@ -3431,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; @@ -3445,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; } @@ -3487,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 @@ -3959,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)); @@ -3975,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 */ /* @@ -3985,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; } @@ -4146,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); @@ -4155,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)); @@ -4283,19 +4324,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 +4576,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 +4798,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. * @@ -6255,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 +6382,8 @@ MODULE = Storable PACKAGE = Storable 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)); @@ -6356,6 +6397,7 @@ BOOT: #ifdef USE_56_INTERWORK_KLUDGE gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); #endif +} void init_perinterp()