X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4b62894a4418bf61f306acb452472eb9fe79974e..a3c63a9402266c2f0e3bb0f421763d96ea1bd856:/pp_ctl.c?ds=sidebyside diff --git a/pp_ctl.c b/pp_ctl.c index 69280e2..17d4f0d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -34,7 +34,8 @@ #define PERL_IN_PP_CTL_C #include "perl.h" -#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#define RUN_PP_CATCHABLY(thispp) \ + STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) @@ -162,15 +163,9 @@ PP(pp_regcomp) /* handle the empty pattern */ if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) { if (PL_curpm == PL_reg_curpm) { - if (PL_curpm_under) { - if (PL_curpm_under == PL_reg_curpm) { - Perl_croak(aTHX_ "Infinite recursion via empty pattern"); - } else { - pm = PL_curpm_under; - } + if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) { + Perl_croak(aTHX_ "Infinite recursion via empty pattern"); } - } else { - pm = PL_curpm; } } @@ -218,9 +213,9 @@ PP(pp_substcont) SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ /* See "how taint works" above pp_subst() */ - if (SvTAINTED(TOPs)) - cx->sb_rxtainted |= SUBST_TAINT_REPL; sv_catsv_nomg(dstr, POPs); + if (UNLIKELY(TAINT_get)) + cx->sb_rxtainted |= SUBST_TAINT_REPL; if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m), cx->sb_targ, NULL, @@ -720,6 +715,7 @@ PP(pp_formline) SvSETMAGIC(sv); break; } + /* FALLTHROUGH */ case FF_LINESNGL: /* process ^* */ chopspace = 0; @@ -872,9 +868,9 @@ PP(pp_formline) } #else /* we generate fmt ourselves so it is safe */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; #endif PERL_MY_SNPRINTF_POST_GUARD(len, max); RESTORE_LC_NUMERIC(); @@ -920,7 +916,7 @@ PP(pp_formline) *t++ = ' '; } s1 = t - 3; - if (strnEQ(s1," ",3)) { + if (strBEGINs(s1," ")) { while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) s1--; } @@ -957,7 +953,7 @@ PP(pp_grepstart) if (PL_stack_base + TOPMARK == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - mXPUSHi(0); + XPUSHs(&PL_sv_zero); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + TOPMARK + 1; @@ -1127,9 +1123,11 @@ PP(pp_mapwhile) PP(pp_range) { + dTARG; if (GIMME_V == G_ARRAY) return NORMAL; - if (SvTRUEx(PAD_SV(PL_op->op_targ))) + GETTARGET; + if (SvTRUE_NN(targ)) return cLOGOP->op_other; else return NORMAL; @@ -1157,7 +1155,7 @@ PP(pp_flip) flip = SvIV(sv) == SvIV(GvSV(gv)); } } else { - flip = SvTRUE(sv); + flip = SvTRUE_NN(sv); } if (flip) { sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); @@ -1270,7 +1268,7 @@ PP(pp_flop) } } else { - flop = SvTRUE(sv); + flop = SvTRUE_NN(sv); } if (flop) { @@ -1684,7 +1682,13 @@ Perl_die_unwind(pTHX_ SV *msv) if (in_eval) { I32 cxix; - exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* We need to keep this SV alive through all the stack unwinding + * and FREETMPSing below, while ensuing that it doesn't leak + * if we call out to something which then dies (e.g. sub STORE{die} + * when unlocalising a tied var). So we do a dance with + * mortalising and SAVEFREEing. + */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); /* * Historically, perl used to set ERRSV ($@) early in the die @@ -1753,6 +1757,24 @@ Perl_die_unwind(pTHX_ SV *msv) restartjmpenv = cx->blk_eval.cur_top_env; restartop = cx->blk_eval.retop; + + /* We need a FREETMPS here to avoid late-called destructors + * clobbering $@ *after* we set it below, e.g. + * sub DESTROY { eval { die "X" } } + * eval { my $x = bless []; die $x = 0, "Y" }; + * is($@, "Y") + * Here the clearing of the $x ref mortalises the anon array, + * which needs to be freed *before* $& is set to "Y", + * otherwise it gets overwritten with "X". + * + * However, the FREETMPS will clobber exceptsv, so preserve it + * on the savestack for now. + */ + SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv)); + FREETMPS; + /* now we're about to pop the savestack, so re-mortalise it */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* Note that unlike pp_entereval, pp_require isn't supposed to * trap errors. So if we're a require, after we pop the * CXt_EVAL that pp_require pushed, rethrow the error with @@ -1778,7 +1800,7 @@ Perl_die_unwind(pTHX_ SV *msv) PP(pp_xor) { dSP; dPOPTOPssrl; - if (SvTRUE(left) != SvTRUE(right)) + if (SvTRUE_NN(left) != SvTRUE_NN(right)) RETSETYES; else RETSETNO; @@ -1920,7 +1942,7 @@ PP(pp_caller) } else { PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); - mPUSHi(0); + PUSHs(&PL_sv_zero); } gimme = cx->blk_gimme; if (gimme == G_VOID) @@ -1970,7 +1992,8 @@ PP(pp_caller) if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) av_extend(PL_dbargs, AvFILLp(ary) + off); - Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); + if (AvFILLp(ary) + 1 + off) + Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } mPUSHi(CopHINTS_get(cx->blk_oldcop)); @@ -1984,16 +2007,7 @@ PP(pp_caller) mask = &PL_sv_undef ; else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { - /* Get the bit mask for $warnings::Bits{all}, because - * it could have been extended by warnings::register */ - SV **bits_all; - HV * const bits = get_hv("warnings::Bits", 0); - if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { - mask = newSVsv(*bits_all); - } - else { - mask = newSVpvn(WARN_ALLstring, WARNsize) ; - } + mask = newSVpvn(WARN_ALLstring, WARNsize) ; } else mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); @@ -2011,8 +2025,10 @@ PP(pp_reset) dSP; const char * tmps; STRLEN len = 0; - if (MAXARG < 1 || (!TOPs && !POPs)) + if (MAXARG < 1 || (!TOPs && !POPs)) { + EXTEND(SP, 1); tmps = NULL, len = 0; + } else tmps = SvPVx_const(POPs, len); sv_resetpvn(tmps, len, CopSTASH(PL_curcop)); @@ -2628,6 +2644,9 @@ PP(pp_redo) return redo_op; } +#define UNENTERABLE (OP *)1 +#define GOTO_DEPTH 64 + STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) { @@ -2642,15 +2661,34 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || o->op_type == OP_LEAVESUB || - o->op_type == OP_LEAVETRY) + o->op_type == OP_LEAVETRY || + o->op_type == OP_LEAVEGIVEN) { *ops++ = cUNOPo->op_first; - if (ops >= oplimit) - Perl_croak(aTHX_ "%s", too_deep); } + else if (oplimit - opstack < GOTO_DEPTH) { + if (o->op_flags & OPf_KIDS + && cUNOPo->op_first->op_type == OP_PUSHMARK) { + *ops++ = UNENTERABLE; + } + else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type] + && OP_CLASS(o) != OA_LOGOP + && o->op_type != OP_LINESEQ + && o->op_type != OP_SREFGEN + && o->op_type != OP_ENTEREVAL + && o->op_type != OP_GLOB + && o->op_type != OP_RV2CV) { + OP * const kid = cUNOPo->op_first; + if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid)) + *ops++ = UNENTERABLE; + } + } + if (ops >= oplimit) + Perl_croak(aTHX_ "%s", too_deep); *ops = 0; if (o->op_flags & OPf_KIDS) { OP *kid; + OP * const kid1 = cUNOPo->op_first; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { @@ -2673,19 +2711,27 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac } } for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { + bool first_kid_of_binary = FALSE; if (kid == PL_lastgotoprobe) continue; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { if (ops == opstack) *ops++ = kid; - else if (ops[-1]->op_type == OP_NEXTSTATE || - ops[-1]->op_type == OP_DBSTATE) + else if (ops[-1] != UNENTERABLE + && (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE)) ops[-1] = kid; else *ops++ = kid; } + if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) { + first_kid_of_binary = TRUE; + ops--; + } if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) return o; + if (first_kid_of_binary) + *ops++ = UNENTERABLE; } } *ops = 0; @@ -2693,6 +2739,23 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac } +static void +S_check_op_type(pTHX_ OP * const o) +{ + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + /* XXX This comment seems to me like wishful thinking. --sprout */ + if (o == UNENTERABLE) + Perl_croak(aTHX_ + "Can't \"goto\" into a binary or list expression"); + if (o->op_type == OP_ENTERITER) + Perl_croak(aTHX_ + "Can't \"goto\" into the middle of a foreach loop"); + if (o->op_type == OP_ENTERGIVEN) + Perl_croak(aTHX_ + "Can't \"goto\" into a \"given\" block"); +} + /* also used for: pp_dump() */ PP(pp_goto) @@ -2701,7 +2764,6 @@ PP(pp_goto) OP *retop = NULL; I32 ix; PERL_CONTEXT *cx; -#define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; const char *label = NULL; STRLEN label_len = 0; @@ -3034,12 +3096,14 @@ PP(pp_goto) if (leaving_eval && *enterops && enterops[1]) { I32 i; for (i = 1; enterops[i]; i++) - if (enterops[i]->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + S_check_op_type(aTHX_ enterops[i]); } if (*enterops && enterops[1]) { - I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + I32 i = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; if (enterops[i]) deprecate("\"goto\" to jump into a construct"); } @@ -3058,13 +3122,15 @@ PP(pp_goto) if (*enterops && enterops[1]) { OP * const oldop = PL_op; - ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + ix = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; for (; enterops[ix]; ix++) { PL_op = enterops[ix]; - /* Eventually we may want to stack the needed arguments - * for each op. For now, we punt on the hard ones. */ - if (PL_op->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + S_check_op_type(aTHX_ PL_op); + DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n", + OP_NAME(PL_op))); PL_op->op_ppaddr(aTHX); } PL_op = oldop; @@ -3159,23 +3225,18 @@ establish a local jmpenv to handle exception traps. =cut */ STATIC OP * -S_docatch(pTHX_ OP *o) +S_docatch(pTHX_ Perl_ppaddr_t firstpp) { int ret; OP * const oldop = PL_op; dJMPENV; -#ifdef DEBUGGING assert(CATCH_GET == TRUE); -#endif - PL_op = o; JMPENV_PUSH(ret); switch (ret) { case 0: - assert(cxstack_ix >= 0); - assert(CxTYPE(CX_CUR()) == CXt_EVAL); - CX_CUR()->blk_eval.cur_top_env = PL_top_env; + PL_op = firstpp(aTHX); redo_body: CALLRUNOPS(aTHX); break; @@ -3257,7 +3318,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) return cv; case FIND_RUNCV_level_eq: if (level++ != arg) continue; - /* GERONIMO! */ + /* FALLTHROUGH */ default: return cv; } @@ -3353,7 +3414,11 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) SAVEGENERICSV(PL_curstash); PL_curstash = (HV *)CopSTASH(PL_curcop); if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; - else SvREFCNT_inc_simple_void(PL_curstash); + else { + SvREFCNT_inc_simple_void(PL_curstash); + save_item(PL_curstname); + sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash)); + } } /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); @@ -3538,15 +3603,22 @@ S_check_type_and_open(pTHX_ SV *name) errno EACCES, so only do a stat to separate a dir from a real EACCES caused by user perms */ #ifndef WIN32 - /* we use the value of errno later to see how stat() or open() failed. - * We don't want it set if the stat succeeded but we still failed, - * such as if the name exists, but is a directory */ - errno = 0; - st_rc = PerlLIO_stat(p, &st); - if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { + if (st_rc < 0) return NULL; + else { + int eno; + if(S_ISBLK(st.st_mode)) { + eno = EINVAL; + goto not_file; + } + else if(S_ISDIR(st.st_mode)) { + eno = EISDIR; + not_file: + errno = eno; + return NULL; + } } #endif @@ -3558,8 +3630,10 @@ S_check_type_and_open(pTHX_ SV *name) int eno; st_rc = PerlLIO_stat(p, &st); if (st_rc >= 0) { - if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) - eno = 0; + if(S_ISDIR(st.st_mode)) + eno = EISDIR; + else if(S_ISBLK(st.st_mode)) + eno = EINVAL; else eno = EACCES; errno = eno; @@ -3590,7 +3664,7 @@ S_doopen_pm(pTHX_ SV *name) if (!IS_SAFE_PATHNAME(p, namelen, "require")) return NULL; - if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { + if (memENDPs(p, namelen, ".pm")) { SV *const pmcsv = sv_newmortal(); PerlIO * pmcio; @@ -3733,6 +3807,7 @@ S_require_file(pTHX_ SV *sv) I32 old_savestack_ix; const bool op_is_require = PL_op->op_type == OP_REQUIRE; const char *const op_name = op_is_require ? "require" : "do"; + SV ** svp_cached = NULL; assert(op_is_require || PL_op->op_type == OP_DOFILE); @@ -3742,6 +3817,15 @@ S_require_file(pTHX_ SV *sv) if (!(name && len > 0 && *name)) DIE(aTHX_ "Missing or undefined argument to %s", op_name); +#ifndef VMS + /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */ + if (op_is_require) { + /* can optimize to only perform one single lookup */ + svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0); + if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES; + } +#endif + if (!IS_SAFE_PATHNAME(name, len, op_name)) { if (!op_is_require) { CLEAR_ERRSV(); @@ -3780,8 +3864,8 @@ S_require_file(pTHX_ SV *sv) unixlen = len; } if (op_is_require) { - SV * const * const svp = hv_fetch(GvHVn(PL_incgv), - unixname, unixlen, 0); + /* reuse the previous hv_fetch result if possible */ + SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if ( svp ) { if (*svp != &PL_sv_undef) RETPUSHYES; @@ -3815,7 +3899,7 @@ S_require_file(pTHX_ SV *sv) directory, or (*nix) hidden filenames. Also sanity check that the generated filename ends .pm */ if (!path_searchable || len < 3 || name[0] == '.' - || !memEQ(name + package_len, ".pm", 3)) + || !memEQs(name + package_len, len - package_len, ".pm")) DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv); if (memchr(name, 0, package_len)) { /* diag_listed_as: Bareword in require contains "%s" */ @@ -4019,8 +4103,7 @@ S_require_file(pTHX_ SV *sv) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -#else -# ifdef __SYMBIAN32__ +#elif defined(__SYMBIAN32__) if (PL_origfilename[0] && PL_origfilename[1] == ':' && !(dir[0] && dir[1] == ':')) @@ -4032,7 +4115,7 @@ S_require_file(pTHX_ SV *sv) Perl_sv_setpvf(aTHX_ namesv, "%s\\%s", dir, name); -# else +#else /* The equivalent of Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); but without the need to parse the format string, or @@ -4059,7 +4142,6 @@ S_require_file(pTHX_ SV *sv) SvCUR_set(namesv, dirlen + len + 1); SvPOK_on(namesv); } -# endif #endif TAINT_PROPER(op_name); tryname = SvPVX_const(namesv); @@ -4105,24 +4187,54 @@ S_require_file(pTHX_ SV *sv) sv_catpvs(inc, " "); sv_catsv(inc, *av_fetch(ar, i, TRUE)); } - if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) { - const char *c, *e = name + len - 3; - sv_catpv(msg, " (you may need to install the "); - for (c = name; c < e; c++) { - if (*c == '/') { - sv_catpvs(msg, "::"); - } - else { - sv_catpvn(msg, c, 1); - } - } - sv_catpv(msg, " module)"); + if (memENDPs(name, len, ".pm")) { + const char *e = name + len - (sizeof(".pm") - 1); + const char *c; + bool utf8 = cBOOL(SvUTF8(sv)); + + /* if the filename, when converted from "Foo/Bar.pm" + * form back to Foo::Bar form, makes a valid + * package name (i.e. parseable by C), then emit a hint. + * + * this loop is modelled after the one in + S_parse_ident */ + c = name; + while (c < e) { + if (utf8 && isIDFIRST_utf8_safe(c, e)) { + c += UTF8SKIP(c); + while (c < e && isIDCONT_utf8_safe( + (const U8*) c, (const U8*) e)) + c += UTF8SKIP(c); + } + else if (isWORDCHAR_A(*c)) { + while (c < e && isWORDCHAR_A(*c)) + c++; + } + else if (*c == '/') + c++; + else + break; + } + + if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) { + sv_catpvs(msg, " (you may need to install the "); + for (c = name; c < e; c++) { + if (*c == '/') { + sv_catpvs(msg, "::"); + } + else { + sv_catpvn(msg, c, 1); + } + } + sv_catpvs(msg, " module)"); + } } - else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) { - sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); + else if (memENDs(name, len, ".h")) { + sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); } - else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) { - sv_catpv(msg, " (did you run h2ph?)"); + else if (memENDs(name, len, ".ph")) { + sv_catpvs(msg, " (did you run h2ph?)"); } /* diag_listed_as: Can't locate %s */ @@ -4197,6 +4309,7 @@ S_require_file(pTHX_ SV *sv) } /* switch to eval mode */ + assert(!CATCH_GET); cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix); cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0)); @@ -4206,7 +4319,7 @@ S_require_file(pTHX_ SV *sv) PUTBACK; if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) - op = DOCATCH(PL_eval_start); + op = PL_eval_start; else op = PL_op->op_next; @@ -4220,13 +4333,17 @@ S_require_file(pTHX_ SV *sv) PP(pp_require) { - dSP; - SV *sv = POPs; - SvGETMAGIC(sv); - PUTBACK; - return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) - ? S_require_version(aTHX_ sv) - : S_require_file(aTHX_ sv); + RUN_PP_CATCHABLY(Perl_pp_require); + + { + dSP; + SV *sv = POPs; + SvGETMAGIC(sv); + PUTBACK; + return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) + ? S_require_version(aTHX_ sv) + : S_require_file(aTHX_ sv); + } } @@ -4247,18 +4364,28 @@ PP(pp_entereval) dSP; PERL_CONTEXT *cx; SV *sv; - const U8 gimme = GIMME_V; - const U32 was = PL_breakable_sub_gen; + U8 gimme; + U32 was; char tbuf[TYPE_DIGITS(long) + 12]; - bool saved_delete = FALSE; - char *tmpbuf = tbuf; + bool saved_delete; + char *tmpbuf; STRLEN len; CV* runcv; - U32 seq, lex_flags = 0; - HV *saved_hh = NULL; - const bool bytes = PL_op->op_private & OPpEVAL_BYTES; + U32 seq, lex_flags; + HV *saved_hh; + bool bytes; I32 old_savestack_ix; + RUN_PP_CATCHABLY(Perl_pp_entereval); + + gimme = GIMME_V; + was = PL_breakable_sub_gen; + saved_delete = FALSE; + tmpbuf = tbuf; + lex_flags = 0; + saved_hh = NULL; + bytes = PL_op->op_private & OPpEVAL_BYTES; + if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } @@ -4326,6 +4453,7 @@ PP(pp_entereval) * to do the dirty work for us */ runcv = find_runcv(&seq); + assert(!CATCH_GET); cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix); cx_pusheval(cx, PL_op->op_next, NULL); @@ -4355,7 +4483,7 @@ PP(pp_entereval) char *const safestr = savepvn(tmpbuf, len); SAVEDELETE(PL_defstash, safestr, len); } - return DOCATCH(PL_eval_start); + return PL_eval_start; } else { /* We have already left the scope set up earlier thanks to the LEAVE in doeval_compile(). */ @@ -4394,11 +4522,14 @@ PP(pp_leaveeval) /* did require return a false value? */ failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE && !(gimme == G_SCALAR - ? SvTRUE(*PL_stack_sp) + ? SvTRUE_NN(*PL_stack_sp) : PL_stack_sp > oldsp); - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 0); @@ -4466,8 +4597,11 @@ Perl_create_eval_scope(pTHX_ OP *retop, U32 flags) PP(pp_entertry) { + RUN_PP_CATCHABLY(Perl_pp_entertry); + + assert(!CATCH_GET); create_eval_scope(cLOGOP->op_other->op_next, 0); - return DOCATCH(PL_op->op_next); + return PL_op->op_next; } @@ -4487,8 +4621,11 @@ PP(pp_leavetry) oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); @@ -5089,8 +5226,11 @@ PP(pp_enterwhen) to the op that follows the leavewhen. RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ - if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) + if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) { + if (gimme == G_SCALAR) + PUSHs(&PL_sv_undef); RETURNOP(cLOGOP->op_other->op_next); + } cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); cx_pushwhen(cx); @@ -5289,7 +5429,8 @@ S_doparseform(pTHX_ SV *sv) if (s < send) { skipspaces = 0; continue; - } /* else FALL THROUGH */ + } + /* FALLTHROUGH */ case '\n': arg = s - base; skipspaces++; @@ -5557,7 +5698,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) DEFSV_set(upstream); PUSHMARK(SP); - mPUSHi(0); + PUSHs(&PL_sv_zero); if (filter_state) { PUSHs(filter_state); }