X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/043c750c4e1a47be8effe0df70ccd1714aff0460..64d1236453b904858b3d262dfdb71aac934623d0:/sv.c diff --git a/sv.c b/sv.c index e972476..1a0e121 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 @@ -1471,7 +1471,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; @@ -1610,13 +1610,16 @@ Perl_sv_setuv(pTHX_ register SV *const sv, const UV u) { PERL_ARGS_ASSERT_SV_SETUV; - /* With these two if statements: + /* With the if statement to ensure that integers are stored as IVs whenever + possible: u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 without u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 - If you wish to remove them, please benchmark to see what the effect is + If you wish to remove the following if statement, so that this routine + (and its callers) always return UVs, please benchmark to see what the + effect is. Modern CPUs may be different. Or may not :-) */ if (u <= (UV)IV_MAX) { sv_setiv(sv, (IV)u); @@ -1799,7 +1802,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; @@ -1815,16 +1818,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; @@ -2253,22 +2256,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 @@ -2291,25 +2309,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); } @@ -2319,10 +2324,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); @@ -2342,13 +2349,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)) @@ -2370,25 +2393,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); } @@ -2398,6 +2408,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; @@ -2712,198 +2723,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) { - 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 */; - } - - 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); + stashname = "__ANON__"; + stashnamelen = 8; } - /* retval may not necessarily have reached the start of the - buffer here. */ - assert (retval >= buffer); + len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } else { + len = typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } - 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); @@ -2921,7 +2884,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) { @@ -2942,32 +2905,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(); + else if (isGV_with_GP(sv)) { + GV *const gv = MUTABLE_GV(sv); + SV *const buffer = sv_newmortal(); - gv_efullname3(buffer, gv, "*"); - - 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) @@ -2995,17 +2958,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); @@ -3026,11 +3009,17 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp) +Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_2PVBYTE; - SvGETMAGIC(sv); + if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) + || isGV_with_GP(sv) || SvROK(sv)) { + SV *sv2 = sv_newmortal(); + sv_copypv(sv2,sv); + sv = sv2; + } + else SvGETMAGIC(sv); sv_utf8_downgrade(sv,0); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3047,12 +3036,17 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp) +Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_2PVUTF8; - sv_utf8_upgrade(sv); - return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); + if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) + || isGV_with_GP(sv) || SvROK(sv)) + sv = sv_mortalcopy(sv); + else + SvGETMAGIC(sv); + sv_utf8_upgrade_nomg(sv); + return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3092,30 +3086,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); } /* @@ -3521,11 +3492,8 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv) { PERL_ARGS_ASSERT_SV_UTF8_ENCODE; - if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } if (SvREADONLY(sv)) { - Perl_croak_no_modify(aTHX); + sv_force_normal_flags(sv, 0); } (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); @@ -3562,7 +3530,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *const sv) * we want to make sure everything inside is valid utf8 first. */ c = start = (const U8 *) SvPVX_const(sv); - if (!is_utf8_string(c, SvCUR(sv)+1)) + if (!is_utf8_string(c, SvCUR(sv))) return FALSE; e = (const U8 *) SvEND(sv); while (c < e) { @@ -3693,7 +3661,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 { @@ -3728,6 +3695,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))) { @@ -3739,7 +3707,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,9 +3894,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; @@ -3948,13 +3917,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) { @@ -4022,15 +3984,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); @@ -4083,7 +4036,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; @@ -4098,7 +4051,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 */ @@ -4241,7 +4195,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 ) { @@ -4386,7 +4340,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; @@ -4465,7 +4419,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; @@ -4478,7 +4432,8 @@ Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, regi /* len is STRLEN which is unsigned, need to copy to signed */ const IV iv = len; if (iv < 0) - Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen"); + Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" + IVdf, iv); } SvUPGRADE(sv, SVt_PV); @@ -4521,7 +4476,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; @@ -4590,6 +4545,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); @@ -4730,10 +4686,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, @@ -4796,7 +4754,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) } #else if (SvREADONLY(sv)) { - if (SvFAKE(sv) && !isGV_with_GP(sv)) { + if (SvIsCOW(sv)) { const char * const pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvFAKE_off(sv); @@ -4860,15 +4818,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. @@ -4907,6 +4867,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 */ @@ -5034,18 +4995,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 */ @@ -5056,18 +5018,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); } /* @@ -5083,7 +5045,7 @@ void Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr) { dVAR; - register STRLEN len; + STRLEN len; STRLEN tlen; char *junk; @@ -5158,7 +5120,7 @@ SV * Perl_newSV(pTHX_ const STRLEN len) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); if (len) { @@ -5255,8 +5217,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; } @@ -5309,7 +5269,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, if (SvREADONLY(sv)) { if ( /* its okay to attach magic to shared strings */ - (!SvFAKE(sv) || isGV_with_GP(sv)) + !SvIsCOW(sv) && IN_PERL_RUNTIME && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) @@ -5323,13 +5283,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; } } @@ -5558,14 +5513,48 @@ 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; svp = mg ? &(mg->mg_obj) : NULL; } - if (!svp || !*svp) - Perl_croak(aTHX_ "panic: del_backref"); + if (!svp) + Perl_croak(aTHX_ "panic: del_backref, svp=0"); + if (!*svp) { + /* It's possible that sv is being freed recursively part way through the + freeing of tsv. If this happens, the backreferences array of tsv has + already been freed, and so svp will be NULL. If this is the case, + we should not panic. Instead, nothing needs doing, so return. */ + if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) + return; + Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, + *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); + } if (SvTYPE(*svp) == SVt_PVAV) { #ifdef DEBUGGING @@ -5617,10 +5606,13 @@ Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) assert(count ==1); AvFILLp(av) = fill-1; } + else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) { + /* freed AV; skip */ + } else { /* optimisation: only a single backref, stored directly */ if (*svp != sv) - Perl_croak(aTHX_ "panic: del_backref"); + Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv); *svp = NULL; } @@ -5638,7 +5630,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)) { @@ -5734,17 +5726,17 @@ 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; if (!bigstr) - Perl_croak(aTHX_ "Can't modify non-existent substring"); + Perl_croak(aTHX_ "Can't modify nonexistent substring"); SvPV_force_flags(bigstr, curlen, flags); (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { @@ -5780,7 +5772,8 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l bigend = big + SvCUR(bigstr); if (midend > bigend) - Perl_croak(aTHX_ "panic: sv_insert"); + Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", + midend, bigend); if (mid - big > bigend - midend) { /* faster to shorten from end */ if (littlelen) { @@ -5957,7 +5950,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; @@ -6005,6 +5998,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)); } @@ -6025,6 +6019,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); + if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; goto freescalar; case SVt_REGEXP: /* FIXME for plugins */ @@ -6061,14 +6057,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 */ } @@ -6123,6 +6117,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) /* See also S_sv_unglob, which does the same thing. */ if ((const GV *)sv == PL_last_in_gv) PL_last_in_gv = NULL; + else if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -6172,7 +6168,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) Safefree(SvPVX_mutable(sv)); - else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { + else if (SvPVX_const(sv) && SvIsCOW(sv)) { unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); SvFAKE_off(sv); } @@ -6230,13 +6226,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); @@ -6929,7 +6928,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 @@ -6938,18 +6936,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]) { @@ -6960,16 +6954,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 { @@ -6980,18 +6970,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; } } } @@ -7059,7 +7045,8 @@ Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp) s = (const U8*)SvPV_const(sv, blen); if (blen < byte) - Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); + Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf + ", byte=%"UVuf, (UV)blen, (UV)byte); send = s + byte; @@ -7540,7 +7527,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 */ @@ -7551,9 +7541,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; @@ -7568,8 +7558,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)) { @@ -7662,7 +7650,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; @@ -7808,7 +7796,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 */ @@ -7828,9 +7816,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 || @@ -7902,7 +7890,7 @@ void Perl_sv_inc_nomg(pTHX_ register SV *const sv) { dVAR; - register char *d; + char *d; int flags; if (!sv) @@ -7955,6 +7943,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv) const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT && was >= NV_OVERFLOWS_INTEGERS_AT) { + /* diag_listed_as: Lost precision when %s %f by 1 */ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), "Lost precision when incrementing %" NVff " by 1", was); @@ -8139,6 +8128,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv) const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT && was <= -NV_OVERFLOWS_INTEGERS_AT) { + /* diag_listed_as: Lost precision when %s %f by 1 */ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), "Lost precision when decrementing %" NVff " by 1", was); @@ -8222,7 +8212,7 @@ SV * Perl_sv_mortalcopy(pTHX_ SV *const oldstr) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setsv(sv,oldstr); @@ -8246,7 +8236,7 @@ SV * Perl_sv_newmortal(pTHX) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); SvFLAGS(sv) = SVs_TEMP; @@ -8279,7 +8269,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. */ @@ -8343,7 +8333,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)); @@ -8353,22 +8343,24 @@ Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) /* =for apidoc newSVpvn -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. +Creates a new SV and copies a buffer into it, which may contain NUL characters +(C<\0>) and other binary data. The reference count for the SV is set to 1. +Note that if C is zero, Perl will create a zero length (Perl) string. You +are responsible for ensuring that the source buffer is at least +C bytes long. If the C argument is NULL the new SV will be +undefined. =cut */ SV * -Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len) +Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); - sv_setpvn(sv,s,len); + sv_setpvn(sv,buffer,len); return sv; } @@ -8463,7 +8455,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; @@ -8519,7 +8511,7 @@ SV * Perl_newSVpvf_nocontext(const char *const pat, ...) { dTHX; - register SV *sv; + SV *sv; va_list args; PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT; @@ -8543,7 +8535,7 @@ C. SV * Perl_newSVpvf(pTHX_ const char *const pat, ...) { - register SV *sv; + SV *sv; va_list args; PERL_ARGS_ASSERT_NEWSVPVF; @@ -8560,7 +8552,7 @@ SV * Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) { dVAR; - register SV *sv; + SV *sv; PERL_ARGS_ASSERT_VNEWSVPVF; @@ -8582,7 +8574,7 @@ SV * Perl_newSVnv(pTHX_ const NV n) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setnv(sv,n); @@ -8602,7 +8594,7 @@ SV * Perl_newSViv(pTHX_ const IV i) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setiv(sv,i); @@ -8622,7 +8614,7 @@ SV * Perl_newSVuv(pTHX_ const UV u) { dVAR; - register SV *sv; + SV *sv; new_SV(sv); sv_setuv(sv,u); @@ -8641,7 +8633,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); @@ -8661,7 +8653,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; @@ -8698,7 +8690,7 @@ SV * Perl_newSVsv(pTHX_ register SV *const old) { dVAR; - register SV *sv; + SV *sv; if (!old) return NULL; @@ -8775,8 +8767,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; @@ -8948,20 +8940,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); } @@ -8983,7 +8965,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'))) @@ -9049,12 +9031,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; @@ -9074,6 +9059,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); } @@ -9273,7 +9259,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); @@ -9460,11 +9445,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); @@ -9527,6 +9507,8 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags) if ((const GV *)sv == PL_last_in_gv) PL_last_in_gv = NULL; + else if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; } /* @@ -9903,7 +9885,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); } @@ -9977,18 +9959,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); @@ -9999,6 +9984,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; @@ -10017,11 +10012,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) @@ -10029,10 +10027,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); @@ -10041,7 +10041,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; } @@ -10064,7 +10064,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; } @@ -10072,7 +10072,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; } } @@ -10143,9 +10143,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) @@ -10389,7 +10389,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'; @@ -10400,7 +10400,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++; @@ -10999,7 +10999,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, } } else - sv_setuv_mg(argsv, (UV)i); + sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i); continue; /* not "break" */ /* UNKNOWN */ @@ -11019,7 +11019,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); @@ -11324,7 +11324,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; @@ -11811,6 +11811,27 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) return dstr; } } + else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) { + HV *stash = GvSTASH(sstr); + const HEK * hvname; + if (stash && (hvname = HvNAME_HEK(stash))) { + /** don't clone GVs if they already exist **/ + SV **svp; + stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), + HEK_UTF8(hvname) ? SVf_UTF8 : 0); + svp = hv_fetch( + stash, GvNAME(sstr), + GvNAMEUTF8(sstr) + ? -GvNAMELEN(sstr) + : GvNAMELEN(sstr), + 0 + ); + if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { + ptr_table_store(PL_ptr_table, sstr, *svp); + return *svp; + } + } + } } /* create anew and remember what it is */ @@ -12122,10 +12143,12 @@ 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)); /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ @@ -12215,6 +12238,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 @@ -12233,6 +12257,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 @@ -12266,6 +12291,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; } } @@ -12611,28 +12638,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = 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); @@ -12863,28 +12868,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; @@ -12924,7 +12912,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; @@ -12957,10 +12944,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; @@ -12979,8 +12966,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; @@ -13024,10 +13009,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_globhook = proto_perl->Iglobhook; -#ifdef THREADS_HAVE_PIDS - PL_ppid = proto_perl->Ippid; -#endif - /* swatch cache */ PL_last_swash_hv = NULL; /* reinits on demand */ PL_last_swash_klen = 0; @@ -13115,21 +13096,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 */ @@ -13138,10 +13107,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); @@ -13199,6 +13165,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); @@ -13325,9 +13300,61 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); #endif /* !USE_LOCALE_NUMERIC */ - /* utf8 character classes */ + /* Unicode inversion lists */ + PL_ASCII = sv_dup_inc(proto_perl->IASCII, param); + PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); + + PL_PerlSpace = sv_dup_inc(proto_perl->IPerlSpace, param); + PL_XPerlSpace = sv_dup_inc(proto_perl->IXPerlSpace, param); + + PL_L1PosixAlnum = sv_dup_inc(proto_perl->IL1PosixAlnum, param); + PL_PosixAlnum = sv_dup_inc(proto_perl->IPosixAlnum, param); + + PL_L1PosixAlpha = sv_dup_inc(proto_perl->IL1PosixAlpha, param); + PL_PosixAlpha = sv_dup_inc(proto_perl->IPosixAlpha, param); + + PL_PosixBlank = sv_dup_inc(proto_perl->IPosixBlank, param); + PL_XPosixBlank = sv_dup_inc(proto_perl->IXPosixBlank, param); + + PL_L1Cased = sv_dup_inc(proto_perl->IL1Cased, param); + + PL_PosixCntrl = sv_dup_inc(proto_perl->IPosixCntrl, param); + PL_XPosixCntrl = sv_dup_inc(proto_perl->IXPosixCntrl, param); + + PL_PosixDigit = sv_dup_inc(proto_perl->IPosixDigit, param); + + PL_L1PosixGraph = sv_dup_inc(proto_perl->IL1PosixGraph, param); + PL_PosixGraph = sv_dup_inc(proto_perl->IPosixGraph, param); + + PL_L1PosixLower = sv_dup_inc(proto_perl->IL1PosixLower, param); + PL_PosixLower = sv_dup_inc(proto_perl->IPosixLower, param); + + PL_L1PosixPrint = sv_dup_inc(proto_perl->IL1PosixPrint, param); + PL_PosixPrint = sv_dup_inc(proto_perl->IPosixPrint, param); + + PL_L1PosixPunct = sv_dup_inc(proto_perl->IL1PosixPunct, param); + PL_PosixPunct = sv_dup_inc(proto_perl->IPosixPunct, param); + + PL_PosixSpace = sv_dup_inc(proto_perl->IPosixSpace, param); + PL_XPosixSpace = sv_dup_inc(proto_perl->IXPosixSpace, param); + + PL_L1PosixUpper = sv_dup_inc(proto_perl->IL1PosixUpper, param); + PL_PosixUpper = sv_dup_inc(proto_perl->IPosixUpper, param); + + PL_L1PosixWord = sv_dup_inc(proto_perl->IL1PosixWord, param); + PL_PosixWord = sv_dup_inc(proto_perl->IPosixWord, param); + + PL_PosixXDigit = sv_dup_inc(proto_perl->IPosixXDigit, param); + PL_XPosixXDigit = sv_dup_inc(proto_perl->IXPosixXDigit, param); + + 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); @@ -13337,13 +13364,14 @@ 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_special_begin = sv_dup_inc(proto_perl->Iutf8_X_special_begin, 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); + /*not currently used: 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_RI = sv_dup_inc(proto_perl->Iutf8_X_RI, 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); @@ -13357,6 +13385,10 @@ 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); if (proto_perl->Ipsig_pend) { @@ -13599,6 +13631,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 @@ -13743,7 +13807,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; @@ -13755,7 +13819,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; @@ -13797,7 +13861,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: @@ -13814,7 +13878,7 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, { SV * const name = sv_newmortal(); - if (gv) { + if (gv && isGV(gv)) { char buffer[2]; buffer[0] = gvtype; buffer[1] = 0; @@ -13833,13 +13897,15 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, } } else { - CV * const cv = find_runcv(NULL); + CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); SV *sv; AV *av; + 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); } @@ -13848,7 +13914,8 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, SV * const sv = newSV(0); *SvPVX(name) = '$'; Perl_sv_catpvf(aTHX_ name, "{%s}", - pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); + pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); SvREFCNT_dec(sv); } else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { @@ -14349,8 +14416,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: */