X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d4b87e753f3c5c8123aeebb4ae822cef9f2eed3c..50a9fad1a8ce99fe48223ca407d09d01f8c4bef6:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index ce60ea0..7d041bd 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -96,6 +96,7 @@ PP(pp_regcomp) #define tryAMAGICregexp(rx) \ STMT_START { \ + SvGETMAGIC(rx); \ if (SvROK(rx) && SvAMAGIC(rx)) { \ SV *sv = AMG_CALLun(rx, regexp); \ if (sv) { \ @@ -149,6 +150,27 @@ PP(pp_regcomp) 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 = reg_temp_copy(NULL, re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); @@ -243,6 +265,9 @@ PP(pp_substcont) register REGEXP * const rx = cx->sb_rx; SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); + + PERL_ASYNC_CHECK(); + if(old != rx) { if(old) ReREFCNT_dec(old); @@ -257,9 +282,11 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE(aTHX_ "Substitution loop"); + SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ + if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) cx->sb_rxtainted |= 2; - sv_catsv(dstr, POPs); + sv_catsv_nomg(dstr, POPs); /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ s -= RX_GOFS(rx); @@ -298,7 +325,10 @@ PP(pp_substcont) SvPV_set(dstr, NULL); TAINT_IF(cx->sb_rxtainted & 1); - mPUSHi(saviters - 1); + if (pm->op_pmflags & PMf_NONDESTRUCT) + PUSHs(targ); + else + mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); @@ -996,14 +1026,14 @@ PP(pp_grepstart) PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; pp_pushmark(); /* push dst */ pp_pushmark(); /* push src */ - ENTER; /* enter outer scope */ + ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; if (PL_op->op_private & OPpGREP_LEX) SAVESPTR(PAD_SVl(PL_op->op_targ)); else SAVE_DEFSV; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; @@ -1084,13 +1114,13 @@ PP(pp_mapwhile) } } } - LEAVE; /* exit inner scope */ + LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { (void)POPMARK; /* pop top */ - LEAVE; /* exit outer scope */ + LEAVE_with_name("grep"); /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ @@ -1113,7 +1143,7 @@ PP(pp_mapwhile) else { SV *src; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); /* set $_ to the new source item */ @@ -1313,13 +1343,16 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: - if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { - DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", - (long)i, CxLABEL(cx))); + { + const char *cx_label = CxLABEL(cx); + if (!cx_label || strNE(label, cx_label) ) { + DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", + (long)i, cx_label)); continue; } - DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); + DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label)); return i; + } } } return i; @@ -1386,7 +1419,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: - DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); return i; } } @@ -1404,7 +1437,7 @@ S_dopoptoeval(pTHX_ I32 startingblock) default: continue; case CXt_EVAL: - DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i)); return i; } } @@ -1433,7 +1466,7 @@ S_dopoptoloop(pTHX_ I32 startingblock) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: - DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); return i; } } @@ -1451,7 +1484,7 @@ S_dopoptogiven(pTHX_ I32 startingblock) default: continue; case CXt_GIVEN: - DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i)); return i; case CXt_LOOP_PLAIN: assert(!CxFOREACHDEF(cx)); @@ -1460,7 +1493,7 @@ S_dopoptogiven(pTHX_ I32 startingblock) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: if (CxFOREACHDEF(cx)) { - DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i)); return i; } } @@ -1479,7 +1512,7 @@ S_dopoptowhen(pTHX_ I32 startingblock) default: continue; case CXt_WHEN: - DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i)); return i; } } @@ -1495,8 +1528,7 @@ Perl_dounwind(pTHX_ I32 cxix) while (cxstack_ix > cxix) { SV *sv; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", - (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); + DEBUG_CX("UNWIND"); \ /* Note: we don't need to restore the base context info till the end. */ switch (CxTYPE(cx)) { case CXt_SUBST: @@ -1543,49 +1575,18 @@ Perl_qerror(pTHX_ SV *err) ++PL_parser->error_count; } -OP * -Perl_die_where(pTHX_ SV *msv) +void +Perl_die_unwind(pTHX_ SV *msv) { dVAR; + SV *exceptsv = sv_mortalcopy(msv); + U8 in_eval = PL_in_eval; + PERL_ARGS_ASSERT_DIE_UNWIND; - if (PL_in_eval) { + if (in_eval) { I32 cxix; I32 gimme; - if (msv) { - if (PL_in_eval & EVAL_KEEPERR) { - static const char prefix[] = "\t(in cleanup) "; - SV * const err = ERRSV; - const char *e = NULL; - if (!SvPOK(err)) - sv_setpvs(err,""); - else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) { - STRLEN len; - STRLEN msglen; - const char* message = SvPV_const(msv, msglen); - e = SvPV_const(err, len); - e += len - msglen; - if (*e != *message || strNE(e,message)) - e = NULL; - } - if (!e) { - STRLEN start; - SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv)); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catsv(err, msv); - start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1; - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", - SvPVX_const(err)+start); - } - } - else { - STRLEN msglen; - const char* message = SvPV_const(msv, msglen); - sv_setpvn(ERRSV, message, msglen); - SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8; - } - } - while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { @@ -1595,6 +1596,7 @@ Perl_die_where(pTHX_ SV *msv) if (cxix >= 0) { I32 optype; + SV *namesv; register PERL_CONTEXT *cx; SV **newsp; @@ -1604,12 +1606,13 @@ Perl_die_where(pTHX_ SV *msv) POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { STRLEN msglen; - const char* message = SvPVx_const( msv ? msv : ERRSV, msglen); + const char* message = SvPVx_const(exceptsv, msglen); PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); } POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; if (gimme == G_SCALAR) *++newsp = &PL_sv_undef; @@ -1624,22 +1627,35 @@ Perl_die_where(pTHX_ SV *msv) PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { - const char* const msg = SvPVx_nolen_const(ERRSV); - SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), + const char* const msg = SvPVx_nolen_const(exceptsv); + (void)hv_store(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), &PL_sv_undef, 0); - DIE(aTHX_ "%sCompilation failed in require", - *msg ? msg : "Unknown error\n"); + /* note that unlike pp_entereval, pp_require isn't + * supposed to trap errors. So now that we've popped the + * EVAL that pp_require pushed, and processed the error + * message, rethrow the error */ + Perl_croak(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); + } + if (in_eval & EVAL_KEEPERR) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s", + SvPV_nolen_const(exceptsv)); + } + else { + sv_setsv(ERRSV, exceptsv); } assert(CxTYPE(cx) == CXt_EVAL); - return cx->blk_eval.retop; + PL_restartjmpenv = cx->blk_eval.cur_top_env; + PL_restartop = cx->blk_eval.retop; + JMPENV_JUMP(3); + /* NOTREACHED */ } } - write_to_stderr( msv ? msv : ERRSV ); + write_to_stderr(exceptsv); my_failure_exit(); /* NOTREACHED */ - return 0; } PP(pp_xor) @@ -1840,6 +1856,8 @@ PP(pp_dbstate) PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; + PERL_ASYNC_CHECK(); + if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { @@ -1900,7 +1918,7 @@ PP(pp_enteriter) PAD *iterdata; #endif - ENTER; + ENTER_with_name("loop1"); SAVETMPS; if (PL_op->op_targ) { @@ -1929,7 +1947,7 @@ PP(pp_enteriter) if (PL_op->op_private & OPpITER_DEF) cxtype |= CXp_FOR_DEF; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS @@ -2026,9 +2044,9 @@ PP(pp_enterloop) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("loop1"); SAVETMPS; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); PUSHLOOP_PLAIN(cx, SP); @@ -2071,8 +2089,8 @@ PP(pp_leaveloop) POPLOOP(cx); /* Stack values are safe: release loop vars ... */ PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; - LEAVE; + LEAVE_with_name("loop2"); + LEAVE_with_name("loop1"); return NORMAL; } @@ -2087,8 +2105,9 @@ PP(pp_return) SV **newsp; PMOP *newpm; I32 optype = 0; + SV *namesv; SV *sv; - OP *retop; + OP *retop = NULL; const I32 cxix = dopoptosub(cxstack_ix); @@ -2129,6 +2148,7 @@ PP(pp_return) if (!(PL_in_eval & EVAL_KEEPERR)) clear_errsv = TRUE; POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; if (CxTRYBLOCK(cx)) break; @@ -2137,9 +2157,10 @@ PP(pp_return) (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { /* Unassume the success we assumed earlier. */ - SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); + (void)hv_delete(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), + G_DISCARD); + DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); } break; case CXt_FORMAT: @@ -2210,7 +2231,7 @@ PP(pp_last) I32 pop2 = 0; I32 gimme; I32 optype; - OP *nextop; + OP *nextop = NULL; SV **newsp; PMOP *newpm; SV **mark; @@ -2392,9 +2413,11 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) OP *kid; /* 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) && - CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label)) - return kid; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + const char *kid_label = CopLABEL(kCOP); + if (kid_label && strEQ(kid_label, label)) + return kid; + } } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) @@ -2620,6 +2643,8 @@ PP(pp_goto) else label = cPVOP->op_pv; + PERL_ASYNC_CHECK(); + if (label && *label) { OP *gotoprobe = NULL; bool leaving_eval = FALSE; @@ -2697,6 +2722,12 @@ PP(pp_goto) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); } + if (*enterops && enterops[1]) { + I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + if (enterops[i]) + deprecate("\"goto\" to jump into a construct"); + } + /* pop unwanted frames */ if (ix < cxstack_ix) { @@ -2798,6 +2829,20 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } +/* +=for apidoc docatch + +Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. + +0 is used as continue inside eval, + +3 is used for a die caught by an inner eval - continue inner loop + +See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must +establish a local jmpenv to handle exception traps. + +=cut +*/ STATIC OP * S_docatch(pTHX_ OP *o) { @@ -2822,17 +2867,8 @@ S_docatch(pTHX_ OP *o) break; case 3: /* die caught by an inner eval - continue inner loop */ - - /* NB XXX we rely on the old popped CxEVAL still being at the top - * of the stack; the way die_where() currently works, this - * assumption is valid. In theory The cur_top_env value should be - * returned in another global, the way retop (aka PL_restartop) - * is. */ - assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL); - - if (PL_restartop - && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env) - { + if (PL_restartop && PL_restartjmpenv == PL_top_env) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -2849,13 +2885,20 @@ S_docatch(pTHX_ OP *o) 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. +*/ 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. */ { - /* FIXME - how much of this code is common with pp_entereval? */ dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; @@ -2871,7 +2914,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PERL_ARGS_ASSERT_SV_COMPILE_2OP; - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2932,7 +2975,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) lex_end(); /* XXX DAPM do this properly one year */ *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); - LEAVE; + LEAVE_with_name("eval"); if (IN_PERL_COMPILETIME) CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER @@ -2986,6 +3029,35 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) } +/* Run yyparse() in a setjmp wrapper. Returns: + * 0: yyparse() successful + * 1: yyparse() failed + * 3: yyparse() died + */ +STATIC int +S_try_yyparse(pTHX) +{ + int ret; + dJMPENV; + + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + JMPENV_PUSH(ret); + switch (ret) { + case 0: + ret = yyparse() ? 1 : 0; + break; + case 3: + break; + default: + JMPENV_POP; + JMPENV_JUMP(ret); + /* 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. @@ -3000,8 +3072,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; OP * const saveop = PL_op; + bool in_require = (saveop && saveop->op_type == OP_REQUIRE); + int yystatus; - PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) + PL_in_eval = (in_require ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) : EVAL_INEVAL); @@ -3053,36 +3127,61 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_in_eval |= EVAL_KEEPERR; else CLEAR_ERRSV(); - if (yyparse() || PL_parser->error_count || !PL_eval_root) { + + /* note that yyparse() may raise an exception, e.g. C, + * so honour CATCH_GET and trap it here if necessary */ + + yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse(); + + if (yystatus || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - I32 optype = 0; /* Might be reset by POPEVAL. */ + PERL_CONTEXT *cx = NULL; + I32 optype; /* Used by POPEVAL. */ + SV *namesv = NULL; const char *msg; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(optype); + + /* note that if yystatus == 3, then the EVAL CX block has already + * been popped, and various vars restored */ PL_op = saveop; - if (PL_eval_root) { - 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); + if (yystatus != 3) { + if (PL_eval_root) { + 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; + } } lex_end(); - LEAVE; /* pp_entereval knows about this LEAVE. */ + if (yystatus != 3) + LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); - if (optype == OP_REQUIRE) { - const SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), - &PL_sv_undef, 0); + if (in_require) { + if (!cx) { + /* If cx is still NULL, it means that we didn't go in the + * POPEVAL branch. */ + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_EVAL); + namesv = cx->blk_eval.old_namesv; + } + (void)hv_store(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), + &PL_sv_undef, 0); Perl_croak(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } else if (startop) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); + if (yystatus != 3) { + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + } Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } @@ -3091,7 +3190,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) sv_setpvs(ERRSV, "Compilation error"); } } - PERL_UNUSED_VAR(newsp); PUSHs(&PL_sv_undef); PUTBACK; return FALSE; @@ -3103,14 +3201,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVEFREEOP(PL_eval_root); /* Set the context for this new optree. - * If the last op is an OP_REQUIRE, force scalar context. - * Otherwise, propagate the context from the eval(). */ - if (PL_eval_root->op_type == OP_LEAVEEVAL - && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ - && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type - == OP_REQUIRE) - scalar(PL_eval_root); - else if ((gimme & G_WANT) == G_VOID) + * Propagate the context from the eval(). */ + if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); @@ -3249,36 +3341,37 @@ PP(pp_require) SVfARG(vnormal(PL_patchlevel))); } else { /* probably 'use 5.10' or 'use 5.8' */ - SV * hintsv = newSV(0); + SV *hintsv; I32 second = 0; if (av_len(lav)>=1) second = SvIV(*av_fetch(lav,1,0)); second /= second >= 600 ? 100 : 10; - hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d", - (int)first, (int)second,0); + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", + (int)first, (int)second); upg_version(hintsv, TRUE); DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" "--this is only %"SVf", stopped", SVfARG(vnormal(req)), - SVfARG(vnormal(hintsv)), + SVfARG(vnormal(sv_2mortal(hintsv))), SVfARG(vnormal(PL_patchlevel))); } } } - /* We do this only with use, not require. */ + /* We do this only with "use", not "require" or "no". */ if (PL_compcv && + !(cUNOP->op_first->op_private & OPpCONST_NOVER) && /* If we request a version >= 5.9.5, load feature.pm with the * feature bundle that corresponds to the required version. */ vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; - ENTER; + ENTER_with_name("load_feature"); Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE; + LEAVE_with_name("load_feature"); } /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (PL_compcv && @@ -3361,7 +3454,7 @@ PP(pp_require) tryname = SvPVX_const(namesv); tryrsfp = NULL; - ENTER; + ENTER_with_name("call_INC"); SAVETMPS; EXTEND(SP, 2); @@ -3375,11 +3468,6 @@ PP(pp_require) count = call_sv(loader, G_ARRAY); SPAGAIN; - /* Adjust file name if the hook has set an %INC entry */ - svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); - if (svp) - tryname = SvPV_nolen_const(*svp); - if (count > 0) { int i = 0; SV *arg; @@ -3439,7 +3527,13 @@ PP(pp_require) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_INC"); + + /* Adjust file name if the hook has set an %INC entry. + This needs to happen after the FREETMPS above. */ + svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + if (svp) + tryname = SvPV_nolen_const(*svp); if (tryrsfp) { hook_sv = dirsv; @@ -3533,39 +3627,39 @@ PP(pp_require) } } } - SAVECOPFILE_FREE(&PL_compiling); - CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); + if (tryrsfp) { + SAVECOPFILE_FREE(&PL_compiling); + CopFILE_set(&PL_compiling, tryname); + } SvREFCNT_dec(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { - const char *msgstr = name; if(errno == EMFILE) { - SV * const msg - = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr, - Strerror(errno))); - msgstr = SvPV_nolen_const(msg); + /* diag_listed_as: Can't locate %s */ + DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno)); } else { if (namesv) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); I32 i; - SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "%s in @INC%s%s (@INC contains:", - msgstr, - (instr(msgstr, ".h ") - ? " (change .h to .ph maybe?)" : ""), - (instr(msgstr, ".ph ") - ? " (did you run h2ph?)" : "") - )); - + SV *const inc = newSVpvs_flags("", SVs_TEMP); for (i = 0; i <= AvFILL(ar); i++) { - sv_catpvs(msg, " "); - sv_catsv(msg, *av_fetch(ar, i, TRUE)); + sv_catpvs(inc, " "); + sv_catsv(inc, *av_fetch(ar, i, TRUE)); } - sv_catpvs(msg, ")"); - msgstr = SvPV_nolen_const(msg); - } + + /* diag_listed_as: Can't locate %s */ + DIE(aTHX_ + "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")", + name, + (memEQ(name + len - 2, ".h", 3) + ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""), + (memEQ(name + len - 3, ".ph", 4) + ? " (did you run h2ph?)" : ""), + inc + ); + } } - DIE(aTHX_ "Can't locate %s", msgstr); + DIE(aTHX_ "Can't locate %s", name); } RETPUSHUNDEF; @@ -3586,7 +3680,7 @@ PP(pp_require) unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } - ENTER; + ENTER_with_name("eval"); SAVETMPS; lex_start(NULL, tryrsfp, TRUE); @@ -3673,7 +3767,7 @@ PP(pp_entereval) TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; @@ -3710,7 +3804,18 @@ PP(pp_entereval) if (PL_compiling.cop_hints_hash) { Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); } - PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; + if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, 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 + = PL_curcop->cop_hints_hash->refcounted_he_next; + /* Check the assumption that this removed the label. */ + assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL, + NULL) == NULL); + } + else + PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; if (PL_compiling.cop_hints_hash) { HINTS_REFCNT_LOCK; PL_compiling.cop_hints_hash->refcounted_he_refcnt++; @@ -3768,9 +3873,11 @@ PP(pp_leaveeval) OP *retop; const U8 save_flags = PL_op -> op_flags; I32 optype; + SV *namesv; POPBLOCK(cx,newpm); POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; TAINT_NOT; @@ -3811,13 +3918,15 @@ PP(pp_leaveeval) !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ - SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); - /* die_where() did LEAVE, or we won't be here */ + (void)hv_delete(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), + G_DISCARD); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", + SVfARG(namesv)); + /* die_unwind() did LEAVE, or we won't be here */ } else { - LEAVE; + LEAVE_with_name("eval"); if (!(save_flags & OPf_SPECIAL)) { CLEAR_ERRSV(); } @@ -3840,7 +3949,7 @@ Perl_delete_eval_scope(pTHX) POPBLOCK(cx,newpm); POPEVAL(cx); PL_curpm = newpm; - LEAVE; + LEAVE_with_name("eval_scope"); PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); PERL_UNUSED_VAR(optype); @@ -3854,7 +3963,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("eval_scope"); SAVETMPS; PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); @@ -3922,7 +4031,7 @@ PP(pp_leavetry) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; + LEAVE_with_name("eval_scope"); CLEAR_ERRSV(); RETURN; } @@ -3933,7 +4042,7 @@ PP(pp_entergiven) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("given"); SAVETMPS; sv_setsv(PAD_SV(PL_op->op_targ), POPs); @@ -3956,14 +4065,38 @@ PP(pp_leavegiven) POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_GIVEN); - SP = newsp; - PUTBACK; - - PL_curpm = newpm; /* pop $1 et al */ - - LEAVE; + TAINT_NOT; + if (gimme == G_VOID) + SP = newsp; + else if (gimme == G_SCALAR) { + register SV **mark; + MARK = newsp + 1; + if (MARK <= SP) { + if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); + } + else { + MEXTEND(mark,0); + *MARK = &PL_sv_undef; + } + SP = MARK; + } + else { + /* in case LEAVE wipes old return values */ + register SV **mark; + for (mark = newsp + 1; mark <= SP; mark++) { + if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { + *mark = sv_mortalcopy(*mark); + TAINT_NOT; /* Each item is independent */ + } + } + } + PL_curpm = newpm; /* Don't pop $1 et al till now */ - return NORMAL; + LEAVE_with_name("given"); + RETURN; } /* Helper routines used by pp_smartmatch */ @@ -3978,7 +4111,7 @@ S_make_matcher(pTHX_ REGEXP *re) PM_SETRE(matcher, ReREFCNT_inc(re)); SAVEFREEOP((OP *) matcher); - ENTER; SAVETMPS; + ENTER_with_name("matcher"); SAVETMPS; SAVEOP(); return matcher; } @@ -4008,7 +4141,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher) PERL_UNUSED_ARG(matcher); FREETMPS; - LEAVE; + LEAVE_with_name("matcher"); } /* Do a smart match */ @@ -4031,6 +4164,19 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV *e = TOPs; /* e is for 'expression' */ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ + /* Take care only to invoke mg_get() once for each argument. + * Currently we do this by copying the SV if it's magical. */ + if (d) { + if (SvGMAGICAL(d)) + d = sv_mortalcopy(d); + } + else + d = &PL_sv_undef; + + assert(e); + if (SvGMAGICAL(e)) + e = sv_mortalcopy(e); + /* First of all, handle overload magic of the rightmost argument */ if (SvAMAGIC(e)) { SV * tmpsv; @@ -4049,18 +4195,6 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SP -= 2; /* Pop the values */ - /* Take care only to invoke mg_get() once for each argument. - * Currently we do this by copying the SV if it's magical. */ - if (d) { - if (SvGMAGICAL(d)) - d = sv_mortalcopy(d); - } - else - d = &PL_sv_undef; - - assert(e); - if (SvGMAGICAL(e)) - e = sv_mortalcopy(e); /* ~~ undef */ if (!SvOK(e)) { @@ -4095,7 +4229,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHYES; while ( (he = hv_iternext(hv)) ) { DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); - ENTER; + ENTER_with_name("smartmatch_hash_key_test"); SAVETMPS; PUSHMARK(SP); PUSHs(hv_iterkeysv(he)); @@ -4107,7 +4241,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else andedresults = SvTRUEx(POPs) && andedresults; FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_hash_key_test"); } if (andedresults) RETPUSHYES; @@ -4126,7 +4260,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) for (i = 0; i <= len; ++i) { SV * const * const svp = av_fetch(av, i, FALSE); DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); - ENTER; + ENTER_with_name("smartmatch_array_elem_test"); SAVETMPS; PUSHMARK(SP); if (svp) @@ -4139,7 +4273,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else andedresults = SvTRUEx(POPs) && andedresults; FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_array_elem_test"); } if (andedresults) RETPUSHYES; @@ -4149,7 +4283,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else { sm_any_sub: DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); - ENTER; + ENTER_with_name("smartmatch_coderef"); SAVETMPS; PUSHMARK(SP); PUSHs(d); @@ -4161,7 +4295,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else if (SvTEMP(TOPs)) SvREFCNT_inc_void(TOPs); FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_coderef"); RETURN; } } @@ -4312,7 +4446,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (void) sv_2mortal(MUTABLE_SV(seen_this)); } if (NULL == seen_other) { - seen_this = newHV(); + seen_other = newHV(); (void) sv_2mortal(MUTABLE_SV(seen_other)); } for(i = 0; i <= other_len; ++i) { @@ -4320,7 +4454,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV * const * const other_elem = av_fetch(other_av, i, FALSE); if (!this_elem || !other_elem) { - if (this_elem || other_elem) + if ((this_elem && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) RETPUSHNO; } else if (hv_exists_ent(seen_this, @@ -4502,11 +4637,12 @@ PP(pp_enterwhen) fails, we don't want to push a context and then pop it again right away, so we skip straight to the op that follows the leavewhen. + RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) - return cLOGOP->op_other->op_next; + RETURNOP(cLOGOP->op_other->op_next); - ENTER; + ENTER_with_name("eval"); SAVETMPS; PUSHBLOCK(cx, CXt_WHEN, SP); @@ -4531,7 +4667,7 @@ PP(pp_leavewhen) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("eval"); return NORMAL; } @@ -4563,7 +4699,8 @@ PP(pp_break) I32 cxix; register PERL_CONTEXT *cx; I32 inner; - + dSP; + cxix = dopoptogiven(cxstack_ix); if (cxix < 0) { if (PL_op->op_flags & OPf_SPECIAL) @@ -4587,7 +4724,8 @@ PP(pp_break) if (CxFOREACH(cx)) return CX_LOOP_NEXTOP_GET(cx); else - return cx->blk_givwhen.leave_op; + /* RETURNOP calls PUTBACK which restores the old old sp */ + RETURNOP(cx->blk_givwhen.leave_op); } STATIC OP * @@ -4848,8 +4986,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) int status = 0; SV *upstream; STRLEN got_len; - const char *got_p = NULL; - const char *prune_from = NULL; + char *got_p = NULL; + char *prune_from = NULL; bool read_from_cache = FALSE; STRLEN umaxlen; @@ -4918,7 +5056,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) dSP; int count; - ENTER; + ENTER_with_name("call_filter_sub"); SAVE_DEFSV; SAVETMPS; EXTEND(SP, 2); @@ -4942,7 +5080,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_filter_sub"); } if(SvOK(upstream)) { @@ -4952,8 +5090,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) prune_from = got_p + umaxlen; } } else { - const char *const first_nl = - (const char *)memchr(got_p, '\n', got_len); + char *const first_nl = (char *)memchr(got_p, '\n', got_len); if (first_nl && first_nl + 1 < got_p + got_len) { /* There's a second line here... */ prune_from = first_nl + 1; @@ -4979,6 +5116,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SvUTF8_on(cache); } SvCUR_set(upstream, got_len - cached_len); + *prune_from = 0; /* Can't yet be EOF */ if (status == 0) status = 1;