X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6bc991bfb3c34a5d286a1202fcc0d740d72dcee7..50a9fad1a8ce99fe48223ca407d09d01f8c4bef6:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index b196640..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); @@ -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: @@ -1544,48 +1576,17 @@ Perl_qerror(pTHX_ SV *err) } void -Perl_die_where(pTHX_ SV *msv) +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,21 +1627,33 @@ 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); + 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 */ } @@ -1841,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)) { @@ -1858,7 +1875,7 @@ PP(pp_dbstate) /* don't do recursive DB::DB call */ return NORMAL; - ENTER_with_name("sub"); + ENTER; SAVETMPS; SAVEI32(PL_debug); @@ -1873,7 +1890,7 @@ PP(pp_dbstate) (void)(*CvXSUB(cv))(aTHX_ cv); CvDEPTH(cv)--; FREETMPS; - LEAVE_with_name("sub"); + LEAVE; return NORMAL; } else { @@ -2088,6 +2105,7 @@ PP(pp_return) SV **newsp; PMOP *newpm; I32 optype = 0; + SV *namesv; SV *sv; OP *retop = NULL; @@ -2130,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; @@ -2138,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: @@ -2393,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) @@ -2534,7 +2556,7 @@ PP(pp_goto) PUSHMARK(mark); PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); - LEAVE_with_name("sub"); + LEAVE; return retop; } else { @@ -2621,6 +2643,8 @@ PP(pp_goto) else label = cPVOP->op_pv; + PERL_ASYNC_CHECK(); + if (label && *label) { OP *gotoprobe = NULL; bool leaving_eval = FALSE; @@ -2805,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) { @@ -2829,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; @@ -2856,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; @@ -2993,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. @@ -3007,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); @@ -3060,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_with_name("eval"); /* 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")); } @@ -3098,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; @@ -3250,28 +3341,29 @@ 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) { @@ -3376,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; @@ -3442,6 +3529,12 @@ PP(pp_require) FREETMPS; 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; break; @@ -3534,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; @@ -3711,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++; @@ -3769,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; @@ -3812,10 +3918,12 @@ 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_with_name("eval"); @@ -3957,14 +4065,38 @@ PP(pp_leavegiven) POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_GIVEN); - SP = newsp; - PUTBACK; - - PL_curpm = newpm; /* pop $1 et al */ + 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 */ LEAVE_with_name("given"); - - return NORMAL; + RETURN; } /* Helper routines used by pp_smartmatch */ @@ -4032,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; @@ -4050,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)) { @@ -4504,9 +4637,10 @@ 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_with_name("eval"); SAVETMPS; @@ -4565,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) @@ -4589,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 *