X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3ed356df9354193bbcc5202f066f3c07ae84b443..265075c0d13cbdf53c9e662decbb83fc34d4e7a4:/sv.c diff --git a/sv.c b/sv.c index 1bebb81..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: @@ -1403,7 +1401,9 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) 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; @@ -2067,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 @@ -2277,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) { @@ -2308,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); @@ -2370,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) { @@ -2392,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); @@ -2436,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)) @@ -2458,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. */ @@ -2475,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); @@ -2527,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)) @@ -2919,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; @@ -4017,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: */ @@ -4035,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); } @@ -4146,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) { @@ -4189,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 ) && @@ -4759,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)) { @@ -4781,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)); @@ -4801,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); } @@ -5284,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)) { @@ -6034,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: @@ -6110,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))) @@ -7916,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; @@ -8098,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; @@ -9456,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; @@ -11098,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') { @@ -11743,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)); @@ -11870,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); @@ -11958,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); @@ -11986,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: @@ -11997,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)) { @@ -12452,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); @@ -12907,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; @@ -13082,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 */ @@ -13407,6 +13458,8 @@ 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); @@ -13991,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; @@ -14198,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) { @@ -14242,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; @@ -14370,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) { @@ -14378,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; }