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<require
+                         * Foo::Bar>), 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);
 	}