X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cec4dc0e420ef6e3b19b0e6f661d2b4fa43b93fa..265075c0d13cbdf53c9e662decbb83fc34d4e7a4:/sv.c diff --git a/sv.c b/sv.c index 1d42afb..4a57a9a 100644 --- a/sv.c +++ b/sv.c @@ -182,7 +182,9 @@ Public API: #endif #ifdef DEBUG_LEAKING_SCALARS -# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) +# define FREE_SV_DEBUG_FILE(sv) STMT_START { \ + if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ + } STMT_END # define DEBUG_SV_SERIAL(sv) \ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ PTR2UV(sv), (long)(sv)->sv_debug_serial)) @@ -275,7 +277,7 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) ); sv->sv_debug_inpad = 0; sv->sv_debug_parent = NULL; - sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; + sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; sv->sv_debug_serial = PL_sv_serial++; @@ -1161,7 +1163,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) no longer need to unshare so as to free up the IVX slot for its proper purpose. So it's safe to move the early return earlier. */ - if (new_type != SVt_PV && SvIsCOW(sv)) { + if (new_type > SVt_PVMG && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } @@ -1329,11 +1331,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) } break; - - case SVt_REGEXP: - /* This ensures that SvTHINKFIRST(sv) is true, and hence that - sv_force_normal_flags(sv) is called. */ - SvFAKE_on(sv); case SVt_PVIV: /* XXX Is this still needed? Was it ever needed? Surely as there is no route from NV to PVIV, NOK can never be true */ @@ -1344,6 +1341,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: + case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -1397,12 +1395,15 @@ 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)))); IoPAGE_LEN(sv) = 60; } - if (old_type < SVt_PV) { + if (new_type == SVt_REGEXP) + sv->sv_u.svu_rx = (regexp *)new_body; + else if (old_type < SVt_PV) { /* referant will be NULL unless the old type was SVt_IV emulating SVt_RV */ sv->sv_u.svu_rv = referant; @@ -2066,7 +2067,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) SvUVX(sv))); } } - else if (SvPOKp(sv) && SvLEN(sv)) { + else if (SvPOKp(sv)) { UV value; const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); /* We want to avoid a possible problem when we cache an IV/ a UV which @@ -2276,21 +2277,22 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) return PTR2IV(SvRV(sv)); } - if (SvVALID(sv)) { + if (SvVALID(sv) || isREGEXP(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. + + Regexps have no SvIVX and SvNVX fields. */ - if (SvIOKp(sv)) - return SvIVX(sv); - if (SvNOKp(sv)) - return I_V(SvNVX(sv)); - if (SvPOKp(sv) && SvLEN(sv)) { + assert(isREGEXP(sv) || SvPOKp(sv)); + { UV value; + const char * const ptr = + isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); const int numtype - = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + = grok_number(ptr, SvCUR(sv), &value); if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { @@ -2307,17 +2309,16 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - return I_V(Atof(SvPVX_const(sv))); + return I_V(Atof(ptr)); } - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; } if (SvTHINKFIRST(sv)) { +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } +#endif if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -2369,17 +2370,17 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) return PTR2UV(SvRV(sv)); } - if (SvVALID(sv)) { + if (SvVALID(sv) || isREGEXP(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 (SvIOKp(sv)) - return SvUVX(sv); - if (SvNOKp(sv)) - return U_V(SvNVX(sv)); - if (SvPOKp(sv) && SvLEN(sv)) { + the same flag bit as SVf_IVisUV, so must not let them cache IVs. + Regexps have no SvIVX and SvNVX fields. */ + assert(isREGEXP(sv) || SvPOKp(sv)); + { UV value; + const char * const ptr = + isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); const int numtype - = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + = grok_number(ptr, SvCUR(sv), &value); if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { @@ -2391,17 +2392,16 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - return U_V(Atof(SvPVX_const(sv))); + return U_V(Atof(ptr)); } - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; } if (SvTHINKFIRST(sv)) { +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } +#endif if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -2435,18 +2435,22 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) dVAR; if (!sv) return 0.0; - if (SvGMAGICAL(sv) || SvVALID(sv)) { + if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(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 NVs. */ + the same flag bit as SVf_IVisUV, so must not let them cache NVs. + Regexps have no SvIVX and SvNVX fields. */ + const char *ptr; if (flags & SV_GMAGIC) mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); - if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) { + if (SvPOKp(sv) && !SvIOKp(sv)) { + ptr = SvPVX_const(sv); + grokpv: if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && - !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) + !grok_number(ptr, SvCUR(sv), NULL)) not_a_number(sv); - return Atof(SvPVX_const(sv)); + return Atof(ptr); } if (SvIOKp(sv)) { if (SvIsUV(sv)) @@ -2457,6 +2461,10 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) if (SvROK(sv)) { goto return_rok; } + if (isREGEXP(sv)) { + ptr = RX_WRAPPED((REGEXP *)sv); + goto grokpv; + } assert(SvTYPE(sv) >= SVt_PVMG); /* This falls through to the report_uninit near the end of the function. */ @@ -2474,9 +2482,11 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) } return PTR2NV(SvRV(sv)); } +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } +#endif if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -2526,7 +2536,7 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) SvNOKp_on(sv); #endif } - else if (SvPOKp(sv) && SvLEN(sv)) { + else if (SvPOKp(sv)) { UV value; const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) @@ -2918,6 +2928,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags *lp = SvCUR(buffer); return SvPVX(buffer); } + else if (isREGEXP(sv)) { + if (lp) *lp = RX_WRAPLEN((REGEXP *)sv); + return RX_WRAPPED((REGEXP *)sv); + } else { if (lp) *lp = 0; @@ -3099,7 +3113,7 @@ Always sets the SvUTF8 flag to avoid future validity checks even if the whole string is the same in UTF-8 as not. Returns the number of bytes in the converted string -This is not as a general purpose byte encoding to Unicode interface: +This is not a general purpose byte encoding to Unicode interface: use the Encode extension for that. =for apidoc sv_utf8_upgrade_nomg @@ -3118,7 +3132,7 @@ Returns the number of bytes in the converted string C and C are implemented in terms of this function. -This is not as a general purpose byte encoding to Unicode interface: +This is not a general purpose byte encoding to Unicode interface: use the Encode extension for that. =cut @@ -3163,7 +3177,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST if (sv == &PL_sv_undef) return 0; - if (!SvPOK(sv)) { + if (!SvPOK_nog(sv)) { STRLEN len = 0; if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { (void) sv_2pv_flags(sv,&len, flags); @@ -3421,7 +3435,7 @@ in a byte, this conversion will fail; in this case, either returns false or, if C is not true, croaks. -This is not as a general purpose Unicode to byte encoding interface: +This is not a general purpose Unicode to byte encoding interface: use the Encode extension for that. =cut @@ -3882,6 +3896,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); @@ -4008,8 +4030,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) break; case SVt_REGEXP: + upgregexp: if (dtype < SVt_REGEXP) + { + if (dtype >= SVt_PV) { + SvPV_free(dstr); + SvPV_set(dstr, 0); + SvLEN_set(dstr, 0); + SvCUR_set(dstr, 0); + } sv_upgrade(dstr, SVt_REGEXP); + } break; /* case SVt_BIND: */ @@ -4026,7 +4057,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) return; } if (stype == SVt_PVLV) + { + if (isREGEXP(sstr)) goto upgregexp; SvUPGRADE(dstr, SVt_PVNV); + } else SvUPGRADE(dstr, (svtype)stype); } @@ -4137,7 +4171,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } } } - else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) { + else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV) + && (stype == SVt_REGEXP || isREGEXP(sstr))) { reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); } else if (sflags & SVp_POK) { @@ -4180,7 +4215,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) in a newer implementation. */ /* If we are COW and dstr is a suitable target then we drop down into the else and make dest a COW of us. */ - || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS + || (SvFLAGS(dstr) & SVf_BREAK) #endif ) && @@ -4711,7 +4746,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) #ifdef PERL_OLD_COPY_ON_WRITE if (SvREADONLY(sv)) { - if (SvFAKE(sv)) { + if (SvIsCOW(sv)) { const char * const pvx = SvPVX_const(sv); const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); @@ -4750,7 +4785,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) } } else if (IN_PERL_RUNTIME) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); } #else if (SvREADONLY(sv)) { @@ -4772,19 +4807,21 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } else if (IN_PERL_RUNTIME) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); } #endif if (SvROK(sv)) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && isGV_with_GP(sv)) sv_unglob(sv, flags); - else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { + else if (SvFAKE(sv) && isREGEXP(sv)) { /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous to sv_unglob. We only need it here, so inline it. */ - const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; + const bool islv = SvTYPE(sv) == SVt_PVLV; + const svtype new_type = + islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; SV *const temp = newSV_type(new_type); - void *const temp_p = SvANY(sv); + regexp *const temp_p = ReANY((REGEXP *)sv); if (new_type == SVt_PVMG) { SvMAGIC_set(temp, SvMAGIC(sv)); @@ -4792,29 +4829,37 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) SvSTASH_set(temp, SvSTASH(sv)); SvSTASH_set(sv, NULL); } - SvCUR_set(temp, SvCUR(sv)); - /* Remember that SvPVX is in the head, not the body. */ - if (SvLEN(temp)) { - SvLEN_set(temp, SvLEN(sv)); - /* This signals "buffer is owned by someone else" in sv_clear, - which is the least effort way to stop it freeing the buffer. - */ - SvLEN_set(sv, SvLEN(sv)+1); - } else { - /* Their buffer is already owned by someone else. */ - SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv)); - SvLEN_set(temp, SvCUR(sv)+1); + if (!islv) SvCUR_set(temp, SvCUR(sv)); + /* Remember that SvPVX is in the head, not the body. But + RX_WRAPPED is in the body. */ + assert(ReANY((REGEXP *)sv)->mother_re); + /* Their buffer is already owned by someone else. */ + if (flags & SV_COW_DROP_PV) { + /* SvLEN is already 0. For SVt_REGEXP, we have a brand new + zeroed body. For SVt_PVLV, it should have been set to 0 + before turning into a regexp. */ + assert(!SvLEN(islv ? sv : temp)); + sv->sv_u.svu_pv = 0; + } + else { + sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); + SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); + SvPOK_on(sv); } /* Now swap the rest of the bodies. */ - SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK); - SvFLAGS(sv) |= new_type; - SvANY(sv) = SvANY(temp); + SvFAKE_off(sv); + if (!islv) { + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= new_type; + SvANY(sv) = SvANY(temp); + } SvFLAGS(temp) &= ~(SVTYPEMASK); SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; SvANY(temp) = temp_p; + temp->sv_u.svu_rx = (regexp *)temp_p; SvREFCNT_dec(temp); } @@ -5275,7 +5320,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) ) { - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); } } if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { @@ -6025,6 +6070,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) goto freescalar; case SVt_REGEXP: /* FIXME for plugins */ + freeregexp: pregfree2((REGEXP*) sv); goto freescalar; case SVt_PVCV: @@ -6047,9 +6093,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); } @@ -6098,6 +6147,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) } else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); + if (isREGEXP(sv)) goto freeregexp; case SVt_PVGV: if (isGV_with_GP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) @@ -6460,7 +6510,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 */ @@ -6473,10 +6524,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; } @@ -6504,13 +6552,8 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv) if (!sv) return 0; - if (SvGMAGICAL(sv)) - return mg_length(sv); - else - { - SvGETMAGIC(sv); - return sv_len_utf8_nomg(sv); - } + SvGETMAGIC(sv); + return sv_len_utf8_nomg(sv); } STRLEN @@ -6522,7 +6565,7 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG; - if (PL_utf8cache) { + if (PL_utf8cache && SvUTF8(sv)) { STRLEN ulen; MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; @@ -6549,7 +6592,7 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) } return ulen; } - return Perl_utf8_length(aTHX_ s, s + len); + return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len; } /* Walk forwards to find the byte corresponding to the passed in UTF-8 @@ -6637,7 +6680,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start if (!uoffset) return 0; - if (!SvREADONLY(sv) + if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv) && PL_utf8cache && (*mgp || (SvTYPE(sv) >= SVt_PVMG && (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { @@ -6720,7 +6763,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start boffset = real_boffset; } - if (PL_utf8cache) { + if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) { if (at_end) utf8_mg_len_cache_update(sv, mgp, uoffset); else @@ -6832,7 +6875,7 @@ S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN ulen) { PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE; - if (SvREADONLY(sv)) + if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv)) return; if (!*mgp && (SvTYPE(sv) < SVt_PVMG || @@ -7911,7 +7954,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); } if (SvROK(sv)) { IV i; @@ -8093,7 +8136,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); } if (SvROK(sv)) { IV i; @@ -8220,13 +8263,15 @@ statement boundaries. See also C and C. * permanent location. */ SV * -Perl_sv_mortalcopy(pTHX_ SV *const oldstr) +Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) { dVAR; SV *sv; + if (flags & SV_GMAGIC) + SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ new_SV(sv); - sv_setsv(sv,oldstr); + sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC); PUSH_EXTEND_MORTAL__SV_C(sv); SvTEMP_on(sv); return sv; @@ -8709,11 +8754,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; } @@ -8729,15 +8775,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**); @@ -8762,7 +8815,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] == '-') { @@ -9108,8 +9162,8 @@ Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE; - sv_pvn_force(sv,lp); - sv_utf8_upgrade(sv); + sv_pvn_force(sv,0); + sv_utf8_upgrade_nomg(sv); *lp = SvCUR(sv); return SvPVX(sv); } @@ -9440,10 +9494,8 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { - if (SvIsCOW(tmpRef)) - sv_force_normal_flags(tmpRef, 0); - if (SvREADONLY(tmpRef)) - Perl_croak_no_modify(aTHX); + if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef)) + Perl_croak_no_modify(); if (SvOBJECT(tmpRef)) { if (SvTYPE(tmpRef) != SVt_PVIO) --PL_sv_objcount; @@ -10518,16 +10570,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (DO_UTF8(argsv)) { STRLEN old_precis = precis; if (has_precis && precis < elen) { - STRLEN ulen = sv_len_utf8_nomg(argsv); + STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); STRLEN p = precis > ulen ? ulen : precis; - precis = sv_pos_u2b_flags(argsv, p, 0, 0); + precis = sv_or_pv_pos_u2b(argsv, eptr, p, 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_nomg(argsv); + width += + elen - sv_or_pv_len_utf8(argsv,eptr,elen); } is_utf8 = TRUE; } @@ -11081,13 +11134,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p have = esignlen + zeros + elen; if (have < zeros) - Perl_croak_nocontext("%s", PL_memory_wrap); + croak_memory_wrap(); need = (have > width ? have : width); gap = need - have; if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) - Perl_croak_nocontext("%s", PL_memory_wrap); + croak_memory_wrap(); SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { @@ -11726,6 +11779,7 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa { PERL_ARGS_ASSERT_RVPV_DUP; + assert(!isREGEXP(sstr)); if (SvROK(sstr)) { if (SvWEAKREF(sstr)) { SvRV_set(dstr, sv_dup(SvRV_const(sstr), param)); @@ -11853,7 +11907,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) dstr->sv_debug_inpad = sstr->sv_debug_inpad; dstr->sv_debug_parent = (SV*)sstr; FREE_SV_DEBUG_FILE(dstr); - dstr->sv_debug_file = savepv(sstr->sv_debug_file); + dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file); #endif ptr_table_store(PL_ptr_table, sstr, dstr); @@ -11941,6 +11995,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) if (sv_type != SVt_PVAV && sv_type != SVt_PVHV && !isGV_with_GP(dstr) + && !isREGEXP(dstr) && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))) Perl_rvpv_dup(aTHX_ dstr, sstr, param); @@ -11969,7 +12024,9 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) case SVt_PVMG: break; case SVt_REGEXP: + duprex: /* FIXME for plugins */ + dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any; re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); break; case SVt_PVLV: @@ -11980,6 +12037,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param)); else LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); + if (isREGEXP(sstr)) goto duprex; case SVt_PVGV: /* non-GP case already handled above */ if(isGV_with_GP(sstr)) { @@ -12435,6 +12493,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPUV(nss,ix) = uv; switch (type) { case SAVEt_CLEARSV: + case SAVEt_CLEARPADRANGE: break; case SAVEt_HELEM: /* hash element */ sv = (const SV *)POPPTR(ss,ix); @@ -12890,9 +12949,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origargc = proto_perl->Iorigargc; PL_origargv = proto_perl->Iorigargv; +#if !NO_TAINT_SUPPORT /* Set tainting stuff before PerlIO_debug can possibly get called */ PL_tainting = proto_perl->Itainting; PL_taint_warn = proto_perl->Itaint_warn; +#else + PL_tainting = FALSE; + PL_taint_warn = FALSE; +#endif PL_minus_c = proto_perl->Iminus_c; @@ -13065,7 +13129,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_timesbuf = proto_perl->Itimesbuf; #endif +#if !NO_TAINT_SUPPORT PL_tainted = proto_perl->Itainted; +#else + PL_tainted = FALSE; +#endif PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ @@ -13362,6 +13430,7 @@ 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); + PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param); /* utf8 character class swashes */ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); @@ -13389,11 +13458,12 @@ 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_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param); + PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, 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) { Newxz(PL_psig_pend, SIG_SIZE, int); } @@ -13701,8 +13771,8 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) save_re_context(); PUSHMARK(sp); EXTEND(SP, 3); - XPUSHs(encoding); - XPUSHs(sv); + PUSHs(encoding); + PUSHs(sv); /* NI-S 2002/07/09 Passing sv_yes is wrong - it needs to be or'ed set of constants @@ -13772,12 +13842,12 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, save_re_context(); PUSHMARK(sp); EXTEND(SP, 6); - XPUSHs(encoding); - XPUSHs(dsv); - XPUSHs(ssv); + PUSHs(encoding); + PUSHs(dsv); + PUSHs(ssv); offsv = newSViv(*offset); - mXPUSHs(offsv); - mXPUSHp(tstr, tlen); + mPUSHs(offsv); + mPUSHp(tstr, tlen); PUTBACK; call_method("cat_decode", G_SCALAR); SPAGAIN; @@ -13821,7 +13891,7 @@ S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) array = HvARRAY(hv); - for (i=HvMAX(hv); i>0; i--) { + for (i=HvMAX(hv); i>=0; i--) { HE *entry; for (entry = array[i]; entry; entry = HeNEXT(entry)) { if (HeVAL(entry) != val) @@ -13910,7 +13980,7 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, return NULL; av = *PadlistARRAY(CvPADLIST(cv)); sv = *av_fetch(av, targ, FALSE); - sv_setsv(name, sv); + sv_setsv_flags(name, sv, 0); } if (subscript_type == FUV_SUBSCRIPT_HASH) { @@ -13974,8 +14044,16 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_PADAV: case OP_PADHV: { - const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); - const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); + const bool pad = ( obase->op_type == OP_PADAV + || obase->op_type == OP_PADHV + || obase->op_type == OP_PADRANGE + ); + + const bool hash = ( obase->op_type == OP_PADHV + || obase->op_type == OP_RV2HV + || (obase->op_type == OP_PADRANGE + && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV) + ); I32 index = 0; SV *keysv = NULL; int subscript_type = FUV_SUBSCRIPT_WITHIN; @@ -14181,7 +14259,9 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_OPEN: o = cUNOPx(obase)->op_first; - if (o->op_type == OP_PUSHMARK) + if ( o->op_type == OP_PUSHMARK + || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) + ) o = o->op_sibling; if (!o->op_sibling) { @@ -14225,7 +14305,10 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, match = 1; /* print etc can return undef on defined args */ /* skip filehandle as it can't produce 'undef' warning */ o = cUNOPx(obase)->op_first; - if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) + if ((obase->op_flags & OPf_STACKED) + && + ( o->op_type == OP_PUSHMARK + || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK))) o = o->op_sibling->op_sibling; goto do_op2; @@ -14353,6 +14436,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, * left that is not skipped, then we *know* it is responsible for * the uninitialized value. If there is more than one op left, we * have to look for an exact match in the while() loop below. + * Note that we skip padrange, because the individual pad ops that + * it replaced are still in the tree, so we work on them instead. */ o2 = NULL; for (kid=o; kid; kid = kid->op_sibling) { @@ -14361,6 +14446,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) || (type == OP_PUSHMARK) + || (type == OP_PADRANGE) ) continue; }