X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=a59af0d02e3b897ed07db4cc32142ebb25e8aa58;hb=b68c599a1231c4d11ec0b0a667ce0c407c357eab;hp=7844c498c5780ad554ca74e1164f6bf28c7dc5c3;hpb=ceb531cd9f4a607a106933280c868d236b5c51fa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 7844c49..a59af0d 100644 --- a/sv.c +++ b/sv.c @@ -916,9 +916,11 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - /* 32 */ - { sizeof(struct xregexp), copy_length(struct xregexp, xrx_regexp), 0, - SVt_REGEXP, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(struct xregexp)) + /* something big */ + { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated), + + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur), + SVt_REGEXP, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(struct regexp_allocated)) }, /* 48 */ @@ -1397,27 +1399,18 @@ wrapper instead. int Perl_sv_backoff(pTHX_ register SV *sv) { + STRLEN delta; + const char * const s = SvPVX_const(sv); PERL_UNUSED_CONTEXT; assert(SvOOK(sv)); assert(SvTYPE(sv) != SVt_PVHV); assert(SvTYPE(sv) != SVt_PVAV); - if (SvIVX(sv)) { - const char * const s = SvPVX_const(sv); -#ifdef DEBUGGING - /* Validate the preceding buffer's sentinals to verify that no-one is - using it. */ - const U8 *p = (const U8*) s; - const U8 *const real_start = p - SvIVX(sv); - while (p > real_start) { - --p; - assert (*p == (U8)PTR2UV(p)); - } -#endif - SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); - SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); - SvIV_set(sv, 0); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); - } + + SvOOK_offset(sv, delta); + + SvLEN_set(sv, SvLEN(sv) + delta); + SvPV_set(sv, SvPVX(sv) - delta); + Move(s, SvPVX(sv), SvCUR(sv)+1, char); SvFLAGS(sv) &= ~SVf_OOK; return 0; } @@ -1655,7 +1648,7 @@ S_not_a_number(pTHX_ SV *sv) const char *pv; if (DO_UTF8(sv)) { - dsv = sv_2mortal(newSVpvs("")); + dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 10, 0); } else { char *d = tmpbuf; @@ -1869,10 +1862,13 @@ S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ STATIC int -S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) +S_sv_2iuv_non_preserve(pTHX_ register SV *sv +# ifdef DEBUGGING + , I32 numtype +# endif + ) { dVAR; - PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); @@ -1953,7 +1949,11 @@ S_sv_2iuv_common(pTHX_ SV *sv) { we're outside the range of NV integer precision */ #endif ) { - SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + if (SvNOK(sv)) + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + else { + /* scalar has trailing garbage, eg "42a" */ + } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), @@ -1992,6 +1992,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif + && SvNOK(sv) ) SvIOK_on(sv); SvIsUV_on(sv); @@ -2145,10 +2146,20 @@ S_sv_2iuv_common(pTHX_ SV *sv) { 1 1 already read UV. so there's no point in sv_2iuv_non_preserve() attempting to use atol, strtol, strtoul etc. */ +# ifdef DEBUGGING sv_2iuv_non_preserve (sv, numtype); +# else + sv_2iuv_non_preserve (sv); +# endif } } #endif /* NV_PRESERVES_UV */ + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvIOKp_on() rather than SvIOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); } } else { @@ -2417,11 +2428,15 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvIOKp(sv)) { SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV - SvNOK_on(sv); + if (SvIOK(sv)) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else /* Only set the public NV OK flag if this NV preserves the IV */ /* Check it's not 0xFFFFFFFFFFFFFFFF */ - if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + if (SvIOK(sv) && + SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) : (SvIVX(sv) == I_V(SvNVX(sv)))) SvNOK_on(sv); else @@ -2440,7 +2455,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); } else SvNV_set(sv, Atof(SvPVX_const(sv))); - SvNOK_on(sv); + if (numtype) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else SvNV_set(sv, Atof(SvPVX_const(sv))); /* Only set the public NV OK flag if this NV preserves the value in @@ -2507,6 +2525,12 @@ Perl_sv_2nv(pTHX_ register SV *sv) } } } + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvNOKp_on() rather than SvNOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); #endif /* NV_PRESERVES_UV */ } else { @@ -2709,20 +2733,25 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) len = 7; retval = buffer = savepvn("NULLREF", len); } else if (SvTYPE(referent) == SVt_REGEXP) { - char *str = NULL; - I32 haseval = 0; - U32 flags = 0; - struct magic temp; - temp.mg_obj - = (SV*)((struct xregexp *)SvANY(referent))->xrx_regexp; - assert(temp.mg_obj); - (str) = CALLREG_AS_STR(&temp,lp,&flags,&haseval); - if (flags & 1) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - PL_reginterp_cnt += haseval; - return str; + const REGEXP * const re = (REGEXP *)referent; + I32 seen_evals = 0; + + assert(re); + + /* If the regex is UTF-8 we want the containing scalar to + have an UTF-8 flag too */ + if (RX_UTF8(re)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + + if ((seen_evals = RX_SEEN_EVALS(re))) + PL_reginterp_cnt += seen_evals; + + if (lp) + *lp = RX_WRAPLEN(re); + + return RX_WRAPPED(re); } else { const char *const typestr = sv_reftype(referent, 0); const STRLEN typelen = strlen(typestr); @@ -2788,10 +2817,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); if (lp) *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); return (char *)""; } } @@ -2845,10 +2876,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (isGV_with_GP(sv)) return glob_2pv((GV *)sv, lp); - if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); if (lp) *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); @@ -3505,6 +3538,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } /* Fall through */ #endif + case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3778,7 +3812,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { - SvOOK_off(dstr); SvIV_set(dstr, SvIVX(sstr)); /* Must do this otherwise some other overloaded use of 0x80000000 gets confused. I guess SVpbm_VALID */ @@ -4217,7 +4250,13 @@ refer to the same chunk of data. void Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) { - register STRLEN delta; + STRLEN delta; + STRLEN old_delta; + U8 *p; +#ifdef DEBUGGING + const U8 *real_start; +#endif + if (!ptr || !SvPOKp(sv)) return; delta = ptr - SvPVX_const(sv); @@ -4227,8 +4266,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) } assert(ptr > SvPVX_const(sv)); SV_CHECK_THINKFIRST(sv); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -4238,27 +4275,38 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } - SvIV_set(sv, 0); - /* Same SvOOK_on but SvOOK_on does a SvIOK_off - and we do that anyway inside the SvNIOK_off - */ SvFLAGS(sv) |= SVf_OOK; + old_delta = 0; + } else { + SvOOK_offset(sv, old_delta); } - SvNIOK_off(sv); SvLEN_set(sv, SvLEN(sv) - delta); SvCUR_set(sv, SvCUR(sv) - delta); SvPV_set(sv, SvPVX(sv) + delta); - SvIV_set(sv, SvIVX(sv) + delta); + + p = (U8 *)SvPVX_const(sv); + + delta += old_delta; + #ifdef DEBUGGING - { - /* Fill the preceding buffer with sentinals to verify that no-one is - using it. */ - U8 *p = (U8*) SvPVX(sv); - const U8 *const real_start = p - SvIVX(sv); - while (p > real_start) { - --p; - *p = (U8)PTR2UV(p); - } + real_start = p - delta; +#endif + + assert(delta); + if (delta < 0x100) { + *--p = (U8) delta; + } else { + *--p = 0; + p -= sizeof(STRLEN); + Copy((U8*)&delta, p, sizeof(STRLEN), U8); + } + +#ifdef DEBUGGING + /* Fill the preceding buffer with sentinals to verify that no-one is + using it. */ + while (p > real_start) { + --p; + *p = (U8)PTR2UV(p); } #endif } @@ -4343,7 +4391,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* const csv = sv_2mortal(newSVpvn(spv, slen)); + SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP); sv_utf8_upgrade(csv); spv = SvPV_const(csv, slen); @@ -4475,7 +4523,6 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || - how == PERL_MAGIC_qr || how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || @@ -5232,7 +5279,8 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoBOTTOM_NAME(sv)); goto freescalar; case SVt_REGEXP: - ReREFCNT_dec(((struct xregexp *)SvANY(sv))->xrx_regexp); + /* FIXME for plugins */ + pregfree2((REGEXP*) sv); goto freescalar; case SVt_PVCV: case SVt_PVFM: @@ -5277,13 +5325,15 @@ Perl_sv_clear(pTHX_ register SV *sv) case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: + case SVt_PV: freescalar: /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ if (SvOOK(sv)) { - SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); + STRLEN offset; + SvOOK_offset(sv, offset); + SvPV_set(sv, SvPVX_mutable(sv) - offset); /* Don't even bother with turning off the OOK flag. */ } - case SVt_PV: if (SvROK(sv)) { SV * const target = SvRV(sv); if (SvWEAKREF(sv)) @@ -5385,17 +5435,28 @@ Perl_sv_free(pTHX_ SV *sv) return; } if (ckWARN_d(WARN_INTERNAL)) { - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced scalar: SV 0x%"UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP Perl_dump_sv_child(aTHX_ sv); #else #ifdef DEBUG_LEAKING_SCALARS - sv_dump(sv); + sv_dump(sv); #endif +#ifdef DEBUG_LEAKING_SCALARS_ABORT + if (PL_warnhook == PERL_WARNHOOK_FATAL + || ckDEAD(packWARN(WARN_INTERNAL))) { + /* Don't let Perl_warner cause us to escape our fate: */ + abort(); + } +#endif + /* This may not return: */ + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced scalar: SV 0x%"UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); #endif } +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif return; } if (--(SvREFCNT(sv)) > 0) @@ -6041,8 +6102,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) * invalidate pv1, so we may need to make a copy */ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { pv1 = SvPV_const(sv1, cur1); - sv1 = sv_2mortal(newSVpvn(pv1, cur1)); - if (SvUTF8(sv2)) SvUTF8_on(sv1); + sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); } pv1 = SvPV_const(sv1, cur1); } @@ -6199,7 +6259,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 'use bytes' aware, handles get magic, and will coerce its args to strings -if necessary. See also C. See also C. +if necessary. See also C. =cut */ @@ -6741,8 +6801,15 @@ Perl_sv_inc(pTHX_ register SV *sv) return; } if (flags & SVp_NOK) { + const NV was = SvNVX(sv); + if (NV_OVERFLOWS_INTEGERS_AT && + was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { + Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when incrementing %" NVff " by 1", + was); + } (void)SvNOK_only(sv); - SvNV_set(sv, SvNVX(sv) + 1.0); + SvNV_set(sv, was + 1.0); return; } @@ -6886,8 +6953,10 @@ Perl_sv_dec(pTHX_ register SV *sv) SvUV_set(sv, SvUVX(sv) - 1); } } else { - if (SvIVX(sv) == IV_MIN) - sv_setnv(sv, (NV)IV_MIN - 1.0); + if (SvIVX(sv) == IV_MIN) { + sv_setnv(sv, (NV)IV_MIN); + goto oops_its_num; + } else { (void)SvIOK_only(sv); SvIV_set(sv, SvIVX(sv) - 1); @@ -6896,9 +6965,19 @@ Perl_sv_dec(pTHX_ register SV *sv) return; } if (flags & SVp_NOK) { - SvNV_set(sv, SvNVX(sv) - 1.0); - (void)SvNOK_only(sv); - return; + oops_its_num: + { + const NV was = SvNVX(sv); + if (NV_OVERFLOWS_INTEGERS_AT && + was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { + Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when decrementing %" NVff " by 1", + was); + } + (void)SvNOK_only(sv); + SvNV_set(sv, was - 1.0); + return; + } } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVIV) @@ -6998,6 +7077,40 @@ Perl_sv_newmortal(pTHX) return sv; } + +/* +=for apidoc newSVpvn_flags + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. Note that if C is zero, Perl will create a zero length +string. You are responsible for ensuring that the source string is at least +C bytes long. If the C argument is NULL the new SV will be undefined. +Currently the only flag bits accepted are C and C. +If C is set, then C is called on the result before +returning. If C is set, then it will be set on the new SV. +C is a convenience wrapper for this function, defined as + + #define newSVpvn_utf8(s, len, u) \ + newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) + +=cut +*/ + +SV * +Perl_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) +{ + dVAR; + register SV *sv; + + /* All the flags we don't support must be zero. + And we're new code so I'm going to assert this from the start. */ + assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); + new_SV(sv); + sv_setpvn(sv,s,len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + /* =for apidoc sv_2mortal @@ -7067,7 +7180,6 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) return sv; } - /* =for apidoc newSVhek @@ -7799,7 +7911,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; - case SVt_REGEXP: return "Regexp"; /* FIXME? to "REGEXP" */ + case SVt_REGEXP: return "REGEXP"; default: return "UNKNOWN"; } } @@ -9498,7 +9610,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else { const STRLEN old_elen = elen; - SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); + SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); sv_utf8_upgrade(nsv); eptr = SvPVX_const(nsv); elen = SvCUR(nsv); @@ -9822,10 +9934,13 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; + /* FIXME for plugins if (mg->mg_type == PERL_MAGIC_qr) { nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); } - else if(mg->mg_type == PERL_MAGIC_backref) { + else + */ + if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by 1. */ nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param)); @@ -10061,8 +10176,14 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) dVAR; SV *dstr; - if (!sstr || SvTYPE(sstr) == SVTYPEMASK) + if (!sstr) return NULL; + if (SvTYPE(sstr) == SVTYPEMASK) { +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif + return NULL; + } /* look for it in the table first */ dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); if (dstr) @@ -10205,9 +10326,8 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVMG: break; case SVt_REGEXP: - ((struct xregexp *)SvANY(dstr))->xrx_regexp - = CALLREGDUPE(((struct xregexp *)SvANY(dstr))->xrx_regexp, - param); + /* FIXME for plugins */ + re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); break; case SVt_PVLV: /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ @@ -10393,69 +10513,55 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) return ncxs; /* create anew and remember what it is */ - Newxz(ncxs, max + 1, PERL_CONTEXT); + Newx(ncxs, max + 1, PERL_CONTEXT); ptr_table_store(PL_ptr_table, cxs, ncxs); + Copy(cxs, ncxs, max + 1, PERL_CONTEXT); while (ix >= 0) { - PERL_CONTEXT * const cx = &cxs[ix]; PERL_CONTEXT * const ncx = &ncxs[ix]; - ncx->cx_type = cx->cx_type; - if (CxTYPE(cx) == CXt_SUBST) { + if (CxTYPE(ncx) == CXt_SUBST) { Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); } else { - ncx->blk_oldsp = cx->blk_oldsp; - ncx->blk_oldcop = cx->blk_oldcop; - ncx->blk_oldmarksp = cx->blk_oldmarksp; - ncx->blk_oldscopesp = cx->blk_oldscopesp; - ncx->blk_oldpm = cx->blk_oldpm; - ncx->blk_gimme = cx->blk_gimme; - switch (CxTYPE(cx)) { + switch (CxTYPE(ncx)) { case CXt_SUB: - ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 - ? cv_dup_inc(cx->blk_sub.cv, param) - : cv_dup(cx->blk_sub.cv,param)); - ncx->blk_sub.argarray = (cx->blk_sub.hasargs - ? av_dup_inc(cx->blk_sub.argarray, param) + ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 + ? cv_dup_inc(ncx->blk_sub.cv, param) + : cv_dup(ncx->blk_sub.cv,param)); + ncx->blk_sub.argarray = (CxHASARGS(ncx) + ? av_dup_inc(ncx->blk_sub.argarray, + param) : NULL); - ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); - ncx->blk_sub.olddepth = cx->blk_sub.olddepth; - ncx->blk_sub.hasargs = cx->blk_sub.hasargs; - ncx->blk_sub.lval = cx->blk_sub.lval; - ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray, + param); ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - cx->blk_sub.oldcomppad); + ncx->blk_sub.oldcomppad); break; case CXt_EVAL: - ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; - ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param); - ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; - ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); - ncx->blk_eval.retop = cx->blk_eval.retop; + ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, + param); + ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); break; case CXt_LOOP: - ncx->blk_loop.label = cx->blk_loop.label; - ncx->blk_loop.resetsp = cx->blk_loop.resetsp; - ncx->blk_loop.my_op = cx->blk_loop.my_op; - ncx->blk_loop.iterdata = (CxPADLOOP(cx) - ? cx->blk_loop.iterdata - : gv_dup((GV*)cx->blk_loop.iterdata, param)); + ncx->blk_loop.iterdata = (CxPADLOOP(ncx) + ? ncx->blk_loop.iterdata + : gv_dup((GV*)ncx->blk_loop.iterdata, + param)); ncx->blk_loop.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - cx->blk_loop.oldcomppad); - ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); - ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); - ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); - ncx->blk_loop.iterix = cx->blk_loop.iterix; - ncx->blk_loop.itermax = cx->blk_loop.itermax; + ncx->blk_loop.oldcomppad); + ncx->blk_loop.itersave = sv_dup_inc(ncx->blk_loop.itersave, + param); + ncx->blk_loop.iterlval = sv_dup_inc(ncx->blk_loop.iterlval, + param); + ncx->blk_loop.iterary = av_dup_inc(ncx->blk_loop.iterary, + param); break; case CXt_FORMAT: - ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param); - ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param); - ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param); - ncx->blk_sub.hasargs = cx->blk_sub.hasargs; - ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param); + ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); + ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, + param); break; case CXt_BLOCK: case CXt_NULL: @@ -10877,7 +10983,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv) ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(hvname))); + mXPUSHs(newSVhek(hvname)); PUTBACK; call_sv((SV*)GvCV(cloner), G_SCALAR); SPAGAIN; @@ -11144,7 +11250,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; - PL_preprocess = proto_perl->Ipreprocess; PL_minus_n = proto_perl->Iminus_n; PL_minus_p = proto_perl->Iminus_p; PL_minus_l = proto_perl->Iminus_l; @@ -11187,26 +11292,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regmatch_slab = NULL; /* Clone the regex array */ - PL_regex_padav = newAV(); - { - const I32 len = av_len((AV*)proto_perl->Iregex_padav); - SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); - IV i; - av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param)); - for(i = 1; i <= len; i++) { - const SV * const regex = regexen[i]; - SV * const sv = - SvREPADTMP(regex) - ? sv_dup_inc(regex, param) - : SvREFCNT_inc( - newSViv(PTR2IV(CALLREGDUPE( - INT2PTR(REGEXP *, SvIVX(regex)), param)))) - ; - if (SvFLAGS(regex) & SVf_BREAK) - SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */ - av_push(PL_regex_padav, sv); - } - } + /* ORANGE FIXME for plugins, probably in the SV dup code. + newSViv(PTR2IV(CALLREGDUPE( + INT2PTR(REGEXP *, SvIVX(regex)), param)))) + */ + PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); PL_regex_pad = AvARRAY(PL_regex_padav); /* shortcuts to various I/O objects */ @@ -11627,7 +11717,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); + mXPUSHs(newSVhek(HvNAME_HEK(stash))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -11743,8 +11833,9 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, XPUSHs(encoding); XPUSHs(dsv); XPUSHs(ssv); - XPUSHs(offsv = sv_2mortal(newSViv(*offset))); - XPUSHs(sv_2mortal(newSVpvn(tstr, tlen))); + offsv = newSViv(*offset); + mXPUSHs(offsv); + mXPUSHp(tstr, tlen); PUTBACK; call_method("cat_decode", G_SCALAR); SPAGAIN; @@ -11798,7 +11889,7 @@ S_find_hash_subscript(pTHX_ HV *hv, SV* val) return NULL; if (HeKLEN(entry) == HEf_SVKEY) return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } } return NULL; @@ -12172,7 +12263,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_SCHOMP: case OP_CHOMP: if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return sv_2mortal(newSVpvs("${$/}")); + return newSVpvs_flags("${$/}", SVs_TEMP); /*FALLTHROUGH*/ default: