X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2e2b25717dbde8d9ce48b4b8dc443e1d08166347..a8b0c4535f00ce3e66877fa1cc6100dea2e74eab:/sv.c diff --git a/sv.c b/sv.c index aebfe48..342fc7f 100644 --- a/sv.c +++ b/sv.c @@ -365,8 +365,8 @@ S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) { dVAR; SV *const sva = MUTABLE_SV(ptr); - register SV* sv; - register SV* svend; + SV* sv; + SV* svend; PERL_ARGS_ASSERT_SV_ADD_ARENA; @@ -410,8 +410,8 @@ S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) PERL_ARGS_ASSERT_VISIT; for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { - register const SV * const svend = &sva[SvREFCNT(sva)]; - register SV* sv; + const SV * const svend = &sva[SvREFCNT(sva)]; + SV* sv; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != (svtype)SVTYPEMASK && (sv->sv_flags & mask) == flags @@ -1397,6 +1397,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package name */ + DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); hv_clear(PL_stashcache); SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); @@ -1471,7 +1472,7 @@ Use the C wrapper instead. char * Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) { - register char *s; + char *s; PERL_ARGS_ASSERT_SV_GROW; @@ -1802,7 +1803,7 @@ ignored. I32 Perl_looks_like_number(pTHX_ SV *const sv) { - register const char *sbegin; + const char *sbegin; STRLEN len; PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; @@ -1818,16 +1819,16 @@ Perl_looks_like_number(pTHX_ SV *const sv) STATIC bool S_glob_2number(pTHX_ GV * const gv) { - SV *const buffer = sv_newmortal(); - PERL_ARGS_ASSERT_GLOB_2NUMBER; - gv_efullname3(buffer, gv, "*"); - /* We know that all GVs stringify to something that is not-a-number, so no need to test that. */ if (ckWARN(WARN_NUMERIC)) + { + SV *const buffer = sv_newmortal(); + gv_efullname3(buffer, gv, "*"); not_a_number(buffer); + } /* We just want something true to return, so that S_sv_2iuv_common can tail call us and return true. */ return TRUE; @@ -2256,22 +2257,37 @@ IV Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; + if (!sv) return 0; - if (SvGMAGICAL(sv) || SvVALID(sv)) { + + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); + + if (SvROK(sv)) { + if (SvAMAGIC(sv)) { + SV * tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); + } + + if (SvVALID(sv)) { /* FBMs use the space for SvIVX and SvNVX for other purposes, and use the same flag bit as SVf_IVisUV, so must not let them cache IVs. In practice they are extremely unlikely to actually get anywhere accessible by user Perl code - the only way that I'm aware of is when a constant subroutine which is used as the second argument to index. */ - if (flags & SV_GMAGIC) - mg_get(sv); if (SvIOKp(sv)) return SvIVX(sv); - if (SvNOKp(sv)) { + if (SvNOKp(sv)) return I_V(SvNVX(sv)); - } if (SvPOKp(sv) && SvLEN(sv)) { UV value; const int numtype @@ -2294,25 +2310,12 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) } return I_V(Atof(SvPVX_const(sv))); } - if (SvROK(sv)) { - goto return_rok; - } - assert(SvTYPE(sv) >= SVt_PVMG); - /* This falls through to the report_uninit inside S_sv_2iuv_common. */ - } else if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - return_rok: - if (SvAMAGIC(sv)) { - SV * tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvIV(tmpstr); - } - } - return PTR2IV(SvRV(sv)); - } + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } + + if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } @@ -2322,10 +2325,12 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) return 0; } } + if (!SvIOKp(sv)) { if (S_sv_2iuv_common(aTHX_ sv)) return 0; } + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", PTR2UV(sv),SvIVX(sv))); return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); @@ -2345,13 +2350,29 @@ UV Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; + if (!sv) return 0; - if (SvGMAGICAL(sv) || SvVALID(sv)) { + + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); + + if (SvROK(sv)) { + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvUV(tmpstr); + } + } + return PTR2UV(SvRV(sv)); + } + + if (SvVALID(sv)) { /* FBMs use the space for SvIVX and SvNVX for other purposes, and use the same flag bit as SVf_IVisUV, so must not let them cache IVs. */ - if (flags & SV_GMAGIC) - mg_get(sv); if (SvIOKp(sv)) return SvUVX(sv); if (SvNOKp(sv)) @@ -2373,25 +2394,12 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) } return U_V(Atof(SvPVX_const(sv))); } - if (SvROK(sv)) { - goto return_rok; - } - assert(SvTYPE(sv) >= SVt_PVMG); - /* This falls through to the report_uninit inside S_sv_2iuv_common. */ - } else if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - return_rok: - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvUV(tmpstr); - } - } - return PTR2UV(SvRV(sv)); - } + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } + + if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } @@ -2401,6 +2409,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) return 0; } } + if (!SvIOKp(sv)) { if (S_sv_2iuv_common(aTHX_ sv)) return 0; @@ -2715,201 +2724,150 @@ char * Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags) { dVAR; - register char *s; + char *s; if (!sv) { if (lp) *lp = 0; return (char *)""; } - if (SvGMAGICAL(sv)) { - if (flags & SV_GMAGIC) - mg_get(sv); - if (SvPOKp(sv)) { - if (lp) - *lp = SvCUR(sv); - if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); - if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); - return SvPVX(sv); - } - if (SvIOKp(sv) || SvNOKp(sv)) { - char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ - STRLEN len; - - if (SvIOKp(sv)) { - len = SvIsUV(sv) - ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv)) - : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv)); - } else if(SvNVX(sv) == 0.0) { - tbuf[0] = '0'; - tbuf[1] = 0; - len = 1; - } else { - Gconvert(SvNVX(sv), NV_DIG, 0, tbuf); - len = strlen(tbuf); - } - assert(!SvROK(sv)); - { - dVAR; + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); + if (SvROK(sv)) { + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return NULL; + tmpstr = AMG_CALLunary(sv, string_amg); + TAINT_IF(tmpstr && SvTAINTED(tmpstr)); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); + */ - SvUPGRADE(sv, SVt_PV); - if (lp) - *lp = len; - s = SvGROW_mutable(sv, len + 1); - SvCUR_set(sv, len); - SvPOKp_on(sv); - return (char*)memcpy(s, tbuf, len + 1); - } - } - if (SvROK(sv)) { - goto return_rok; - } - assert(SvTYPE(sv) >= SVt_PVMG); - /* This falls through to the report_uninit near the end of the - function. */ - } else if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - return_rok: - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return NULL; - tmpstr = AMG_CALLunary(sv, string_amg); - TAINT_IF(tmpstr && SvTAINTED(tmpstr)); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - /* Unwrap this: */ - /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); - */ - - char *pv; - if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { - if (flags & SV_CONST_RETURN) { - pv = (char *) SvPVX_const(tmpstr); - } else { - pv = (flags & SV_MUTABLE_RETURN) - ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); - } - if (lp) - *lp = SvCUR(tmpstr); + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); } else { - pv = sv_2pv_flags(tmpstr, lp, flags); + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); } - if (SvUTF8(tmpstr)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return pv; + if (lp) + *lp = SvCUR(tmpstr); + } else { + pv = sv_2pv_flags(tmpstr, lp, flags); } + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; } - { - STRLEN len; - char *retval; - char *buffer; - SV *const referent = SvRV(sv); - - if (!referent) { - len = 7; - retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_REGEXP && ( - !(PL_curcop->cop_hints & HINT_NO_AMAGIC) - || amagic_is_enabled(string_amg) - )) { - REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); - I32 seen_evals = 0; - - assert(re); + } + { + STRLEN len; + char *retval; + char *buffer; + SV *const referent = SvRV(sv); + + if (!referent) { + len = 7; + retval = buffer = savepvn("NULLREF", len); + } else if (SvTYPE(referent) == SVt_REGEXP && + (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || + amagic_is_enabled(string_amg))) { + REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); + + 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 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 (lp) - *lp = RX_WRAPLEN(re); + if (lp) + *lp = RX_WRAPLEN(re); - return RX_WRAPPED(re); - } else { - const char *const typestr = sv_reftype(referent, 0); - const STRLEN typelen = strlen(typestr); - UV addr = PTR2UV(referent); - const char *stashname = NULL; - STRLEN stashnamelen = 0; /* hush, gcc */ - const char *buffer_end; - - if (SvOBJECT(referent)) { - const HEK *const name = HvNAME_HEK(SvSTASH(referent)); - - if (name) { - stashname = HEK_KEY(name); - stashnamelen = HEK_LEN(name); - - if (HEK_UTF8(name)) { - SvUTF8_on(sv); - } else { - SvUTF8_off(sv); - } + return RX_WRAPPED(re); + } else { + const char *const typestr = sv_reftype(referent, 0); + const STRLEN typelen = strlen(typestr); + UV addr = PTR2UV(referent); + const char *stashname = NULL; + STRLEN stashnamelen = 0; /* hush, gcc */ + const char *buffer_end; + + if (SvOBJECT(referent)) { + const HEK *const name = HvNAME_HEK(SvSTASH(referent)); + + if (name) { + stashname = HEK_KEY(name); + stashnamelen = HEK_LEN(name); + + if (HEK_UTF8(name)) { + SvUTF8_on(sv); } else { - stashname = "__ANON__"; - stashnamelen = 8; + SvUTF8_off(sv); } - len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ - + 2 * sizeof(UV) + 2 /* )\0 */; } else { - len = typelen + 3 /* (0x */ - + 2 * sizeof(UV) + 2 /* )\0 */; + stashname = "__ANON__"; + stashnamelen = 8; } + len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } else { + len = typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } - Newx(buffer, len, char); - buffer_end = retval = buffer + len; - - /* Working backwards */ - *--retval = '\0'; - *--retval = ')'; - do { - *--retval = PL_hexdigit[addr & 15]; - } while (addr >>= 4); - *--retval = 'x'; - *--retval = '0'; - *--retval = '('; - - retval -= typelen; - memcpy(retval, typestr, typelen); - - if (stashname) { - *--retval = '='; - retval -= stashnamelen; - memcpy(retval, stashname, stashnamelen); - } - /* retval may not necessarily have reached the start of the - buffer here. */ - assert (retval >= buffer); - - len = buffer_end - retval - 1; /* -1 for that \0 */ + Newx(buffer, len, char); + buffer_end = retval = buffer + len; + + /* Working backwards */ + *--retval = '\0'; + *--retval = ')'; + do { + *--retval = PL_hexdigit[addr & 15]; + } while (addr >>= 4); + *--retval = 'x'; + *--retval = '0'; + *--retval = '('; + + retval -= typelen; + memcpy(retval, typestr, typelen); + + if (stashname) { + *--retval = '='; + retval -= stashnamelen; + memcpy(retval, stashname, stashnamelen); } - if (lp) - *lp = len; - SAVEFREEPV(buffer); - return retval; + /* retval may not necessarily have reached the start of the + buffer here. */ + assert (retval >= buffer); + + len = buffer_end - retval - 1; /* -1 for that \0 */ } - } - if (SvREADONLY(sv) && !SvOK(sv)) { if (lp) - *lp = 0; - if (flags & SV_UNDEF_RETURNS_NULL) - return NULL; - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return (char *)""; + *lp = len; + SAVEFREEPV(buffer); + return retval; } } - if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { + + if (SvPOKp(sv)) { + if (lp) + *lp = SvCUR(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + return SvPVX(sv); + } + + if (SvIOK(sv)) { /* I'm assuming that if both IV and NV are equally valid then converting the IV is going to be more efficient */ const U32 isUIOK = SvIsUV(sv); @@ -2927,7 +2885,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags s += len; *s = '\0'; } - else if (SvNOKp(sv)) { + else if (SvNOK(sv)) { if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); if (SvNVX(sv) == 0.0) { @@ -2948,32 +2906,32 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags *--s = '\0'; #endif } - else { - if (isGV_with_GP(sv)) { - GV *const gv = MUTABLE_GV(sv); - SV *const buffer = sv_newmortal(); - - gv_efullname3(buffer, gv, "*"); + else if (isGV_with_GP(sv)) { + GV *const gv = MUTABLE_GV(sv); + SV *const buffer = sv_newmortal(); - assert(SvPOK(buffer)); - if (lp) { - *lp = SvCUR(buffer); - } - if ( SvUTF8(buffer) ) SvUTF8_on(sv); - return SvPVX(buffer); - } + gv_efullname3(buffer, gv, "*"); + assert(SvPOK(buffer)); + if (SvUTF8(buffer)) + SvUTF8_on(sv); + if (lp) + *lp = SvCUR(buffer); + return SvPVX(buffer); + } + else { if (lp) *lp = 0; if (flags & SV_UNDEF_RETURNS_NULL) return NULL; if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - if (SvTYPE(sv) < SVt_PV) - /* Typically the caller expects that sv_any is not NULL now. */ + /* Typically the caller expects that sv_any is not NULL now. */ + if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) sv_upgrade(sv, SVt_PV); return (char *)""; } + { const STRLEN len = s - SvPVX_const(sv); if (lp) @@ -3001,17 +2959,37 @@ sv_2pv[_flags] but operates directly on an SV instead of just the string. Mostly uses sv_2pv_flags to do its work, except when that would lose the UTF-8'ness of the PV. +=for apidoc sv_copypv_nomg + +Like sv_copypv, but doesn't invoke get magic first. + +=for apidoc sv_copypv_flags + +Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags +include SV_GMAGIC. + =cut */ void Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv) { + PERL_ARGS_ASSERT_SV_COPYPV; + + sv_copypv_flags(dsv, ssv, 0); +} + +void +Perl_sv_copypv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags) +{ STRLEN len; - const char * const s = SvPV_const(ssv,len); + const char *s; - PERL_ARGS_ASSERT_SV_COPYPV; + PERL_ARGS_ASSERT_SV_COPYPV_FLAGS; + if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv)) + mg_get(ssv); + s = SvPV_nomg_const(ssv,len); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); @@ -3036,7 +3014,8 @@ Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_2PVBYTE; - if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) { + if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) + || isGV_with_GP(sv) || SvROK(sv)) { SV *sv2 = sv_newmortal(); sv_copypv(sv2,sv); sv = sv2; @@ -3062,11 +3041,12 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_2PVUTF8; - if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) + if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) + || isGV_with_GP(sv) || SvROK(sv)) sv = sv_mortalcopy(sv); - sv_utf8_upgrade(sv); - if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~SVf_POK; - assert(SvPOKp(sv)); + else + SvGETMAGIC(sv); + sv_utf8_upgrade_nomg(sv); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3107,30 +3087,7 @@ Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags) } return SvRV(sv) != 0; } - if (SvPOKp(sv)) { - register XPV* const Xpvtmp = (XPV*)SvANY(sv); - if (Xpvtmp && - (*sv->sv_u.svu_pv > '0' || - Xpvtmp->xpv_cur > 1 || - (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) - return 1; - else - return 0; - } - else { - if (SvIOKp(sv)) - return SvIVX(sv) != 0; - else { - if (SvNOKp(sv)) - return SvNVX(sv) != 0.0; - else { - if (isGV_with_GP(sv)) - return TRUE; - else - return FALSE; - } - } - } + return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0); } /* @@ -3705,7 +3662,6 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) /* The stash may have been detached from the symbol table, so check its name. */ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) - && GvAV((const GV *)sstr) ) mro_changes = 2; else { @@ -3740,6 +3696,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } GvMULTI_on(dstr); if(mro_changes == 2) { + if (GvAV((const GV *)sstr)) { MAGIC *mg; SV * const sref = (SV *)GvAV((const GV *)dstr); if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { @@ -3751,7 +3708,8 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr)); } else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); - mro_isa_changed_in(GvSTASH(dstr)); + } + mro_isa_changed_in(GvSTASH(dstr)); } else if(mro_changes == 3) { HV * const stash = GvHV(dstr); @@ -3925,6 +3883,14 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) assert(mg); Perl_magic_clearisa(aTHX_ NULL, mg); } + else if (stype == SVt_PVIO) { + DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n")); + /* It's a cache. It will rebuild itself quite happily. + It's a lot of effort to work out exactly which key (or keys) + might be invalidated by the creation of the this file handle. + */ + hv_clear(PL_stashcache); + } break; } SvREFCNT_dec(dref); @@ -3937,9 +3903,9 @@ void Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { dVAR; - register U32 sflags; - register int dtype; - register svtype stype; + U32 sflags; + int dtype; + svtype stype; PERL_ARGS_ASSERT_SV_SETSV_FLAGS; @@ -3960,13 +3926,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) stype = SvTYPE(sstr); dtype = SvTYPE(dstr); - (void)SvAMAGIC_off(dstr); - if ( SvVOK(dstr) ) - { - /* need to nuke the magic */ - sv_unmagic(dstr, PERL_MAGIC_vstring); - } - /* There's a lot of redundancy below but we're going for speed here */ switch (stype) { @@ -4034,15 +3993,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } goto undef_sstr; - case SVt_PVFM: -#ifdef PERL_OLD_COPY_ON_WRITE - if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { - if (dtype < SVt_PVIV) - sv_upgrade(dstr, SVt_PVIV); - break; - } - /* Fall through */ -#endif case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -4095,7 +4045,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) dtype = SvTYPE(dstr); sflags = SvFLAGS(sstr); - if (dtype == SVt_PVCV || dtype == SVt_PVFM) { + if (dtype == SVt_PVCV) { /* Assigning to a subroutine sets the prototype. */ if (SvOK(sstr)) { STRLEN len; @@ -4110,7 +4060,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } else { SvOK_off(dstr); } - } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { + } + else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) { const char * const type = sv_reftype(dstr,0); if (PL_op) /* diag_listed_as: Cannot copy to %s */ @@ -4253,7 +4204,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) && ((flags & SV_COW_SHARED_HASH_KEYS) ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS - && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM)) + && SvTYPE(sstr) >= SVt_PVIV)) : 1) #endif ) { @@ -4398,7 +4349,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) { STRLEN cur = SvCUR(sstr); STRLEN len = SvLEN(sstr); - register char *new_pv; + char *new_pv; PERL_ARGS_ASSERT_SV_SETSV_COW; @@ -4414,7 +4365,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (SvTHINKFIRST(dstr)) sv_force_normal_flags(dstr, SV_COW_DROP_PV); else if (SvPVX_const(dstr)) - Safefree(SvPVX_const(dstr)); + Safefree(SvPVX_mutable(dstr)); } else new_SV(dstr); @@ -4477,7 +4428,7 @@ void Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) { dVAR; - register char *dptr; + char *dptr; PERL_ARGS_ASSERT_SV_SETPVN; @@ -4534,7 +4485,7 @@ void Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr) { dVAR; - register STRLEN len; + STRLEN len; PERL_ARGS_ASSERT_SV_SETPV; @@ -4603,6 +4554,7 @@ Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek) { SV_CHECK_THINKFIRST_COW_DROP(sv); SvUPGRADE(sv, SVt_PV); + Safefree(SvPVX(sv)); SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); SvCUR_set(sv, HEK_LEN(hek)); SvLEN_set(sv, 0); @@ -4743,10 +4695,12 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after) /* =for apidoc sv_force_normal_flags -Undo various types of fakery on an SV: if the PV is a shared string, make +Undo various types of fakery on an SV, where fakery means +"more than" a string: if the PV is a shared string, make a private copy; if we're a ref, stop refing; if we're a glob, downgrade to an xpvmg; if we're a copy-on-write scalar, this is the on-write time when -we do the copy, and is also used locally. If C is set +we do the copy, and is also used locally; if this is a +vstring, drop the vstring magic. If C is set then a copy-on-write scalar drops its PV buffer (if any) and becomes SvPOK_off rather than making a copy. (Used where this scalar is about to be set to some other value.) In addition, @@ -4873,15 +4827,17 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) SvREFCNT_dec(temp); } + else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring); } /* =for apidoc sv_chop Efficient removal of characters from the beginning of the string buffer. -SvPOK(sv) must be true and the C must be a pointer to somewhere inside -the string buffer. The C becomes the first character of the adjusted -string. Uses the "OOK hack". +SvPOK(sv), or at least SvPOKp(sv), must be true and the C must be a +pointer to somewhere inside the string buffer. The C becomes the first +character of the adjusted string. Uses the "OOK hack". On return, only +SvPOK(sv) and SvPOKp(sv) among the OK flags will be true. Beware: after this function returns, C and SvPVX_const(sv) may no longer refer to the same chunk of data. @@ -4920,6 +4876,7 @@ Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */ SV_CHECK_THINKFIRST(sv); + SvPOK_only_UTF8(sv); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -5047,18 +5004,19 @@ Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, re /* =for apidoc sv_catsv -Concatenates the string from SV C onto the end of the string in -SV C. Modifies C but not C. Handles 'get' magic, but -not 'set' magic. See C. +Concatenates the string from SV C onto the end of the string in SV +C. If C is null, does nothing; otherwise modifies only C. +Handles 'get' magic on both SVs, but no 'set' magic. See C and +C. =for apidoc sv_catsv_flags -Concatenates the string from SV C onto the end of the string in -SV C. Modifies C but not C. If C has C -bit set, will C on the C, if appropriate, before -reading it. If the C contain C, C will be -called on the modified SV afterward, if appropriate. C -and C are implemented in terms of this function. +Concatenates the string from SV C onto the end of the string in SV +C. If C is null, does nothing; otherwise modifies only C. +If C include C bit set, will call C on both SVs if +appropriate. If C include C, C will be called on +the modified SV afterward, if appropriate. C, C, +and C are implemented in terms of this function. =cut */ @@ -5069,18 +5027,18 @@ Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags PERL_ARGS_ASSERT_SV_CATSV_FLAGS; - if (ssv) { + if (ssv) { STRLEN slen; const char *spv = SvPV_flags_const(ssv, slen, flags); if (spv) { - if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) - mg_get(dsv); + if (flags & SV_GMAGIC) + SvGETMAGIC(dsv); sv_catpvn_flags(dsv, spv, slen, DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES); - } + if (flags & SV_SMAGIC) + SvSETMAGIC(dsv); + } } - if (flags & SV_SMAGIC) - SvSETMAGIC(dsv); } /* @@ -5096,7 +5054,7 @@ void Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr) { dVAR; - register STRLEN len; + STRLEN len; STRLEN tlen; char *junk; @@ -5171,7 +5129,7 @@ SV * Perl_newSV(pTHX_ const STRLEN len) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); if (len) { @@ -5268,8 +5226,6 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, mg->mg_virtual = (MGVTBL *) vtable; mg_magical(sv); - if (SvGMAGICAL(sv)) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); return mg; } @@ -5336,13 +5292,8 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, /* sv_magic() refuses to add a magic of the same 'how' as an existing one */ - if (how == PERL_MAGIC_taint) { + if (how == PERL_MAGIC_taint) mg->mg_len |= 1; - /* Any scalar which already had taint magic on which someone - (erroneously?) did SvIOK_on() or similar will now be - incorrectly sporting public "OK" flags. */ - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); - } return; } } @@ -5571,6 +5522,30 @@ Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) if (SvOOK(tsv)) svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } + else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) { + /* It's possible for the the last (strong) reference to tsv to have + become freed *before* the last thing holding a weak reference. + If both survive longer than the backreferences array, then when + the referent's reference count drops to 0 and it is freed, it's + not able to chase the backreferences, so they aren't NULLed. + + For example, a CV holds a weak reference to its stash. If both the + CV and the stash survive longer than the backreferences array, + and the CV gets picked for the SvBREAK() treatment first, + *and* it turns out that the stash is only being kept alive because + of an our variable in the pad of the CV, then midway during CV + destruction the stash gets freed, but CvSTASH() isn't set to NULL. + It ends up pointing to the freed HV. Hence it's chased in here, and + if this block wasn't here, it would hit the !svp panic just below. + + I don't believe that "better" destruction ordering is going to help + here - during global destruction there's always going to be the + chance that something goes out of order. We've tried to make it + foolproof before, and it only resulted in evolutionary pressure on + fools. Which made us look foolish for our hubris. :-( + */ + return; + } else { MAGIC *const mg = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; @@ -5664,7 +5639,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) if (!av) return; - /* after multiple passes through Perl_sv_clean_all() for a thinngy + /* after multiple passes through Perl_sv_clean_all() for a thingy * that has badly leaked, the backref array may have gotten freed, * since we only protect it against 1 round of cleanup */ if (SvIS_FREED(av)) { @@ -5760,11 +5735,11 @@ void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) { dVAR; - register char *big; - register char *mid; - register char *midend; - register char *bigend; - register SSize_t i; /* better be sizeof(STRLEN) or bad things happen */ + char *big; + char *mid; + char *midend; + char *bigend; + SSize_t i; /* better be sizeof(STRLEN) or bad things happen */ STRLEN curlen; PERL_ARGS_ASSERT_SV_INSERT_FLAGS; @@ -5940,10 +5915,11 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) assert(GvGP(gv)); assert(!CvANON(cv)); assert(CvGV(cv) == gv); + assert(!CvNAMED(cv)); /* will the CV shortly be freed by gp_free() ? */ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) { - SvANY(cv)->xcv_gv = NULL; + SvANY(cv)->xcv_gv_u.xcv_gv = NULL; return; } @@ -5957,7 +5933,7 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) CvANON_on(cv); CvCVGV_RC_on(cv); - SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv)); + SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv)); } @@ -5984,7 +5960,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) const struct body_details *sv_type_details; SV* iter_sv = NULL; SV* next_sv = NULL; - register SV *sv = orig_sv; + SV *sv = orig_sv; STRLEN hash_index; PERL_ARGS_ASSERT_SV_CLEAR; @@ -6032,6 +6008,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) sv_unmagic(sv, PERL_MAGIC_backref); mg_free(sv); } + SvMAGICAL_off(sv); if (type == SVt_PVMG && SvPAD_TYPED(sv)) SvREFCNT_dec(SvSTASH(sv)); } @@ -6079,9 +6056,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) if ( PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME((HV*)sv))) { - if (PL_stashcache) + if (PL_stashcache) { + DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", + sv)); (void)hv_delete(PL_stashcache, name, HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD); + } hv_name_set((HV*)sv, NULL, 0, 0); } @@ -6090,14 +6070,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) SvSTASH(sv) = (HV*)iter_sv; iter_sv = sv; - /* XXX ideally we should save the old value of hash_index - * too, but I can't think of any place to hide it. The - * effect of not saving it is that for freeing hashes of - * hashes, we become quadratic in scanning the HvARRAY of - * the top hash looking for new entries to free; but - * hopefully this will be dwarfed by the freeing of all - * the nested hashes. */ + /* save old hash_index in unused SvMAGIC field */ + assert(!SvMAGICAL(sv)); + assert(!SvMAGIC(sv)); + ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; hash_index = 0; + next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); goto get_next_sv; /* process this new sv */ } @@ -6195,7 +6173,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) SvFAKE_off(sv); } else if (SvLEN(sv)) { - Safefree(SvPVX_const(sv)); + Safefree(SvPVX_mutable(sv)); } } #else @@ -6261,13 +6239,16 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) /* no more elements of current HV to free */ sv = iter_sv; type = SvTYPE(sv); - /* Restore previous value of iter_sv, squirrelled away */ + /* Restore previous values of iter_sv and hash_index, + * squirrelled away */ assert(!SvOBJECT(sv)); iter_sv = (SV*)SvSTASH(sv); - - /* ideally we should restore the old hash_index here, - * but we don't currently save the old value */ - hash_index = 0; + assert(!SvMAGICAL(sv)); + hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; +#ifdef DEBUGGING + /* perl -DA does not like rubbish in SvMAGIC. */ + SvMAGIC_set(sv, 0); +#endif /* free any remaining detritus from the hash struct */ Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); @@ -6491,7 +6472,8 @@ Perl_sv_free2(pTHX_ SV *const sv) =for apidoc sv_len Returns the length of the string in the SV. Handles magic and type -coercion. See also C, which gives raw access to the xpv_cur slot. +coercion and sets the UTF8 flag appropriately. See also C, which +gives raw access to the xpv_cur slot. =cut */ @@ -6504,10 +6486,7 @@ Perl_sv_len(pTHX_ register SV *const sv) if (!sv) return 0; - if (SvGMAGICAL(sv)) - len = mg_length(sv); - else - (void)SvPV_const(sv, len); + (void)SvPV_const(sv, len); return len; } @@ -6539,10 +6518,21 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv) return mg_length(sv); else { - STRLEN len; - const U8 *s = (U8*)SvPV_const(sv, len); + SvGETMAGIC(sv); + return sv_len_utf8_nomg(sv); + } +} + +STRLEN +Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) +{ + dVAR; + STRLEN len; + const U8 *s = (U8*)SvPV_nomg_const(sv, len); + + PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG; - if (PL_utf8cache) { + if (PL_utf8cache) { STRLEN ulen; MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; @@ -6568,9 +6558,8 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv) utf8_mg_len_cache_update(sv, &mg, ulen); } return ulen; - } - return Perl_utf8_length(aTHX_ s, s + len); } + return Perl_utf8_length(aTHX_ s, s + len); } /* Walk forwards to find the byte corresponding to the passed in UTF-8 @@ -6960,7 +6949,6 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b calculation in bytes simply because we always know the byte length. squareroot has the same ordering as the positive value, so don't bother with the actual square root. */ - const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen); if (byte > cache[1]) { /* New position is after the existing pair of pairs. */ const float keep_earlier @@ -6969,18 +6957,14 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b = THREEWAY_SQUARE(0, cache[1], byte, blen); if (keep_later < keep_earlier) { - if (keep_later < existing) { - cache[2] = cache[0]; - cache[3] = cache[1]; - cache[0] = utf8; - cache[1] = byte; - } + cache[2] = cache[0]; + cache[3] = cache[1]; + cache[0] = utf8; + cache[1] = byte; } else { - if (keep_earlier < existing) { - cache[0] = utf8; - cache[1] = byte; - } + cache[0] = utf8; + cache[1] = byte; } } else if (byte > cache[3]) { @@ -6991,16 +6975,12 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b = THREEWAY_SQUARE(0, byte, cache[1], blen); if (keep_later < keep_earlier) { - if (keep_later < existing) { - cache[2] = utf8; - cache[3] = byte; - } + cache[2] = utf8; + cache[3] = byte; } else { - if (keep_earlier < existing) { - cache[0] = utf8; - cache[1] = byte; - } + cache[0] = utf8; + cache[1] = byte; } } else { @@ -7011,18 +6991,14 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b = THREEWAY_SQUARE(0, byte, cache[1], blen); if (keep_later < keep_earlier) { - if (keep_later < existing) { - cache[2] = utf8; - cache[3] = byte; - } + cache[2] = utf8; + cache[3] = byte; } else { - if (keep_earlier < existing) { - cache[0] = cache[2]; - cache[1] = cache[3]; - cache[2] = utf8; - cache[3] = byte; - } + cache[0] = cache[2]; + cache[1] = cache[3]; + cache[2] = utf8; + cache[3] = byte; } } } @@ -7572,7 +7548,10 @@ S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) =for apidoc sv_gets Get a line from the filehandle and store it into the SV, optionally -appending to the currently-stored string. +appending to the currently-stored string. If C is not 0, the +line is appended to the SV instead of overwriting it. C should +be set to the byte offset that the appended string should start at +in the SV (typically, C is a suitable choice). =cut */ @@ -7583,9 +7562,9 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) dVAR; const char *rsptr; STRLEN rslen; - register STDCHAR rslast; - register STDCHAR *bp; - register I32 cnt; + STDCHAR rslast; + STDCHAR *bp; + I32 cnt; I32 i = 0; I32 rspara = 0; @@ -7600,8 +7579,6 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) Swings and roundabouts. */ SvUPGRADE(sv, SVt_PV); - SvSCREAM_off(sv); - if (append) { if (PerlIO_isutf8(fp)) { if (!SvUTF8(sv)) { @@ -7694,7 +7671,7 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) * We're going to steal some values from the stdio struct * and put EVERYTHING in the innermost loop into registers. */ - register STDCHAR *ptr; + STDCHAR *ptr; STRLEN bpx; I32 shortbuffered; @@ -7840,7 +7817,7 @@ thats_really_all_folks: screamer2: if (rslen) { - register const STDCHAR * const bpe = buf + sizeof(buf); + const STDCHAR * const bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -7860,9 +7837,9 @@ screamer2: if (cnt < 0) cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ if (append) - sv_catpvn(sv, (char *) buf, cnt); + sv_catpvn_nomg(sv, (char *) buf, cnt); else - sv_setpvn(sv, (char *) buf, cnt); + sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */ if (i != EOF && /* joy */ (!rslen || @@ -7934,7 +7911,7 @@ void Perl_sv_inc_nomg(pTHX_ register SV *const sv) { dVAR; - register char *d; + char *d; int flags; if (!sv) @@ -8256,7 +8233,7 @@ SV * Perl_sv_mortalcopy(pTHX_ SV *const oldstr) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setsv(sv,oldstr); @@ -8280,7 +8257,7 @@ SV * Perl_sv_newmortal(pTHX) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); SvFLAGS(sv) = SVs_TEMP; @@ -8313,7 +8290,7 @@ SV * Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) { dVAR; - register SV *sv; + 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. */ @@ -8377,7 +8354,7 @@ SV * Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); @@ -8401,7 +8378,7 @@ SV * Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setpvn(sv,buffer,len); @@ -8499,7 +8476,7 @@ SV * Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) { dVAR; - register SV *sv; + SV *sv; bool is_utf8 = FALSE; const char *const orig_src = src; @@ -8555,7 +8532,7 @@ SV * Perl_newSVpvf_nocontext(const char *const pat, ...) { dTHX; - register SV *sv; + SV *sv; va_list args; PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT; @@ -8579,7 +8556,7 @@ C. SV * Perl_newSVpvf(pTHX_ const char *const pat, ...) { - register SV *sv; + SV *sv; va_list args; PERL_ARGS_ASSERT_NEWSVPVF; @@ -8596,7 +8573,7 @@ SV * Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) { dVAR; - register SV *sv; + SV *sv; PERL_ARGS_ASSERT_VNEWSVPVF; @@ -8618,7 +8595,7 @@ SV * Perl_newSVnv(pTHX_ const NV n) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setnv(sv,n); @@ -8638,7 +8615,7 @@ SV * Perl_newSViv(pTHX_ const IV i) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setiv(sv,i); @@ -8658,7 +8635,7 @@ SV * Perl_newSVuv(pTHX_ const UV u) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setuv(sv,u); @@ -8677,7 +8654,7 @@ is set to 1. SV * Perl_newSV_type(pTHX_ const svtype type) { - register SV *sv; + SV *sv; new_SV(sv); sv_upgrade(sv, type); @@ -8697,7 +8674,7 @@ SV * Perl_newRV_noinc(pTHX_ SV *const tmpRef) { dVAR; - register SV *sv = newSV_type(SVt_IV); + SV *sv = newSV_type(SVt_IV); PERL_ARGS_ASSERT_NEWRV_NOINC; @@ -8734,7 +8711,7 @@ SV * Perl_newSVsv(pTHX_ register SV *const old) { dVAR; - register SV *sv; + SV *sv; if (!old) return NULL; @@ -8742,11 +8719,12 @@ Perl_newSVsv(pTHX_ register SV *const old) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); return NULL; } + /* Do this here, otherwise we leak the new SV if this croaks. */ + SvGETMAGIC(old); new_SV(sv); - /* SV_GMAGIC is the default for sv_setv() - SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games + /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */ - sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL); + sv_setsv_flags(sv, old, SV_NOSTEAL); return sv; } @@ -8762,15 +8740,22 @@ Note that the perl-level function is vaguely deprecated. void Perl_sv_reset(pTHX_ register const char *s, HV *const stash) { + PERL_ARGS_ASSERT_SV_RESET; + + sv_resetpvn(*s ? s : NULL, strlen(s), stash); +} + +void +Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) +{ dVAR; char todo[PERL_UCHAR_MAX+1]; - - PERL_ARGS_ASSERT_SV_RESET; + const char *send; if (!stash) return; - if (!*s) { /* reset ?? searches */ + if (!s) { /* reset ?? searches */ MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); if (mg) { const U32 count = mg->mg_len / sizeof(PMOP**); @@ -8795,7 +8780,8 @@ Perl_sv_reset(pTHX_ register const char *s, HV *const stash) return; Zero(todo, 256, char); - while (*s) { + send = s + len; + while (s < send) { I32 max; I32 i = (unsigned char)*s; if (s[1] == '-') { @@ -8811,8 +8797,8 @@ Perl_sv_reset(pTHX_ register const char *s, HV *const stash) entry; entry = HeNEXT(entry)) { - register GV *gv; - register SV *sv; + GV *gv; + SV *sv; if (!todo[(U8)*HeKEY(entry)]) continue; @@ -8984,20 +8970,10 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) } *st = GvESTASH(gv); if (lref & ~GV_ADDMG && !GvCVu(gv)) { - SV *tmpsv; - ENTER; - tmpsv = newSV(0); - gv_efullname3(tmpsv, gv, NULL); /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ - newSUB(start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, tmpsv), - NULL, NULL); - LEAVE; - if (!GvCVu(gv)) - Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - SVfARG(SvOK(sv) ? sv : &PL_sv_no)); + newSTUB(gv,0); } return GvCVu(gv); } @@ -9019,7 +8995,7 @@ Perl_sv_true(pTHX_ register SV *const sv) if (!sv) return 0; if (SvPOK(sv)) { - register const XPV* const tXpv = (XPV*)SvANY(sv); + const XPV* const tXpv = (XPV*)SvANY(sv); if (tXpv && (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) @@ -9085,12 +9061,15 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) else Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } - if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) + if (SvTYPE(sv) > SVt_PVLV || isGV_with_GP(sv)) /* diag_listed_as: Can't coerce %s to %s in %s */ Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_DESC(PL_op)); s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); + if (!s) { + s = (char *)""; + } if (lp) *lp = len; @@ -9110,6 +9089,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) PTR2UV(sv),SvPVX_const(sv))); } } + (void)SvPOK_only_UTF8(sv); return SvPVX_mutable(sv); } @@ -9309,7 +9289,6 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) new_SV(sv); SV_CHECK_THINKFIRST_COW_DROP(rv); - (void)SvAMAGIC_off(rv); if (SvTYPE(rv) >= SVt_PVMG) { const U32 refcnt = SvREFCNT(rv); @@ -9496,11 +9475,6 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); - if (Gv_AMG(stash)) - SvAMAGIC_on(sv); - else - (void)SvAMAGIC_off(sv); - if(SvSMAGICAL(tmpRef)) if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) mg_set(tmpRef); @@ -9941,7 +9915,7 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, PERL_ARGS_ASSERT_SV_VSETPVFN; sv_setpvs(sv, ""); - sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); + sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0); } @@ -10015,18 +9989,21 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) /* =for apidoc sv_vcatpvfn +=for apidoc sv_vcatpvfn_flags + Processes its arguments like C and appends the formatted output to an SV. Uses an array of SVs if the C style variable argument list is missing (NULL). When running with taint checks enabled, indicates via C if results are untrustworthy (often due to the use of locales). +If called as C or flags include C, calls get magic. + Usually used via one of its frontends C and C. =cut */ - #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ vecstr = (U8*)SvPV_const(vecsv,veclen);\ vec_utf8 = DO_UTF8(vecsv); @@ -10037,6 +10014,16 @@ void Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) { + PERL_ARGS_ASSERT_SV_VCATPVFN; + + sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC); +} + +void +Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, + va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, + const U32 flags) +{ dVAR; char *p; char *q; @@ -10055,11 +10042,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ - PERL_ARGS_ASSERT_SV_VCATPVFN; + PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); + if (flags & SV_GMAGIC) + SvGETMAGIC(sv); + /* no matter what, this is a string now */ - (void)SvPV_force(sv, origlen); + (void)SvPV_force_nomg(sv, origlen); /* special-case "", "%s", and "%-p" (SVf - see below) */ if (patlen == 0) @@ -10067,10 +10057,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { if (args) { const char * const s = va_arg(*args, char*); - sv_catpv(sv, s ? s : nullstr); + sv_catpv_nomg(sv, s ? s : nullstr); } else if (svix < svmax) { - sv_catsv(sv, *svargs); + /* we want get magic on the source but not the target. sv_catsv can't do that, though */ + SvGETMAGIC(*svargs); + sv_catsv_nomg(sv, *svargs); } else S_vcatpvfn_missing_argument(aTHX); @@ -10079,7 +10071,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { argsv = MUTABLE_SV(va_arg(*args, void*)); - sv_catsv(sv, argsv); + sv_catsv_nomg(sv, argsv); return; } @@ -10102,7 +10094,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { /* 0, point, slack */ Gconvert(nv, (int)digits, 0, ebuf); - sv_catpv(sv, ebuf); + sv_catpv_nomg(sv, ebuf); if (*ebuf) /* May return an empty string for digits==0 */ return; } @@ -10110,7 +10102,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, STRLEN l; if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { - sv_catpvn(sv, p, l); + sv_catpvn_nomg(sv, p, l); return; } } @@ -10181,9 +10173,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, for (q = p; q < patend && *q != '%'; ++q) ; if (q > p) { if (has_utf8 && !pat_utf8) - sv_catpvn_utf8_upgrade(sv, p, q - p, nsv); + sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv); else - sv_catpvn(sv, p, q - p); + sv_catpvn_nomg(sv, p, q - p); p = q; } if (q++ >= patend) @@ -10403,20 +10395,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * vectorize happen normally */ if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { - char *version = savesvpv(vecsv); if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF), "vector argument not supported with alpha versions"); - goto unknown; + goto vdblank; } vecsv = sv_newmortal(); - scan_vstring(version, version + veclen, vecsv); + scan_vstring((char *)vecstr, (char *)vecstr + veclen, + vecsv); vecstr = (U8*)SvPV_const(vecsv, veclen); vec_utf8 = DO_UTF8(vecsv); - Safefree(version); } } else { + vdblank: vecstr = (U8*)""; veclen = 0; } @@ -10427,7 +10419,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, switch (*q) { #ifdef WIN32 case 'I': /* Ix, I32x, and I64x */ -# ifdef WIN64 +# ifdef USE_64_BIT_INT if (q[1] == '6' && q[2] == '4') { q += 3; intsize = 'q'; @@ -10438,7 +10430,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, q += 3; break; } -# ifdef WIN64 +# ifdef USE_64_BIT_INT intsize = 'q'; # endif q++; @@ -10545,16 +10537,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (DO_UTF8(argsv)) { STRLEN old_precis = precis; if (has_precis && precis < elen) { - STRLEN ulen = sv_len_utf8(argsv); - I32 p = precis > ulen ? ulen : precis; - sv_pos_u2b(argsv, &p, 0); /* sticks at end */ - precis = p; + STRLEN ulen = sv_len_utf8_nomg(argsv); + STRLEN p = precis > ulen ? ulen : precis; + precis = sv_pos_u2b_flags(argsv, p, 0, 0); + /* sticks at end */ } if (width) { /* fudge width (can't fudge elen) */ if (has_precis && precis < elen) width += precis - old_precis; else - width += elen - sv_len_utf8(argsv); + width += elen - sv_len_utf8_nomg(argsv); } is_utf8 = TRUE; } @@ -11057,7 +11049,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, sv_catpvs(msg, "\"%"); for (f = fmtstart; f < fmtend; f++) { if (isPRINT(*f)) { - sv_catpvn(msg, f, 1); + sv_catpvn_nomg(msg, f, 1); } else { Perl_sv_catpvf(aTHX_ msg, "\\%03"UVof, (UV)*f & 0xFF); @@ -11259,7 +11251,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) parser->multi_open = proto->multi_open; parser->multi_start = proto->multi_start; parser->multi_end = proto->multi_end; - parser->pending_ident = proto->pending_ident; parser->preambled = proto->preambled; parser->sublex_info = proto->sublex_info; /* XXX not quite right */ parser->linestr = sv_dup_inc(proto->linestr, param); @@ -11362,7 +11353,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) #ifdef HAS_FCHDIR DIR *pwd; - register const Direntry_t *dirent; + const Direntry_t *dirent; char smallbuf[256]; char *name = NULL; STRLEN len = 0; @@ -12157,6 +12148,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) daux->xhv_mro_meta = saux->xhv_mro_meta ? mro_meta_dup(saux->xhv_mro_meta, param) : 0; + daux->xhv_super = NULL; /* Record stashes for possible cloning in Perl_clone(). */ if (HvNAME(sstr)) @@ -12181,14 +12173,20 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) OP_REFCNT_LOCK; CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); OP_REFCNT_UNLOCK; + CvSLABBED_off(dstr); } else if (CvCONST(dstr)) { CvXSUBANY(dstr).any_ptr = sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); } + assert(!CvSLABBED(dstr)); if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr)); + if (CvNAMED(dstr)) + SvANY((CV *)dstr)->xcv_gv_u.xcv_hek = + share_hek_hek(CvNAME_HEK((CV *)sstr)); /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ - SvANY(MUTABLE_CV(dstr))->xcv_gv = + else + SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv = CvCVGV_RC(dstr) ? gv_dup_inc(CvGV(sstr), param) : (param->flags & CLONEf_JOIN_IN) @@ -12274,6 +12272,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); } else { + ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); switch (CxTYPE(ncx)) { case CXt_SUB: ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 @@ -12292,6 +12291,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 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); + ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param); break; case CXt_LOOP_LAZYSV: ncx->blk_loop.state_u.lazysv.end @@ -12325,6 +12325,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) break; case CXt_BLOCK: case CXt_NULL: + case CXt_WHEN: + case CXt_GIVEN: break; } } @@ -12666,32 +12668,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) new_state->re_state_bostr = pv_dup(old_state->re_state_bostr); - new_state->re_state_reginput - = pv_dup(old_state->re_state_reginput); new_state->re_state_regeol = pv_dup(old_state->re_state_regeol); - new_state->re_state_regoffs - = (regexp_paren_pair*) - any_dup(old_state->re_state_regoffs, proto_perl); - new_state->re_state_reglastparen - = (U32*) any_dup(old_state->re_state_reglastparen, - proto_perl); - new_state->re_state_reglastcloseparen - = (U32*)any_dup(old_state->re_state_reglastcloseparen, - proto_perl); - /* XXX This just has to be broken. The old save_re_context - code did SAVEGENERICPV(PL_reg_start_tmp); - PL_reg_start_tmp is char **. - Look above to what the dup code does for - SAVEt_GENERIC_PVREF - It can never have worked. - So this is merely a faithful copy of the exiting bug: */ - new_state->re_state_reg_start_tmp - = (char **) pv_dup((char *) - old_state->re_state_reg_start_tmp); - /* I assume that it only ever "worked" because no-one called - (pseudo)fork while the regexp engine had re-entered itself. - */ #ifdef PERL_OLD_COPY_ON_WRITE new_state->re_state_nrs = sv_dup(old_state->re_state_nrs, param); @@ -12922,28 +12900,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_hash_seed = proto_perl->Ihash_seed; PL_rehash_seed = proto_perl->Irehash_seed; - SvANY(&PL_sv_undef) = NULL; - SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; - SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; - SvREFCNT(&PL_sv_no) = (~(U32)0)/2; - SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - - SvANY(&PL_sv_yes) = new_XPVNV(); - SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; - SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - /* dbargs array probably holds garbage */ PL_dbargs = NULL; PL_compiling = proto_perl->Icompiling; -#ifdef PERL_DEBUG_READONLY_OPS - PL_slabs = NULL; - PL_slab_count = 0; -#endif - /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; PL_origargv = proto_perl->Iorigargv; @@ -12983,7 +12944,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* RE engine related */ Zero(&PL_reg_state, 1, struct re_save_state); - PL_reginterp_cnt = 0; PL_regmatch_slab = NULL; PL_sub_generation = proto_perl->Isub_generation; @@ -13016,10 +12976,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_in_clean_objs = proto_perl->Iin_clean_objs; PL_in_clean_all = proto_perl->Iin_clean_all; - PL_uid = proto_perl->Iuid; - PL_euid = proto_perl->Ieuid; - PL_gid = proto_perl->Igid; - PL_egid = proto_perl->Iegid; + PL_delaymagic_uid = proto_perl->Idelaymagic_uid; + PL_delaymagic_euid = proto_perl->Idelaymagic_euid; + PL_delaymagic_gid = proto_perl->Idelaymagic_gid; + PL_delaymagic_egid = proto_perl->Idelaymagic_egid; PL_nomemok = proto_perl->Inomemok; PL_an = proto_perl->Ian; PL_evalseq = proto_perl->Ievalseq; @@ -13038,8 +12998,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_hints = proto_perl->Ihints; - PL_amagic_generation = proto_perl->Iamagic_generation; - #ifdef USE_LOCALE_COLLATE PL_collation_ix = proto_perl->Icollation_ix; PL_collation_standard = proto_perl->Icollation_standard; @@ -13170,21 +13128,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_ptr_table = ptr_table_new(); /* initialize these special pointers as early as possible */ + init_constants(); ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); - - SvANY(&PL_sv_no) = new_XPVNV(); - SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); - SvCUR_set(&PL_sv_no, 0); - SvLEN_set(&PL_sv_no, 1); - SvIV_set(&PL_sv_no, 0); - SvNV_set(&PL_sv_no, 0); ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); - - SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); - SvCUR_set(&PL_sv_yes, 1); - SvLEN_set(&PL_sv_yes, 2); - SvIV_set(&PL_sv_yes, 1); - SvNV_set(&PL_sv_yes, 1); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); /* create (a non-shared!) shared string table */ @@ -13193,10 +13139,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); - /* These two PVs will be free'd special way so must set them same way op.c does */ - PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); - ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); - + /* This PV will be free'd special way so must set it same way op.c does */ PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); @@ -13237,7 +13180,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); /* magical thingies */ - PL_formfeed = sv_dup(proto_perl->Iformfeed, param); PL_encoding = sv_dup(proto_perl->Iencoding, param); @@ -13254,6 +13196,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); PL_regex_pad = AvARRAY(PL_regex_padav); + PL_stashpadmax = proto_perl->Istashpadmax; + PL_stashpadix = proto_perl->Istashpadix ; + Newx(PL_stashpad, PL_stashpadmax, HV *); + { + PADOFFSET o = 0; + for (; o < PL_stashpadmax; ++o) + PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); + } + /* shortcuts to various I/O objects */ PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param); PL_stdingv = gv_dup(proto_perl->Istdingv, param); @@ -13429,9 +13380,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_VertSpace = sv_dup_inc(proto_perl->IVertSpace, param); + PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param); + /* utf8 character class swashes */ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); + PL_utf8_blank = sv_dup_inc(proto_perl->Iutf8_blank, param); PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); @@ -13441,16 +13395,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); - PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param); + PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param); PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); - PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param); - PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param); - PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param); - PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param); PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param); - PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param); - PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param); - PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param); PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); @@ -13461,7 +13408,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param); - PL_utf8_quotemeta = sv_dup_inc(proto_perl->Iutf8_quotemeta, param); PL_ASCII = sv_dup_inc(proto_perl->IASCII, param); PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); @@ -13707,6 +13653,38 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) #endif /* USE_ITHREADS */ +void +Perl_init_constants(pTHX) +{ + SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; + SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; + SvANY(&PL_sv_undef) = NULL; + + SvANY(&PL_sv_no) = new_XPVNV(); + SvREFCNT(&PL_sv_no) = (~(U32)0)/2; + SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK; + + SvANY(&PL_sv_yes) = new_XPVNV(); + SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; + SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK; + + SvPV_set(&PL_sv_no, (char*)PL_No); + SvCUR_set(&PL_sv_no, 0); + SvLEN_set(&PL_sv_no, 0); + SvIV_set(&PL_sv_no, 0); + SvNV_set(&PL_sv_no, 0); + + SvPV_set(&PL_sv_yes, (char*)PL_Yes); + SvCUR_set(&PL_sv_yes, 1); + SvLEN_set(&PL_sv_yes, 0); + SvIV_set(&PL_sv_yes, 1); + SvNV_set(&PL_sv_yes, 1); +} + /* =head1 Unicode Support @@ -13851,7 +13829,7 @@ STATIC SV* S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) { dVAR; - register HE **array; + HE **array; I32 i; PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; @@ -13863,7 +13841,7 @@ S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) array = HvARRAY(hv); for (i=HvMAX(hv); i>0; i--) { - register HE *entry; + HE *entry; for (entry = array[i]; entry; entry = HeNEXT(entry)) { if (HeVAL(entry) != val) continue; @@ -13905,7 +13883,7 @@ S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) return -1; } -/* S_varname(): return the name of a variable, optionally with a subscript. +/* varname(): return the name of a variable, optionally with a subscript. * If gv is non-zero, use the name of that global, along with gvtype (one * of "$", "@", "%"); otherwise use the name of the lexical at pad offset * targ. Depending on the value of the subscript_type flag, return: @@ -13941,15 +13919,15 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, } } else { - CV * const cv = gv ? (CV *)gv : find_runcv(NULL); + CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); SV *sv; AV *av; - assert(!cv || SvTYPE(cv) == SVt_PVCV); + assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); if (!cv || !CvPADLIST(cv)) return NULL; - av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE))); + av = *PadlistARRAY(CvPADLIST(cv)); sv = *av_fetch(av, targ, FALSE); sv_setsv(name, sv); } @@ -14460,8 +14438,8 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */