X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FStorable%2FStorable.xs;h=5b3868b8f7e35aae95ae13ac138cf3d50908eddc;hb=821bf9a5d89e1fc44be0165540e1f57de5c874e1;hp=efa441a88d27662f418ab75fe1baa12403650d11;hpb=a2307be4b899f5bb1ef09b534ea96c8d5ffd7a73;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index efa441a..5b3868b 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -10,9 +10,15 @@ #include #include -#include /* Perl's one, needed since 5.6 */ #include +#ifndef PATCHLEVEL +# include /* Perl's one, needed since 5.6 */ +# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) +# include +# endif +#endif + #ifndef NETWARE #if 0 #define DEBUGME /* Debug mode, turns assertions on as well */ @@ -464,7 +470,7 @@ static stcxt_t *Context_ptr = NULL; if (!mbase) { \ TRACEME(("** allocating mbase of %d bytes", MGROW)); \ New(10003, mbase, MGROW, char); \ - msiz = MGROW; \ + msiz = (STRLEN)MGROW; \ } \ mptr = mbase; \ if (x) \ @@ -777,10 +783,21 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #define STORABLE_BIN_WRITE_MINOR 6 #endif /* (PATCHLEVEL <= 6) */ +#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) +#define PL_sv_placeholder PL_sv_undef +#endif + /* * Useful store shortcuts... */ +/* + * Note that if you put more than one mark for storing a particular + * type of thing, *and* in the retrieve_foo() function you mark both + * the thingy's you get off with SEEN(), you *must* increase the + * tagnum with cxt->tagnum++ along with this macro! + * - samv 20Jan04 + */ #define PUTMARK(x) \ STMT_START { \ if (!cxt->fio) \ @@ -844,12 +861,12 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) /* - * Store undef in arrays and hashes without recursing through store(). + * Store &PL_sv_undef in arrays without recursing through store(). */ -#define STORE_UNDEF() \ +#define STORE_SV_UNDEF() \ STMT_START { \ cxt->tagnum++; \ - PUTMARK(SX_UNDEF); \ + PUTMARK(SX_SV_UNDEF); \ } STMT_END /* @@ -1316,7 +1333,8 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) * new retrieve routines. */ - cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0); + cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) + ? newHV() : 0); cxt->aseen = newAV(); /* Where retrieved objects are kept */ cxt->aclass = newAV(); /* Where seen classnames are kept */ @@ -1954,7 +1972,7 @@ static int store_scalar(stcxt_t *cxt, SV *sv) #else SvIV_please(sv); - if (SvIOK(sv)) { + if (SvIOK_notUV(sv)) { iv = SvIV(sv); goto integer; /* Share code above */ } @@ -2030,7 +2048,7 @@ static int store_array(stcxt_t *cxt, AV *av) sav = av_fetch(av, i, 0); if (!sav) { TRACEME(("(#%d) undef item", i)); - STORE_UNDEF(); + STORE_SV_UNDEF(); continue; } TRACEME(("(#%d) item", i)); @@ -2201,7 +2219,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) = (((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) ? SHV_K_LOCKED : 0); - if (val == &PL_sv_undef) + if (val == &PL_sv_placeholder) flags |= SHV_K_PLACEHOLDER; keyval = SvPV(key, keylen_tmp); @@ -2242,7 +2260,13 @@ static int store_hash(stcxt_t *cxt, HV *hv) PUTMARK(flags); TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval)); } else { - assert (flags == 0); + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); TRACEME(("(#%d) key '%s'", i, keyval)); } WLEN(keylen); @@ -2263,7 +2287,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) /* * Storing in "random" order (in the order the keys are stored - * within the the hash). This is the default and will be faster! + * within the hash). This is the default and will be faster! */ for (i = 0; i < len; i++) { @@ -2297,7 +2321,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) = (((hash_flags & SHV_RESTRICTED) && SvREADONLY(val)) ? SHV_K_LOCKED : 0); - if (val == &PL_sv_undef) + if (val == &PL_sv_placeholder) flags |= SHV_K_PLACEHOLDER; hek = HeKEY_hek(he); @@ -2333,7 +2357,13 @@ static int store_hash(stcxt_t *cxt, HV *hv) PUTMARK(flags); TRACEME(("(#%d) key '%s' flags %x", i, key, flags)); } else { - assert (flags == 0); + /* This is a workaround for a bug in 5.8.0 + that causes the HEK_WASUTF8 flag to be + set on an HEK without the hash being + marked as having key flags. We just + cross our fingers and drop the flag. + AMS 20030901 */ + assert (flags == 0 || flags == SHV_K_WASUTF8); TRACEME(("(#%d) key '%s'", i, key)); } if (flags & SHV_K_ISSV) { @@ -2373,7 +2403,7 @@ static int store_code(stcxt_t *cxt, CV *cv) #else dSP; I32 len; - int ret, count, reallen; + int count, reallen; SV *text, *bdeparse; TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); @@ -2424,14 +2454,14 @@ static int store_code(stcxt_t *cxt, CV *cv) text = POPs; len = SvLEN(text); - reallen = strlen(SvPV(text,PL_na)); + reallen = strlen(SvPV_nolen(text)); /* * Empty code references or XS functions are deparsed as * "(prototype) ;" or ";". */ - if (len == 0 || *(SvPV(text,PL_na)+reallen-1) == ';') { + if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); } @@ -2440,14 +2470,15 @@ static int store_code(stcxt_t *cxt, CV *cv) */ PUTMARK(SX_CODE); + cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ TRACEME(("size = %d", len)); - TRACEME(("code = %s", SvPV(text,PL_na))); + TRACEME(("code = %s", SvPV_nolen(text))); /* * Now store the source code. */ - STORE_SCALAR(SvPV(text,PL_na), len); + STORE_SCALAR(SvPV_nolen(text), len); FREETMPS; LEAVE; @@ -2469,6 +2500,7 @@ static int store_code(stcxt_t *cxt, CV *cv) static int store_tied(stcxt_t *cxt, SV *sv) { MAGIC *mg; + SV *obj = NULL; int ret = 0; int svt = SvTYPE(sv); char mtype = 'P'; @@ -2514,7 +2546,9 @@ static int store_tied(stcxt_t *cxt, SV *sv) * accesses on the retrieved object will indeed call the magic methods... */ - if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ + /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ + obj = mg->mg_obj ? mg->mg_obj : newSV(0); + if ((ret = store(cxt, obj))) return ret; TRACEME(("ok (tied)")); @@ -3366,7 +3400,7 @@ static int magic_write(stcxt_t *cxt) length -= sizeof (magicstr) - 1; } - WRITE(header, length); + WRITE( (unsigned char*) header, length); if (!cxt->netorder) { TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", @@ -4125,7 +4159,14 @@ static SV *retrieve_ref(stcxt_t *cxt, char *cname) * an SX_OBJECT indication, a ref count increment was done. */ - sv_upgrade(rv, SVt_RV); + if (cname) { + /* Do not use sv_upgrade to preserve STASH */ + SvFLAGS(rv) &= ~SVTYPEMASK; + SvFLAGS(rv) |= SVt_RV; + } else { + sv_upgrade(rv, SVt_RV); + } + SvRV(rv) = sv; /* $rv = \$sv */ SvROK_on(rv); @@ -4169,10 +4210,11 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname) /* * Restore overloading magic. */ - - stash = (HV *) SvSTASH (sv); - if (!stash || !Gv_AMG(stash)) - CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)", + if (!SvTYPE(sv) + || !(stash = (HV *) SvSTASH (sv)) + || !Gv_AMG(stash)) + CROAK(("Cannot restore overloading on %s(0x%"UVxf + ") (package %s)", sv_reftype(sv, FALSE), PTR2UV(sv), stash ? HvNAME(stash) : "")); @@ -4250,19 +4292,27 @@ static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname) static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname) { SV *tv; - SV *sv; + SV *sv, *obj = NULL; TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); SEEN(tv, cname); /* Will return if rv is null */ sv = retrieve(cxt, 0); /* Retrieve */ - if (!sv) + if (!sv) { return (SV *) 0; /* Failed */ + } + else if (SvTYPE(sv) != SVt_NULL) { + obj = sv; + } sv_upgrade(tv, SVt_PVMG); - sv_magic(tv, sv, 'q', Nullch, 0); - SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ + sv_magic(tv, obj, 'q', Nullch, 0); + + if (obj) { + /* Undo refcnt inc from sv_magic() */ + SvREFCNT_dec(obj); + } TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv))); @@ -4654,6 +4704,7 @@ static SV *retrieve_sv_no(stcxt_t *cxt, char *cname) TRACEME(("retrieve_sv_no")); + cxt->tagnum--; /* undo the tagnum increment in retrieve_l?scalar */ SEEN(sv, cname); return sv; } @@ -4871,7 +4922,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) if (flags & SHV_K_PLACEHOLDER) { SvREFCNT_dec (sv); - sv = &PL_sv_undef; + sv = &PL_sv_placeholder; store_flags |= HVhek_PLACEHOLD; } if (flags & SHV_K_UTF8) { @@ -4904,7 +4955,7 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) */ #ifdef HAS_RESTRICTED_HASHES - if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0) + if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0) return (SV *) 0; #else if (!(store_flags & HVhek_PLACEHOLD)) @@ -4934,13 +4985,24 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) CROAK(("retrieve_code does not work with perl 5.005 or less\n")); #else dSP; - int type, count; + int type, count, tagnum; SV *cv; - SV *sv, *text, *sub, *errsv; + SV *sv, *text, *sub; TRACEME(("retrieve_code (#%d)", cxt->tagnum)); /* + * Insert dummy SV in the aseen array so that we don't screw + * up the tag numbers. We would just make the internal + * scalar an untagged item in the stream, but + * retrieve_scalar() calls SEEN(). So we just increase the + * tag number. + */ + tagnum = cxt->tagnum; + sv = newSViv(0); + SEEN(sv, cname); + + /* * Retrieve the source of the code reference * as a small or large scalar */ @@ -4962,7 +5024,7 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) */ sub = newSVpvn("sub ", 4); - sv_catpv(sub, SvPV(text, PL_na)); /* XXX no sv_catsv! */ + sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ SvREFCNT_dec(text); /* @@ -4982,6 +5044,8 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) CROAK(("Can't eval, please set $Storable::Eval to a true value")); } else { sv = newSVsv(sub); + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); return sv; } } @@ -5001,16 +5065,17 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) CROAK(("Unexpected return value from $Storable::Eval callback\n")); cv = POPs; if (SvTRUE(errsv)) { - CROAK(("code %s caused an error: %s", SvPV(sub, PL_na), SvPV(errsv, PL_na))); + CROAK(("code %s caused an error: %s", + SvPV_nolen(sub), SvPV_nolen(errsv))); } PUTBACK; } else { - cv = eval_pv(SvPV(sub, PL_na), TRUE); + cv = eval_pv(SvPV_nolen(sub), TRUE); } if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { sv = SvRV(cv); } else { - CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV(sub, PL_na))); + CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); } SvREFCNT_inc(sv); /* XXX seems to be necessary */ @@ -5018,8 +5083,9 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname) FREETMPS; LEAVE; + /* fix up the dummy entry... */ + av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); - SEEN(sv, cname); return sv; #endif } @@ -5859,6 +5925,9 @@ BOOT: gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); #endif +void +init_perinterp() + int pstore(f,obj) OutputStream f