X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3e1022372a8200bc4c7354e0f588c7f71584a888..6720ec6068a79decfb482291f764ebdc6667131f:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 6405924..1fc855d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -69,9 +69,6 @@ PP(pp_wantarray) PP(pp_regcreset) { dVAR; - /* XXXX Should store the old value to allow for tie/overload - and - restore in regcomp, where marked with XXXX. */ - PL_reginterp_cnt = 0; TAINT_NOT; return NORMAL; } @@ -80,192 +77,113 @@ PP(pp_regcomp) { dVAR; dSP; - register PMOP *pm = (PMOP*)cLOGOP->op_other; - SV *tmpstr; + PMOP *pm = (PMOP*)cLOGOP->op_other; + SV **args; + int nargs; REGEXP *re = NULL; + REGEXP *new_re; + const regexp_engine *eng; + bool is_bare_re; + + if (PL_op->op_flags & OPf_STACKED) { + dMARK; + nargs = SP - MARK; + args = ++MARK; + } + else { + nargs = 1; + args = SP; + } /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { - if (PL_op->op_flags & OPf_STACKED) { - dMARK; - SP = MARK; - } - else - (void)POPs; + SP = args-1; RETURN; } #endif -#define tryAMAGICregexp(rx) \ - STMT_START { \ - SvGETMAGIC(rx); \ - if (SvROK(rx) && SvAMAGIC(rx)) { \ - SV *sv = AMG_CALLunary(rx, regexp_amg); \ - if (sv) { \ - if (SvROK(sv)) \ - sv = SvRV(sv); \ - if (SvTYPE(sv) != SVt_REGEXP) \ - Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \ - rx = sv; \ - } \ - } \ - } STMT_END - - - if (PL_op->op_flags & OPf_STACKED) { - /* multiple args; concatenate them */ - dMARK; dORIGMARK; - tmpstr = PAD_SV(ARGTARG); - sv_setpvs(tmpstr, ""); - while (++MARK <= SP) { - SV *msv = *MARK; - SV *sv; - - tryAMAGICregexp(msv); - - if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && - (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) - { - sv_setsv(tmpstr, sv); - continue; - } - sv_catsv_nomg(tmpstr, msv); - } - SvSETMAGIC(tmpstr); - SP = ORIGMARK; - } - else { - tmpstr = POPs; - tryAMAGICregexp(tmpstr); - } - -#undef tryAMAGICregexp - - if (SvROK(tmpstr)) { - SV * const sv = SvRV(tmpstr); - if (SvTYPE(sv) == SVt_REGEXP) - re = (REGEXP*) sv; - } - else if (SvTYPE(tmpstr) == SVt_REGEXP) - re = (REGEXP*) tmpstr; - - if (re) { - /* The match's LHS's get-magic might need to access this op's reg- - exp (as is sometimes the case with $'; see bug 70764). So we - must call get-magic now before we replace the regexp. Hopeful- - ly this hack can be replaced with the approach described at - http://www.nntp.perl.org/group/perl.perl5.porters/2007/03 - /msg122415.html some day. */ - if(pm->op_type == OP_MATCH) { - SV *lhs; - const bool was_tainted = PL_tainted; - if (pm->op_flags & OPf_STACKED) - lhs = TOPs; - else if (pm->op_private & OPpTARGET_MY) - lhs = PAD_SV(pm->op_targ); - else lhs = DEFSV; - SvGETMAGIC(lhs); - /* Restore the previous value of PL_tainted (which may have been - modified by get-magic), to avoid incorrectly setting the - RXf_TAINTED flag further down. */ - PL_tainted = was_tainted; + re = PM_GETRE(pm); + assert (re != (REGEXP*) &PL_sv_undef); + eng = re ? RX_ENGINE(re) : current_re_engine(); + + new_re = (eng->op_comp + ? eng->op_comp + : &Perl_re_op_compile + )(aTHX_ args, nargs, pm->op_code_list, eng, re, + &is_bare_re, + (pm->op_pmflags & RXf_PMf_COMPILETIME), + pm->op_pmflags | + (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); + if (pm->op_pmflags & PMf_HAS_CV) + ((struct regexp *)SvANY(new_re))->qr_anoncv + = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); + + if (is_bare_re) { + REGEXP *tmp; + /* The match's LHS's get-magic might need to access this op's regexp + (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call + get-magic now before we replace the regexp. Hopefully this hack can + be replaced with the approach described at + http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html + some day. */ + if (pm->op_type == OP_MATCH) { + SV *lhs; + const bool was_tainted = PL_tainted; + if (pm->op_flags & OPf_STACKED) + lhs = args[-1]; + else if (pm->op_private & OPpTARGET_MY) + lhs = PAD_SV(pm->op_targ); + else lhs = DEFSV; + SvGETMAGIC(lhs); + /* Restore the previous value of PL_tainted (which may have been + modified by get-magic), to avoid incorrectly setting the + RXf_TAINTED flag further down. */ + PL_tainted = was_tainted; } - - re = reg_temp_copy(NULL, re); - ReREFCNT_dec(PM_GETRE(pm)); - PM_SETRE(pm, re); + tmp = reg_temp_copy(NULL, new_re); + ReREFCNT_dec(new_re); + new_re = tmp; } - else { - STRLEN len = 0; - const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : ""; - - re = PM_GETRE(pm); - assert (re != (REGEXP*) &PL_sv_undef); - - /* Check against the last compiled regexp. */ - if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len || - memNE(RX_PRECOMP(re), t, len)) - { - const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; - U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; - if (re) { - ReREFCNT_dec(re); -#ifdef USE_ITHREADS - PM_SETRE(pm, (REGEXP*) &PL_sv_undef); -#else - PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ -#endif - } else if (PL_curcop->cop_hints_hash) { - SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); - if (ptr && SvIOK(ptr) && SvIV(ptr)) - eng = INT2PTR(regexp_engine*,SvIV(ptr)); - } - - if (PL_op->op_flags & OPf_SPECIAL) - PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - - if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) { - /* Not doing UTF-8, despite what the SV says. Is this only if - we're trapped in use 'bytes'? */ - /* Make a copy of the octet sequence, but without the flag on, - as the compiler now honours the SvUTF8 flag on tmpstr. */ - STRLEN len; - const char *const p = SvPV(tmpstr, len); - tmpstr = newSVpvn_flags(p, len, SVs_TEMP); - } - else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) { - /* make a copy to avoid extra stringifies */ - tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr)); - } - - if (eng) - PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); - else - PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); - - PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed - inside tie/overload accessors. */ - } + if (re != new_re) { + ReREFCNT_dec(re); + PM_SETRE(pm, new_re); } - - re = PM_GETRE(pm); #ifndef INCOMPLETE_TAINTS - if (PL_tainting) { - if (PL_tainted) { - SvTAINTED_on((SV*)re); - RX_EXTFLAGS(re) |= RXf_TAINTED; - } + if (PL_tainting && PL_tainted) { + SvTAINTED_on((SV*)new_re); + RX_EXTFLAGS(new_re) |= RXf_TAINTED; } #endif - if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) - pm = PL_curpm; - - #if !defined(USE_ITHREADS) /* can't change the optree at runtime either */ /* PMf_KEEP is handled differently under threads to avoid these problems */ + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) + pm = PL_curpm; if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ cLOGOP->op_first->op_next = PL_op->op_next; } #endif + + SP = args-1; RETURN; } + PP(pp_substcont) { dVAR; dSP; - register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - register PMOP * const pm = (PMOP*) cLOGOP->op_other; - register SV * const dstr = cx->sb_dstr; - register char *s = cx->sb_s; - register char *m = cx->sb_m; + PERL_CONTEXT *cx = &cxstack[cxstack_ix]; + PMOP * const pm = (PMOP*) cLOGOP->op_other; + SV * const dstr = cx->sb_dstr; + char *s = cx->sb_s; + char *m = cx->sb_m; char *orig = cx->sb_orig; - register REGEXP * const rx = cx->sb_rx; + REGEXP * const rx = cx->sb_rx; SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); @@ -295,28 +213,19 @@ PP(pp_substcont) s -= RX_GOFS(rx); /* Are we done */ - /* I believe that we can't set REXEC_SCREAM here if - SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always - equal to s. [See the comment before Perl_re_intuit_start(), which is - called from Perl_regexec_flags(), which says that it should be when - SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent - with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ - during the match. */ if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, - ((cx->sb_rflags & REXEC_COPY_STR) - ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) - : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) + (REXEC_IGNOREPOS|REXEC_NOT_FIRST))) { SV *targ = cx->sb_targ; assert(cx->sb_strend >= s); if(cx->sb_strend > s) { if (DO_UTF8(dstr) && !SvUTF8(targ)) - sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); + sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); else - sv_catpvn(dstr, s, cx->sb_strend - s); + sv_catpvn_nomg(dstr, s, cx->sb_strend - s); } if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; @@ -328,11 +237,9 @@ PP(pp_substcont) targ = dstr; } else { -#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(targ)) { sv_force_normal_flags(targ, SV_COW_DROP_PV); } else -#endif { SvPV_free(targ); } @@ -373,13 +280,14 @@ PP(pp_substcont) LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } cx->sb_iters = saviters; } if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; + assert(!RX_SUBOFFSET(rx)); cx->sb_orig = orig = RX_SUBBEG(rx); s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); @@ -387,9 +295,9 @@ PP(pp_substcont) cx->sb_m = m = RX_OFFS(rx)[0].start + orig; if (m > s) { if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) - sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); + sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv); else - sv_catpvn(dstr, s, m-s); + sv_catpvn_nomg(dstr, s, m-s); } cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ @@ -444,9 +352,9 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_OLD_COPY_ON_WRITE - i = 7 + RX_NPARENS(rx) * 2; + i = 7 + (RX_NPARENS(rx)+1) * 2; #else - i = 6 + RX_NPARENS(rx) * 2; + i = 6 + (RX_NPARENS(rx)+1) * 2; #endif if (!p) Newx(p, i, UV); @@ -455,6 +363,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } + /* what (if anything) to free on croak */ *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); RX_MATCH_COPIED_off(rx); @@ -464,9 +373,10 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) #endif *p++ = RX_NPARENS(rx); - *p++ = PTR2UV(RX_SUBBEG(rx)); *p++ = (UV)RX_SUBLEN(rx); + *p++ = (UV)RX_SUBOFFSET(rx); + *p++ = (UV)RX_SUBCOFFSET(rx); for (i = 0; i <= RX_NPARENS(rx); ++i) { *p++ = (UV)RX_OFFS(rx)[i].start; *p++ = (UV)RX_OFFS(rx)[i].end; @@ -494,9 +404,10 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) #endif RX_NPARENS(rx) = *p++; - RX_SUBBEG(rx) = INT2PTR(char*,*p++); RX_SUBLEN(rx) = (I32)(*p++); + RX_SUBOFFSET(rx) = (I32)*p++; + RX_SUBCOFFSET(rx) = (I32)*p++; for (i = 0; i <= RX_NPARENS(rx); ++i) { RX_OFFS(rx)[i].start = (I32)(*p++); RX_OFFS(rx)[i].end = (I32)(*p++); @@ -536,13 +447,13 @@ S_rxres_free(pTHX_ void **rsp) PP(pp_formline) { dVAR; dSP; dMARK; dORIGMARK; - register SV * const tmpForm = *++MARK; + SV * const tmpForm = *++MARK; SV *formsv; /* contains text of original format */ - register U32 *fpc; /* format ops program counter */ - register char *t; /* current append position in target string */ + U32 *fpc; /* format ops program counter */ + char *t; /* current append position in target string */ const char *f; /* current position in format string */ - register I32 arg; - register SV *sv = NULL; /* current item */ + I32 arg; + SV *sv = NULL; /* current item */ const char *item = NULL;/* string value of current item */ I32 itemsize = 0; /* length of current item, possibly truncated */ I32 fieldsize = 0; /* width of current field */ @@ -1300,7 +1211,7 @@ PP(pp_flop) SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { - register IV i, j; + IV i, j; IV max; if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) || (SvOK(right) && SvNV_nomg(right) > IV_MAX)) @@ -1381,21 +1292,22 @@ static const char * const context_name[] = { }; STATIC I32 -S_dopoptolabel(pTHX_ const char *label) +S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) { dVAR; - register I32 i; + I32 i; PERL_ARGS_ASSERT_DOPOPTOLABEL; for (i = cxstack_ix; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstack[i]; + const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: + /* diag_listed_as: Exiting subroutine via %s */ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); if (CxTYPE(cx) == CXt_NULL) @@ -1406,8 +1318,20 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: { - const char *cx_label = CxLABEL(cx); - if (!cx_label || strNE(label, cx_label) ) { + STRLEN cx_label_len = 0; + U32 cx_label_flags = 0; + const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); + if (!cx_label || !( + ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? + (flags & SVf_UTF8) + ? (bytes_cmp_utf8( + (const U8*)cx_label, cx_label_len, + (const U8*)label, len) == 0) + : (bytes_cmp_utf8( + (const U8*)label, len, + (const U8*)cx_label, cx_label_len) == 0) + : (len == cx_label_len && ((cx_label == label) + || memEQ(cx_label, label, len))) )) { DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", (long)i, cx_label)); continue; @@ -1447,7 +1371,7 @@ Perl_block_gimme(pTHX) return G_ARRAY; default: Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ return 0; } } @@ -1488,7 +1412,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) PERL_ARGS_ASSERT_DOPOPTOSUB_AT; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstk[i]; + const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; @@ -1508,7 +1432,7 @@ S_dopoptoeval(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT *cx = &cxstack[i]; + const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1526,13 +1450,14 @@ S_dopoptoloop(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstack[i]; + const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: + /* diag_listed_as: Exiting subroutine via %s */ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); if ((CxTYPE(cx)) == CXt_NULL) @@ -1555,7 +1480,7 @@ S_dopoptogiven(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT *cx = &cxstack[i]; + const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1583,7 +1508,7 @@ S_dopoptowhen(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT *cx = &cxstack[i]; + const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1606,7 +1531,7 @@ Perl_dounwind(pTHX_ I32 cxix) while (cxstack_ix > cxix) { SV *sv; - register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; + PERL_CONTEXT *cx = &cxstack[cxstack_ix]; DEBUG_CX("UNWIND"); \ /* Note: we don't need to restore the base context info till the end. */ switch (CxTYPE(cx)) { @@ -1716,7 +1641,7 @@ Perl_die_unwind(pTHX_ SV *msv) if (cxix >= 0) { I32 optype; SV *namesv; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV **newsp; COP *oldcop; JMPENV *restartjmpenv; @@ -1774,13 +1699,13 @@ Perl_die_unwind(pTHX_ SV *msv) PL_restartjmpenv = restartjmpenv; PL_restartop = restartop; JMPENV_JUMP(3); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } } write_to_stderr(exceptsv); my_failure_exit(); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } PP(pp_xor) @@ -1814,9 +1739,9 @@ frame for the sub call itself. const PERL_CONTEXT * Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { - register I32 cxix = dopoptosub(cxstack_ix); - register const PERL_CONTEXT *cx; - register const PERL_CONTEXT *ccstack = cxstack; + I32 cxix = dopoptosub(cxstack_ix); + const PERL_CONTEXT *cx; + const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; for (;;) { @@ -1856,7 +1781,7 @@ PP(pp_caller) { dVAR; dSP; - register const PERL_CONTEXT *cx; + const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; I32 gimme; const HEK *stash_hek; @@ -1878,7 +1803,11 @@ PP(pp_caller) RETURN; } - stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)); + DEBUG_CX("CALLER"); + assert(CopSTASH(cx->blk_oldcop)); + stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV + ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) + : NULL; if (GIMME != G_ARRAY) { EXTEND(SP, 1); if (!stash_hek) @@ -1907,7 +1836,7 @@ PP(pp_caller) if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { GV * const cvgv = CvGV(dbcx->blk_sub.cv); /* So is ccstack[dbcxix]. */ - if (isGV(cvgv)) { + if (cvgv && isGV(cvgv)) { SV * const sv = newSV(0); gv_efullname3(sv, cvgv, NULL); mPUSHs(sv); @@ -1930,7 +1859,9 @@ PP(pp_caller) if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { - PUSHs(cx->blk_eval.cur_text); + PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), + SvCUR(cx->blk_eval.cur_text)-2, + SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); PUSHs(&PL_sv_no); } /* require */ @@ -2023,11 +1954,11 @@ PP(pp_dbstate) || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = G_ARRAY; U8 hasargs; GV * const gv = PL_DBgv; - register CV * const cv = GvCV(gv); + CV * const cv = GvCV(gv); if (!cv) DIE(aTHX_ "No DB::DB routine defined"); @@ -2046,10 +1977,8 @@ PP(pp_dbstate) SPAGAIN; if (CvISXSUB(cv)) { - CvDEPTH(cv)++; PUSHMARK(SP); (void)(*CvXSUB(cv))(aTHX_ cv); - CvDEPTH(cv)--; FREETMPS; LEAVE; return NORMAL; @@ -2110,7 +2039,7 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla PP(pp_enter) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER_with_name("block"); @@ -2124,7 +2053,7 @@ PP(pp_enter) PP(pp_leave) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV **newsp; PMOP *newpm; I32 gimme; @@ -2150,7 +2079,7 @@ PP(pp_leave) PP(pp_enteriter) { dVAR; dSP; dMARK; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; void *itervar; /* location of the iteration variable */ U8 cxtype = CXt_LOOP_FOR; @@ -2273,7 +2202,7 @@ PP(pp_enteriter) PP(pp_enterloop) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; ENTER_with_name("loop1"); @@ -2289,7 +2218,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -2351,13 +2280,24 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, if (MARK < SP) { copy_sv: if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { + if (!SvPADTMP(*SP)) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); + } + else { + /* FREETMPS could clobber it */ + SV *sv = SvREFCNT_inc(*SP); + FREETMPS; + *++newsp = sv_mortalcopy(sv); + SvREFCNT_dec(sv); + } } else *++newsp = - !SvTEMP(*SP) + SvPADTMP(*SP) + ? sv_mortalcopy(*SP) + : !SvTEMP(*SP) ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) : *SP; } @@ -2377,10 +2317,10 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, if (ref || !CxLVAL(cx)) while (++MARK <= SP) *++newsp = - SvTEMP(*MARK) - ? *MARK - : ref && SvFLAGS(*MARK) & SVs_PADTMP + SvFLAGS(*MARK) & SVs_PADTMP ? sv_mortalcopy(*MARK) + : SvTEMP(*MARK) + ? *MARK : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); else while (++MARK <= SP) { if (*MARK != &PL_sv_undef @@ -2397,6 +2337,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); + /* diag_listed_as: Can't return %s from lvalue subroutine */ Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine", SvREADONLY(TOPs) ? "readonly value" : "temporary"); @@ -2414,7 +2355,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, PP(pp_return) { dVAR; dSP; dMARK; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; bool lval = FALSE; @@ -2486,7 +2427,7 @@ PP(pp_return) retop = cx->blk_sub.retop; break; default: - DIE(aTHX_ "panic: return"); + DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); } TAINT_NOT; @@ -2496,7 +2437,8 @@ PP(pp_return) if (MARK < SP) { if (popsub2) { if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) { + if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1 + && !SvMAGICAL(TOPs)) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); @@ -2508,7 +2450,8 @@ PP(pp_return) SvREFCNT_dec(sv); } } - else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) { + else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1 + && !SvMAGICAL(*SP)) { *++newsp = *SP; } else @@ -2523,6 +2466,7 @@ PP(pp_return) else if (gimme == G_ARRAY) { while (++MARK <= SP) { *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1 + && !SvGMAGICAL(*MARK) ? *MARK : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } @@ -2555,7 +2499,7 @@ PP(pp_leavesublv) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *sv; if (CxMULTICALL(&cxstack[cxstack_ix])) @@ -2577,33 +2521,60 @@ PP(pp_leavesublv) return cx->blk_sub.retop; } -PP(pp_last) +static I32 +S_unwind_loop(pTHX_ const char * const opname) { - dVAR; dSP; + dVAR; I32 cxix; - register PERL_CONTEXT *cx; - I32 pop2 = 0; - I32 gimme; - I32 optype; - OP *nextop = NULL; - SV **newsp; - PMOP *newpm; - SV **mark; - SV *sv = NULL; - - if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"last\" outside a loop block"); + /* diag_listed_as: Can't "last" outside a loop block */ + Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); } else { - cxix = dopoptolabel(cPVOP->op_pv); + dSP; + STRLEN label_len; + const char * const label = + PL_op->op_flags & OPf_STACKED + ? SvPV(TOPs,label_len) + : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); + const U32 label_flags = + PL_op->op_flags & OPf_STACKED + ? SvUTF8(POPs) + : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; + PUTBACK; + cxix = dopoptolabel(label, label_len, label_flags); if (cxix < 0) - DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); + /* diag_listed_as: Label not found for "last %s" */ + Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", + opname, + SVfARG(PL_op->op_flags & OPf_STACKED + && !SvGMAGICAL(TOPp1s) + ? TOPp1s + : newSVpvn_flags(label, + label_len, + label_flags | SVs_TEMP))); } if (cxix < cxstack_ix) dounwind(cxix); + return cxix; +} + +PP(pp_last) +{ + dVAR; + PERL_CONTEXT *cx; + I32 pop2 = 0; + I32 gimme; + I32 optype; + OP *nextop = NULL; + SV **newsp; + PMOP *newpm; + SV **mark; + SV *sv = NULL; + + S_unwind_loop(aTHX_ "last"); POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2630,13 +2601,12 @@ PP(pp_last) nextop = cx->blk_sub.retop; break; default: - DIE(aTHX_ "panic: last"); + DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx)); } TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, + PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme, pop2 == CXt_SUB ? SVs_TEMP : 0); - PUTBACK; LEAVE; cxstack_ix--; @@ -2664,26 +2634,13 @@ PP(pp_last) PP(pp_next) { dVAR; - I32 cxix; - register PERL_CONTEXT *cx; - I32 inner; + PERL_CONTEXT *cx; + const I32 inner = PL_scopestack_ix; - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"next\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); - } - if (cxix < cxstack_ix) - dounwind(cxix); + S_unwind_loop(aTHX_ "next"); /* clear off anything above the scope we're re-entering, but * save the rest until after a possible continue block */ - inner = PL_scopestack_ix; TOPBLOCK(cx); if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); @@ -2694,25 +2651,11 @@ PP(pp_next) PP(pp_redo) { dVAR; - I32 cxix; - register PERL_CONTEXT *cx; + const I32 cxix = S_unwind_loop(aTHX_ "redo"); + PERL_CONTEXT *cx; I32 oldsave; - OP* redo_op; + OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"redo\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); - } - if (cxix < cxstack_ix) - dounwind(cxix); - - redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; @@ -2729,7 +2672,7 @@ PP(pp_redo) } STATIC OP * -S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) +S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) { dVAR; OP **ops = opstack; @@ -2755,8 +2698,21 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { - const char *kid_label = CopLABEL(kCOP); - if (kid_label && strEQ(kid_label, label)) + STRLEN kid_label_len; + U32 kid_label_flags; + const char *kid_label = CopLABEL_len_flags(kCOP, + &kid_label_len, &kid_label_flags); + if (kid_label && ( + ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? + (flags & SVf_UTF8) + ? (bytes_cmp_utf8( + (const U8*)kid_label, kid_label_len, + (const U8*)label, len) == 0) + : (bytes_cmp_utf8( + (const U8*)label, len, + (const U8*)kid_label, kid_label_len) == 0) + : ( len == kid_label_len && ((kid_label == label) + || memEQ(kid_label, label, len))))) return kid; } } @@ -2772,7 +2728,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) else *ops++ = kid; } - if ((o = dofindlabel(kid, label, ops, oplimit))) + if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) return o; } } @@ -2785,10 +2741,12 @@ PP(pp_goto) dVAR; dSP; OP *retop = NULL; I32 ix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; const char *label = NULL; + STRLEN label_len = 0; + U32 label_flags = 0; const bool do_dump = (PL_op->op_type == OP_DUMP); static const char must_have_label[] = "goto must have label"; @@ -2798,7 +2756,7 @@ PP(pp_goto) /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; CV *cv = MUTABLE_CV(SvRV(sv)); SV** mark; I32 items = 0; @@ -2839,8 +2797,10 @@ PP(pp_goto) /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ if (CxTYPE(cx) == CXt_EVAL) { if (CxREALEVAL(cx)) + /* diag_listed_as: Can't goto subroutine from an eval-%s */ DIE(aTHX_ "Can't goto subroutine from an eval-string"); else + /* diag_listed_as: Can't goto subroutine from an eval-%s */ DIE(aTHX_ "Can't goto subroutine from an eval-block"); } else if (CxMULTICALL(cx)) @@ -2879,13 +2839,26 @@ PP(pp_goto) oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); + /* A destructor called during LEAVE_SCOPE could have undefined + * our precious cv. See bug #99850. */ + if (!CvROOT(cv) && !CvXSUB(cv)) { + const GV * const gv = CvGV(cv); + if (gv) { + SV * const tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, NULL); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"", + SVfARG(tmpstr)); + } + DIE(aTHX_ "Goto undefined subroutine"); + } + /* Now do some callish stuff. */ SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { OP* const retop = cx->blk_sub.retop; - SV **newsp __attribute__unused__; - I32 gimme __attribute__unused__; + SV **newsp PERL_UNUSED_DECL; + I32 gimme PERL_UNUSED_DECL; if (reified) { I32 index; for (index=0; indexblk_eval.old_eval_root; @@ -2974,21 +2947,20 @@ PP(pp_goto) } } else { - label = SvPV_nolen_const(sv); - if (!(do_dump || *label)) - DIE(aTHX_ must_have_label); + label = SvPV_const(sv, label_len); + label_flags = SvUTF8(sv); } } - else if (PL_op->op_flags & OPf_SPECIAL) { - if (! do_dump) - DIE(aTHX_ must_have_label); + else if (!(PL_op->op_flags & OPf_SPECIAL)) { + label = cPVOP->op_pv; + label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; + label_len = strlen(label); } - else - label = cPVOP->op_pv; + if (!(do_dump || label_len)) DIE(aTHX_ must_have_label); PERL_ASYNC_CHECK(); - if (label && *label) { + if (label_len) { OP *gotoprobe = NULL; bool leaving_eval = FALSE; bool in_block = FALSE; @@ -3039,12 +3011,13 @@ PP(pp_goto) DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); default: if (ix) - DIE(aTHX_ "panic: goto"); + DIE(aTHX_ "panic: goto, type=%u, ix=%ld", + CxTYPE(cx), (long) ix); gotoprobe = PL_main_root; break; } if (gotoprobe) { - retop = dofindlabel(gotoprobe, label, + retop = dofindlabel(gotoprobe, label, label_len, label_flags, enterops, enterops + GOTO_DEPTH); if (retop) break; @@ -3052,7 +3025,8 @@ PP(pp_goto) gotoprobe->op_sibling->op_type == OP_UNSTACK && gotoprobe->op_sibling->op_sibling) { retop = dofindlabel(gotoprobe->op_sibling->op_sibling, - label, enterops, enterops + GOTO_DEPTH); + label, label_len, label_flags, enterops, + enterops + GOTO_DEPTH); if (retop) break; } @@ -3060,7 +3034,9 @@ PP(pp_goto) PL_lastgotoprobe = gotoprobe; } if (!retop) - DIE(aTHX_ "Can't find label %s", label); + DIE(aTHX_ "Can't find label %"SVf, + SVfARG(newSVpvn_flags(label, label_len, + SVs_TEMP | label_flags))); /* if we're leaving an eval, check before we pop any frames that we're not going to punt, otherwise the error @@ -3232,149 +3208,13 @@ S_docatch(pTHX_ OP *o) JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; return NULL; } -/* James Bond: Do you expect me to talk? - Auric Goldfinger: No, Mr. Bond. I expect you to die. - - This code is an ugly hack, doesn't work with lexicals in subroutines that are - called more than once, and is only used by regcomp.c, for (?{}) blocks. - - Currently it is not used outside the core code. Best if it stays that way. - - Hence it's now deprecated, and will be removed. -*/ -OP * -Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) -/* sv Text to convert to OP tree. */ -/* startop op_free() this to undo. */ -/* code Short string id of the caller. */ -{ - PERL_ARGS_ASSERT_SV_COMPILE_2OP; - return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp); -} - -/* Don't use this. It will go away without warning once the regexp engine is - refactored not to use it. */ -OP * -Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code, - PAD **padp) -{ - dVAR; dSP; /* Make POPBLOCK work. */ - PERL_CONTEXT *cx; - SV **newsp; - I32 gimme = G_VOID; - I32 optype; - OP dummy; - char tbuf[TYPE_DIGITS(long) + 12 + 10]; - char *tmpbuf = tbuf; - char *safestr; - int runtime; - CV* runcv = NULL; /* initialise to avoid compiler warnings */ - STRLEN len; - bool need_catch; - - PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN; - - ENTER_with_name("eval"); - lex_start(sv, NULL, LEX_START_SAME_FILTER); - SAVETMPS; - /* switch to eval mode */ - - if (IN_PERL_COMPILETIME) { - SAVECOPSTASH_FREE(&PL_compiling); - CopSTASH_set(&PL_compiling, PL_curstash); - } - if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { - SV * const sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", - code, (unsigned long)++PL_evalseq, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - tmpbuf = SvPVX(sv); - len = SvCUR(sv); - } - else - len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code, - (unsigned long)++PL_evalseq); - SAVECOPFILE_FREE(&PL_compiling); - CopFILE_set(&PL_compiling, tmpbuf+2); - SAVECOPLINE(&PL_compiling); - CopLINE_set(&PL_compiling, 1); - /* XXX For Cs within BEGIN {} blocks, this ends up - deleting the eval's FILEGV from the stash before gv_check() runs - (i.e. before run-time proper). To work around the coredump that - ensues, we always turn GvMULTI_on for any globals that were - introduced within evals. See force_ident(). GSAR 96-10-12 */ - safestr = savepvn(tmpbuf, len); - SAVEDELETE(PL_defstash, safestr, len); - SAVEHINTS(); -#ifdef OP_IN_REGISTER - PL_opsave = op; -#else - SAVEVPTR(PL_op); -#endif - - /* we get here either during compilation, or via pp_regcomp at runtime */ - runtime = IN_PERL_RUNTIME; - if (runtime) - { - runcv = find_runcv(NULL); - - /* At run time, we have to fetch the hints from PL_curcop. */ - PL_hints = PL_curcop->cop_hints; - if (PL_hints & HINT_LOCALIZE_HH) { - /* SAVEHINTS created a new HV in PL_hintgv, which we - need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = - refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0); - hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints); - } - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - /* XXX Does this need to avoid copying a label? */ - PL_compiling.cop_hints_hash - = cophh_copy(PL_curcop->cop_hints_hash); - } - - PL_op = &dummy; - PL_op->op_type = OP_ENTEREVAL; - PL_op->op_flags = 0; /* Avoid uninit warning. */ - PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); - PUSHEVAL(cx, 0); - need_catch = CATCH_GET; - CATCH_SET(TRUE); - - if (runtime) - (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); - else - (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); - CATCH_SET(need_catch); - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - - (*startop)->op_type = OP_NULL; - (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; - /* XXX DAPM do this properly one year */ - *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); - LEAVE_with_name("eval"); - if (IN_PERL_COMPILETIME) - CopHINTS_set(&PL_compiling, PL_hints); -#ifdef OP_IN_REGISTER - op = PL_opsave; -#endif - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(optype); - - return PL_eval_start; -} - /* =for apidoc find_runcv @@ -3391,8 +3231,16 @@ than in the scope of the debugger itself). CV* Perl_find_runcv(pTHX_ U32 *db_seqp) { + return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp); +} + +/* If this becomes part of the API, it might need a better name. */ +CV * +Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) +{ dVAR; PERL_SI *si; + int level = 0; if (db_seqp) *db_seqp = PL_curcop->cop_seq; @@ -3400,20 +3248,33 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) I32 ix; for (ix = si->si_cxix; ix >= 0; ix--) { const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); + CV *cv = NULL; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - CV * const cv = cx->blk_sub.cv; + cv = cx->blk_sub.cv; /* skip DB:: code */ if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { *db_seqp = cx->blk_oldcop->cop_seq; continue; } - return cv; } else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) - return PL_compcv; + cv = cx->blk_eval.cv; + if (cv) { + switch (cond) { + case FIND_RUNCV_padid_eq: + if (!CvPADLIST(cv) + || CvPADLIST(cv)->xpadl_id != (U32)arg) continue; + return cv; + case FIND_RUNCV_level_eq: + if (level++ != arg) continue; + /* GERONIMO! */ + default: + return cv; + } + } } } - return PL_main_cv; + return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; } @@ -3439,29 +3300,37 @@ S_try_yyparse(pTHX_ int gramtype) default: JMPENV_POP; JMPENV_JUMP(ret); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } JMPENV_POP; return ret; } -/* Compile a require/do, an eval '', or a /(?{...})/. - * In the last case, startop is non-null, and contains the address of - * a pointer that should be set to the just-compiled code. +/* Compile a require/do or an eval ''. + * * outside is the lexically enclosing CV (if any) that invoked us. + * seq is the current COP scope value. + * hh is the saved hints hash, if any. + * * Returns a bool indicating whether the compile was successful; if so, - * PL_eval_start contains the first op of the compiled ocde; otherwise, - * pushes undef (also croaks if startop != NULL). + * PL_eval_start contains the first op of the compiled code; otherwise, + * pushes undef. + * + * This function is called from two places: pp_require and pp_entereval. + * These can be distinguished by whether PL_op is entereval. */ STATIC bool -S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) +S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) { dVAR; dSP; OP * const saveop = PL_op; - bool in_require = (saveop && saveop->op_type == OP_REQUIRE); + bool clear_hints = saveop->op_type != OP_ENTEREVAL; + COP * const oldcurcop = PL_curcop; + bool in_require = (saveop->op_type == OP_REQUIRE); int yystatus; + CV *evalcv; PL_in_eval = (in_require ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -3469,24 +3338,23 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); - SAVESPTR(PL_compcv); - PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); - CvEVAL_on(PL_compcv); + evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); + CvEVAL_on(evalcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - cxstack[cxstack_ix].blk_eval.cv = PL_compcv; + cxstack[cxstack_ix].blk_eval.cv = evalcv; cxstack[cxstack_ix].blk_gimme = gimme; - CvOUTSIDE_SEQ(PL_compcv) = seq; - CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); + CvOUTSIDE_SEQ(evalcv) = seq; + CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); /* set up a scratch pad */ - CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); + CvPADLIST(evalcv) = pad_new(padnew_SAVE); PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ if (!PL_madskills) - SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ + SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ @@ -3507,15 +3375,59 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_madskills = 0; #endif + ENTER_with_name("evalcomp"); + SAVESPTR(PL_compcv); + PL_compcv = evalcv; + /* try to compile it */ PL_eval_root = NULL; PL_curcop = &PL_compiling; - if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) + if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else CLEAR_ERRSV(); + SAVEHINTS(); + if (clear_hints) { + PL_hints = 0; + hv_clear(GvHV(PL_hintgv)); + } + else { + PL_hints = saveop->op_private & OPpEVAL_COPHH + ? oldcurcop->cop_hints : saveop->op_targ; + if (hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = hh; + } + } + SAVECOMPILEWARNINGS(); + if (clear_hints) { + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = pWARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = pWARN_NONE ; + else + PL_compiling.cop_warnings = pWARN_STD ; + } + else { + PL_compiling.cop_warnings = + DUP_WARNINGS(oldcurcop->cop_warnings); + cophh_free(CopHINTHASH_get(&PL_compiling)); + if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { + /* The label, if present, is the first entry on the chain. So rather + than writing a blank label in front of it (which involves an + allocation), just use the next entry in the chain. */ + PL_compiling.cop_hints_hash + = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); + /* Check the assumption that this removed the label. */ + assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); + } + else + PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); + } + CALL_BLOCK_HOOKS(bhk_eval, saveop); /* note that yyparse() may raise an exception, e.g. C, @@ -3539,18 +3451,17 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_op = saveop; if (yystatus != 3) { if (PL_eval_root) { + cv_forget_slab(evalcv); op_free(PL_eval_root); PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ - if (!startop) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - namesv = cx->blk_eval.old_namesv; - } - } - if (yystatus != 3) + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; + /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ + } if (in_require) { if (!cx) { @@ -3569,35 +3480,26 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) ? ERRSV : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } - else if (startop) { - if (yystatus != 3) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - } - Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp", - SVfARG(ERRSV - ? ERRSV - : newSVpvs_flags("Unknown error\n", SVs_TEMP))); - } else { if (!*(SvPVx_nolen_const(ERRSV))) { sv_setpvs(ERRSV, "Compilation error"); } } - PUSHs(&PL_sv_undef); + if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); PUTBACK; return FALSE; } + else + LEAVE_with_name("evalcomp"); + CopLINE_set(&PL_compiling, 0); - if (startop) { - *startop = PL_eval_root; - } else - SAVEFREEOP(PL_eval_root); + SAVEFREEOP(PL_eval_root); + cv_forget_slab(evalcv); DEBUG_x(dump_eval()); /* Register with debugger: */ - if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { + if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; @@ -3616,7 +3518,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* compiled okay, so do it */ - CvDEPTH(PL_compcv) = 1; + CvDEPTH(evalcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ @@ -3673,7 +3575,7 @@ S_doopen_pm(pTHX_ SV *name) PP(pp_require) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *sv; const char *name; STRLEN len; @@ -3681,6 +3583,9 @@ PP(pp_require) STRLEN unixlen; #ifdef VMS int vms_unixname = 0; + char *unixnamebuf; + char *unixdir; + char *unixdirbuf; #endif const char *tryname = NULL; SV *namesv = NULL; @@ -3693,6 +3598,7 @@ PP(pp_require) SV *hook_sv = NULL; SV *encoding; OP *op; + int saved_errno; sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { @@ -3765,7 +3671,9 @@ PP(pp_require) * To prevent this, the key must be stored in UNIX format if the VMS * name can be translated to UNIX. */ - if ((unixname = tounixspec(name, NULL)) != NULL) { + + if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) + && (unixname = tounixspec(name, unixnamebuf)) != NULL) { unixlen = strlen(unixname); vms_unixname = 1; } @@ -3790,6 +3698,8 @@ PP(pp_require) } } + LOADING_FILE_PROBE(unixname); + /* prepare to compile file */ if (path_is_absolute(name)) { @@ -3797,7 +3707,7 @@ PP(pp_require) tryname = name; tryrsfp = doopen_pm(sv); } - if (!tryrsfp) { + if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) { AV * const ar = GvAVn(PL_incgv); I32 i; #ifdef VMS @@ -3940,8 +3850,8 @@ PP(pp_require) } #ifdef VMS - char *unixdir; - if ((unixdir = tounixpath(dir, NULL)) == NULL) + if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL) + || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL)) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); @@ -3989,20 +3899,26 @@ PP(pp_require) } break; } - else if (errno == EMFILE) - /* no point in trying other paths if out of handles */ - break; + else if (errno == EMFILE || errno == EACCES) { + /* no point in trying other paths if out of handles; + * on the other hand, if we couldn't open one of the + * files, then going on with the search could lead to + * unexpected results; see perl #113422 + */ + break; + } } } } } } + saved_errno = errno; /* sv_2mortal can realloc things */ sv_2mortal(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { - if(errno == EMFILE) { + if(saved_errno == EMFILE || saved_errno == EACCES) { /* diag_listed_as: Can't locate %s */ - DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno)); + DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno)); } else { if (namesv) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); @@ -4017,9 +3933,9 @@ PP(pp_require) DIE(aTHX_ "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")", name, - (memEQ(name + len - 2, ".h", 3) + (len >= 2 && memEQ(name + len - 2, ".h", 3) ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""), - (memEQ(name + len - 3, ".ph", 4) + (len >= 3 && memEQ(name + len - 3, ".ph", 4) ? " (did you run h2ph?)" : ""), inc ); @@ -4028,6 +3944,7 @@ PP(pp_require) DIE(aTHX_ "Can't locate %s", name); } + CLEAR_ERRSV(); RETPUSHUNDEF; } else @@ -4052,18 +3969,6 @@ PP(pp_require) CopFILE_set(&PL_compiling, tryname); lex_start(NULL, tryrsfp, 0); - SAVEHINTS(); - PL_hints = 0; - hv_clear(GvHV(PL_hintgv)); - - SAVECOMPILEWARNINGS(); - if (PL_dowarn & G_WARN_ALL_ON) - PL_compiling.cop_warnings = pWARN_ALL ; - else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = pWARN_NONE ; - else - PL_compiling.cop_warnings = pWARN_STD ; - if (filter_sub || filter_cache) { /* We can use the SvPV of the filter PVIO itself as our cache, rather than hanging another SV from it. In turn, filter_add() optionally @@ -4089,7 +3994,7 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = NULL; - if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) + if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; @@ -4097,6 +4002,8 @@ PP(pp_require) /* Restore encoding. */ PL_encoding = encoding; + LOADED_FILE_PROBE(unixname); + return op; } @@ -4116,7 +4023,7 @@ PP(pp_hintseval) PP(pp_entereval) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *sv; const I32 gimme = GIMME_V; const U32 was = PL_breakable_sub_gen; @@ -4125,12 +4032,20 @@ PP(pp_entereval) char *tmpbuf = tbuf; STRLEN len; CV* runcv; - U32 seq; + U32 seq, lex_flags = 0; HV *saved_hh = NULL; + const bool bytes = PL_op->op_private & OPpEVAL_BYTES; if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } + else if (PL_hints & HINT_LOCALIZE_HH || ( + PL_op->op_private & OPpEVAL_COPHH + && PL_curcop->cop_hints & HINT_LOCALIZE_HH + )) { + saved_hh = cop_hints_2hv(PL_curcop, 0); + hv_magic(saved_hh, NULL, PERL_MAGIC_hints); + } sv = POPs; if (!SvPOK(sv)) { /* make sure we've got a plain PV (no overload etc) before testing @@ -4140,13 +4055,29 @@ PP(pp_entereval) const char * const p = SvPV_const(sv, len); sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); + lex_flags |= LEX_START_COPIED; + + if (bytes && SvUTF8(sv)) + SvPVbyte_force(sv, len); + } + else if (bytes && SvUTF8(sv)) { + /* Don't modify someone else's scalar */ + STRLEN len; + sv = newSVsv(sv); + (void)sv_2mortal(sv); + SvPVbyte_force(sv,len); + lex_flags |= LEX_START_COPIED; } TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER_with_name("eval"); - lex_start(sv, NULL, LEX_START_SAME_FILTER); + lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE + ? LEX_IGNORE_UTF8_HINTS + : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER + ) + ); SAVETMPS; /* switch to eval mode */ @@ -4165,32 +4096,6 @@ PP(pp_entereval) CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); - /* XXX For Cs within BEGIN {} blocks, this ends up - deleting the eval's FILEGV from the stash before gv_check() runs - (i.e. before run-time proper). To work around the coredump that - ensues, we always turn GvMULTI_on for any globals that were - introduced within evals. See force_ident(). GSAR 96-10-12 */ - SAVEHINTS(); - PL_hints = PL_op->op_targ; - if (saved_hh) { - /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = saved_hh; - } - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - if (Perl_cop_fetch_label(aTHX_ PL_curcop, NULL, NULL)) { - /* The label, if present, is the first entry on the chain. So rather - than writing a blank label in front of it (which involves an - allocation), just use the next entry in the chain. */ - PL_compiling.cop_hints_hash - = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next); - /* Check the assumption that this removed the label. */ - assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); - } - else - PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash); /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the @@ -4207,6 +4112,11 @@ PP(pp_entereval) if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); else { + /* XXX For Cs within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ char *const safestr = savepvn(tmpbuf, len); SAVEDELETE(PL_defstash, safestr, len); saved_delete = TRUE; @@ -4214,7 +4124,7 @@ PP(pp_entereval) PUTBACK; - if (doeval(gimme, NULL, runcv, seq)) { + if (doeval(gimme, runcv, seq, saved_hh)) { if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? (PERLDB_LINE || PERLDB_SAVESRC) : PERLDB_SAVESRC_NOSUBS) { @@ -4244,17 +4154,19 @@ PP(pp_leaveeval) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; OP *retop; const U8 save_flags = PL_op -> op_flags; I32 optype; SV *namesv; + CV *evalcv; PERL_ASYNC_CHECK(); POPBLOCK(cx,newpm); POPEVAL(cx); namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; + evalcv = cx->blk_eval.cv; TAINT_NOT; SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, @@ -4262,9 +4174,9 @@ PP(pp_leaveeval) PL_curpm = newpm; /* Don't pop $1 et al till now */ #ifdef DEBUGGING - assert(CvDEPTH(PL_compcv) == 1); + assert(CvDEPTH(evalcv) == 1); #endif - CvDEPTH(PL_compcv) = 0; + CvDEPTH(evalcv) = 0; if (optype == OP_REQUIRE && !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) @@ -4296,7 +4208,7 @@ Perl_delete_eval_scope(pTHX) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); @@ -4347,7 +4259,7 @@ PP(pp_leavetry) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 optype; PERL_ASYNC_CHECK(); @@ -4367,14 +4279,21 @@ PP(pp_leavetry) PP(pp_entergiven) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; ENTER_with_name("given"); SAVETMPS; - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs); + if (PL_op->op_targ) { + SAVEPADSVANDMORTALIZE(PL_op->op_targ); + SvREFCNT_dec(PAD_SVl(PL_op->op_targ)); + PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs); + } + else { + SAVE_DEFSV; + DEFSV_set(POPs); + } PUSHBLOCK(cx, CXt_GIVEN, SP); PUSHGIVEN(cx); @@ -4385,7 +4304,7 @@ PP(pp_entergiven) PP(pp_leavegiven) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -4486,7 +4405,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); - tmpsv = amagic_call(d, e, smart_amg, 0); + tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); if (tmpsv) { SPAGAIN; (void)POPs; @@ -4933,7 +4852,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) PP(pp_enterwhen) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; /* This is essentially an optimization: if the match @@ -4958,14 +4877,16 @@ PP(pp_leavewhen) { dVAR; dSP; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; cxix = dopoptogiven(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't use when() outside a topicalizer"); + /* diag_listed_as: Can't "when" outside a topicalizer */ + DIE(aTHX_ "Can't \"%s\" outside a topicalizer", + PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_WHEN); @@ -5000,7 +4921,7 @@ PP(pp_continue) { dVAR; dSP; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -5028,7 +4949,7 @@ PP(pp_break) { dVAR; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; cxix = dopoptogiven(cxstack_ix); if (cxix < 0) @@ -5051,17 +4972,17 @@ static MAGIC * S_doparseform(pTHX_ SV *sv) { STRLEN len; - register char *s = SvPV(sv, len); - register char *send; - register char *base = NULL; /* start of current field */ - register I32 skipspaces = 0; /* number of contiguous spaces seen */ + char *s = SvPV(sv, len); + char *send; + char *base = NULL; /* start of current field */ + I32 skipspaces = 0; /* number of contiguous spaces seen */ bool noblank = FALSE; /* ~ or ~~ seen on this line */ bool repeat = FALSE; /* ~~ seen on this line */ bool postspace = FALSE; /* a text field may need right padding */ U32 *fops; - register U32 *fpc; + U32 *fpc; U32 *linepc = NULL; /* position of last FF_LINEMARK */ - register I32 arg; + I32 arg; bool ischop; /* it's a ^ rather than a @ */ bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */ int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ @@ -5341,6 +5262,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) char *prune_from = NULL; bool read_from_cache = FALSE; STRLEN umaxlen; + SV *err = NULL; PERL_ARGS_ASSERT_RUN_USER_FILTER; @@ -5408,21 +5330,18 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) int count; ENTER_with_name("call_filter_sub"); - save_gp(PL_defgv, 0); - GvINTRO_off(PL_defgv); - SAVEGENERICSV(GvSV(PL_defgv)); + SAVE_DEFSV; SAVETMPS; EXTEND(SP, 2); DEFSV_set(upstream); - SvREFCNT_inc_simple_void_NN(upstream); PUSHMARK(SP); mPUSHi(0); if (filter_state) { PUSHs(filter_state); } PUTBACK; - count = call_sv(filter_sub, G_SCALAR); + count = call_sv(filter_sub, G_SCALAR|G_EVAL); SPAGAIN; if (count > 0) { @@ -5430,6 +5349,9 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (SvOK(out)) { status = SvIV(out); } + else if (SvTRUE(ERRSV)) { + err = newSVsv(ERRSV); + } } PUTBACK; @@ -5437,7 +5359,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) LEAVE_with_name("call_filter_sub"); } - if(SvOK(upstream)) { + if(!err && SvOK(upstream)) { got_p = SvPV(upstream, got_len); if (umaxlen) { if (got_len > umaxlen) { @@ -5451,7 +5373,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } } } - if (prune_from) { + if (!err && prune_from) { /* Oh. Too long. Stuff some in our cache. */ STRLEN cached_len = got_p + got_len - prune_from; SV *const cache = datasv; @@ -5480,7 +5402,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) have touched the SV upstream, so it may be undefined. If we naively concatenate it then we get a warning about use of uninitialised value. */ - if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) { + if (!err && upstream != buf_sv && + (SvOK(upstream) || SvGMAGICAL(upstream))) { sv_catsv(buf_sv, upstream); } @@ -5496,6 +5419,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } filter_del(S_run_user_filter); } + + if (err) + croak_sv(err); + if (status == 0 && read_from_cache) { /* If we read some data from the cache (and by getting here it implies that we emptied the cache) then we aren't yet at EOF, and mustn't @@ -5535,8 +5462,8 @@ S_path_is_absolute(const char *name) * 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: */