X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fb55feefe971ae1552e21360ba05c793b60fefd6..ac1dd572b7ca3bf48b942fd88551d451d38a884d:/pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index 34fe990..199df1f 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -69,9 +69,6 @@ PP(pp_wantarray)
 PP(pp_regcreset)
 {
     dVAR;
-    /* XXXX Should store the old value to allow for tie/overload - and
-       restore in regcomp, where marked with XXXX. */
-    PL_reginterp_cnt = 0;
     TAINT_NOT;
     return NORMAL;
 }
@@ -80,199 +77,113 @@ PP(pp_regcomp)
 {
     dVAR;
     dSP;
-    register PMOP *pm = (PMOP*)cLOGOP->op_other;
-    SV *tmpstr;
+    PMOP *pm = (PMOP*)cLOGOP->op_other;
+    SV **args;
+    int nargs;
     REGEXP *re = NULL;
+    REGEXP *new_re;
+    const regexp_engine *eng;
+    bool is_bare_re;
+
+    if (PL_op->op_flags & OPf_STACKED) {
+	dMARK;
+	nargs = SP - MARK;
+	args  = ++MARK;
+    }
+    else {
+	nargs = 1;
+	args  = SP;
+    }
 
     /* prevent recompiling under /o and ithreads. */
 #if defined(USE_ITHREADS)
     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
-	if (PL_op->op_flags & OPf_STACKED) {
-	    dMARK;
-	    SP = MARK;
-	}
-	else
-	    (void)POPs;
+	SP = args-1;
 	RETURN;
     }
 #endif
 
-#define tryAMAGICregexp(rx)			\
-    STMT_START {				\
-	SvGETMAGIC(rx);				\
-	if (SvROK(rx) && SvAMAGIC(rx)) {	\
-	    SV *sv = AMG_CALLunary(rx, regexp_amg); \
-	    if (sv) {				\
-		if (SvROK(sv))			\
-		    sv = SvRV(sv);		\
-		if (SvTYPE(sv) != SVt_REGEXP)	\
-		    Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
-		rx = sv;			\
-	    }					\
-	}					\
-    } STMT_END
-	    
-
-    if (PL_op->op_flags & OPf_STACKED) {
-	/* multiple args; concatenate them */
-	dMARK; dORIGMARK;
-	tmpstr = PAD_SV(ARGTARG);
-	sv_setpvs(tmpstr, "");
-	while (++MARK <= SP) {
-	    SV *msv = *MARK;
-	    SV *sv;
-
-	    tryAMAGICregexp(msv);
-
-	    if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
-		(sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
-	    {
-	       sv_setsv(tmpstr, sv);
-	       continue;
-	    }
-
-	    if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) {
-		msv = SvRV(msv);
-		PL_reginterp_cnt +=
-		    RX_SEEN_EVALS((REGEXP *)MUTABLE_PTR(msv));
-	    }
-
-	    sv_catsv_nomg(tmpstr, msv);
-	}
-    	SvSETMAGIC(tmpstr);
-	SP = ORIGMARK;
-    }
-    else {
-	tmpstr = POPs;
-	tryAMAGICregexp(tmpstr);
-    }
-
-#undef tryAMAGICregexp
-
-    if (SvROK(tmpstr)) {
-	SV * const sv = SvRV(tmpstr);
-	if (SvTYPE(sv) == SVt_REGEXP)
-	    re = (REGEXP*) sv;
-    }
-    else if (SvTYPE(tmpstr) == SVt_REGEXP)
-	re = (REGEXP*) tmpstr;
-
-    if (re) {
-	/* The match's LHS's get-magic might need to access this op's reg-
-	   exp (as is sometimes the case with $';  see bug 70764).  So we
-	   must call get-magic now before we replace the regexp. Hopeful-
-	   ly this hack can be replaced with the approach described at
-	   http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
-	   /msg122415.html some day. */
-	if(pm->op_type == OP_MATCH) {
-	 SV *lhs;
-	 const bool was_tainted = PL_tainted;
-	 if (pm->op_flags & OPf_STACKED)
-	    lhs = TOPs;
-	 else if (pm->op_private & OPpTARGET_MY)
-	    lhs = PAD_SV(pm->op_targ);
-	 else lhs = DEFSV;
-	 SvGETMAGIC(lhs);
-	 /* Restore the previous value of PL_tainted (which may have been
-	    modified by get-magic), to avoid incorrectly setting the
-	    RXf_TAINTED flag further down. */
-	 PL_tainted = was_tainted;
+    re = PM_GETRE(pm);
+    assert (re != (REGEXP*) &PL_sv_undef);
+    eng = re ? RX_ENGINE(re) : current_re_engine();
+
+    new_re = (eng->op_comp
+		    ? eng->op_comp
+		    : &Perl_re_op_compile
+	    )(aTHX_ args, nargs, pm->op_code_list, eng, re,
+		&is_bare_re,
+		(pm->op_pmflags & RXf_PMf_COMPILETIME),
+		pm->op_pmflags |
+		    (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
+    if (pm->op_pmflags & PMf_HAS_CV)
+	ReANY(new_re)->qr_anoncv
+			= (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
+
+    if (is_bare_re) {
+	REGEXP *tmp;
+	/* The match's LHS's get-magic might need to access this op's regexp
+	   (e.g. $' =~ /$re/ while foo; see bug 70764).  So we must call
+	   get-magic now before we replace the regexp. Hopefully this hack can
+	   be replaced with the approach described at
+	   http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
+	   some day. */
+	if (pm->op_type == OP_MATCH) {
+	    SV *lhs;
+	    const bool was_tainted = TAINT_get;
+	    if (pm->op_flags & OPf_STACKED)
+		lhs = args[-1];
+	    else if (pm->op_private & OPpTARGET_MY)
+		lhs = PAD_SV(pm->op_targ);
+	    else lhs = DEFSV;
+	    SvGETMAGIC(lhs);
+	    /* Restore the previous value of PL_tainted (which may have been
+	       modified by get-magic), to avoid incorrectly setting the
+	       RXf_TAINTED flag with RX_TAINT_on further down. */
+	    TAINT_set(was_tainted);
 	}
-
-	re = reg_temp_copy(NULL, re);
-	ReREFCNT_dec(PM_GETRE(pm));
-	PM_SETRE(pm, re);
+	tmp = reg_temp_copy(NULL, new_re);
+	ReREFCNT_dec(new_re);
+	new_re = tmp;
     }
-    else {
-	STRLEN len = 0;
-	const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
-
-	re = PM_GETRE(pm);
-	assert (re != (REGEXP*) &PL_sv_undef);
-
-	/* Check against the last compiled regexp. */
-	if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
-	    memNE(RX_PRECOMP(re), t, len))
-	{
-	    const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
-            U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
-	    if (re) {
-	        ReREFCNT_dec(re);
-#ifdef USE_ITHREADS
-		PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
-#else
-		PM_SETRE(pm, NULL);	/* crucial if regcomp aborts */
-#endif
-	    } else if (PL_curcop->cop_hints_hash) {
-	        SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
-                if (ptr && SvIOK(ptr) && SvIV(ptr))
-                    eng = INT2PTR(regexp_engine*,SvIV(ptr));
-	    }
-
-	    if (PL_op->op_flags & OPf_SPECIAL)
-		PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
-
-	    if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
-		/* Not doing UTF-8, despite what the SV says. Is this only if
-		   we're trapped in use 'bytes'?  */
-		/* Make a copy of the octet sequence, but without the flag on,
-		   as the compiler now honours the SvUTF8 flag on tmpstr.  */
-		STRLEN len;
-		const char *const p = SvPV(tmpstr, len);
-		tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
-	    }
-	    else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
-		/* make a copy to avoid extra stringifies */
-		tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
-	    }
-
-	    if (eng)
-	        PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
-	    else
-	        PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
-
-	    PL_reginterp_cnt = 0;	/* XXXX Be extra paranoid - needed
-					   inside tie/overload accessors.  */
-	}
+    if (re != new_re) {
+	ReREFCNT_dec(re);
+	PM_SETRE(pm, new_re);
     }
-    
-    re = PM_GETRE(pm);
 
 #ifndef INCOMPLETE_TAINTS
-    if (PL_tainting) {
-	if (PL_tainted) {
-	    SvTAINTED_on((SV*)re);
-	    RX_EXTFLAGS(re) |= RXf_TAINTED;
-	}
+    if (TAINTING_get && TAINT_get) {
+	SvTAINTED_on((SV*)new_re);
+        RX_TAINT_on(new_re);
     }
 #endif
 
-    if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
-	pm = PL_curpm;
-
-
 #if !defined(USE_ITHREADS)
     /* can't change the optree at runtime either */
     /* PMf_KEEP is handled differently under threads to avoid these problems */
+    if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
+	pm = PL_curpm;
     if (pm->op_pmflags & PMf_KEEP) {
 	pm->op_private &= ~OPpRUNTIME;	/* no point compiling again */
 	cLOGOP->op_first->op_next = PL_op->op_next;
     }
 #endif
+
+    SP = args-1;
     RETURN;
 }
 
+
 PP(pp_substcont)
 {
     dVAR;
     dSP;
-    register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
-    register PMOP * const pm = (PMOP*) cLOGOP->op_other;
-    register SV * const dstr = cx->sb_dstr;
-    register char *s = cx->sb_s;
-    register char *m = cx->sb_m;
+    PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+    PMOP * const pm = (PMOP*) cLOGOP->op_other;
+    SV * const dstr = cx->sb_dstr;
+    char *s = cx->sb_s;
+    char *m = cx->sb_m;
     char *orig = cx->sb_orig;
-    register REGEXP * const rx = cx->sb_rx;
+    REGEXP * const rx = cx->sb_rx;
     SV *nsv = NULL;
     REGEXP *old = PM_GETRE(pm);
 
@@ -302,28 +213,19 @@ PP(pp_substcont)
 	s -= RX_GOFS(rx);
 
 	/* Are we done */
-	/* I believe that we can't set REXEC_SCREAM here if
-	   SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
-	   equal to s.  [See the comment before Perl_re_intuit_start(), which is
-	   called from Perl_regexec_flags(), which says that it should be when
-	   SvSCREAM() is true.]  s, cx->sb_strend and orig will be consistent
-	   with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
-	   during the match.  */
 	if (CxONCE(cx) || s < orig ||
 		!CALLREGEXEC(rx, s, cx->sb_strend, orig,
 			     (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
-			     ((cx->sb_rflags & REXEC_COPY_STR)
-			      ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
-			      : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+                                (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
 	{
 	    SV *targ = cx->sb_targ;
 
 	    assert(cx->sb_strend >= s);
 	    if(cx->sb_strend > s) {
 		 if (DO_UTF8(dstr) && !SvUTF8(targ))
-		      sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+		      sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 		 else
-		      sv_catpvn(dstr, s, cx->sb_strend - s);
+		      sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
 	    }
 	    if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 		cx->sb_rxtainted |= SUBST_TAINT_PAT;
@@ -348,6 +250,7 @@ PP(pp_substcont)
 		    SvUTF8_on(targ);
 		SvPV_set(dstr, NULL);
 
+		PL_tainted = 0;
 		mPUSHi(saviters - 1);
 
 		(void)SvPOK_only_UTF8(targ);
@@ -356,7 +259,7 @@ PP(pp_substcont)
 	    /* update the taint state of various various variables in
 	     * preparation for final exit.
 	     * See "how taint works" above pp_subst() */
-	    if (PL_tainting) {
+	    if (TAINTING_get) {
 		if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 		    ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 				    == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
@@ -368,8 +271,10 @@ PP(pp_substcont)
 		)
 		    SvTAINTED_on(TOPs);  /* taint return value */
 		/* needed for mg_set below */
-		PL_tainted = cBOOL(cx->sb_rxtainted &
-			    (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+		TAINT_set(
+                    cBOOL(cx->sb_rxtainted &
+			  (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+                );
 		SvTAINT(TARG);
 	    }
 	    /* PL_tainted must be correctly set for this mg_set */
@@ -378,13 +283,14 @@ PP(pp_substcont)
 	    LEAVE_SCOPE(cx->sb_oldsave);
 	    POPSUBST(cx);
 	    RETURNOP(pm->op_next);
-	    /* NOTREACHED */
+	    assert(0); /* NOTREACHED */
 	}
 	cx->sb_iters = saviters;
     }
     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 	m = s;
 	s = orig;
+        assert(!RX_SUBOFFSET(rx));
 	cx->sb_orig = orig = RX_SUBBEG(rx);
 	s = orig + (m - s);
 	cx->sb_strend = s + (cx->sb_strend - m);
@@ -392,9 +298,9 @@ PP(pp_substcont)
     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
     if (m > s) {
 	if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
-	    sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+	    sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
 	else
-	    sv_catpvn(dstr, s, m-s);
+	    sv_catpvn_nomg(dstr, s, m-s);
     }
     cx->sb_s = RX_OFFS(rx)[0].end + orig;
     { /* Update the pos() information. */
@@ -417,7 +323,7 @@ PP(pp_substcont)
     /* update the taint state of various various variables in preparation
      * for calling the code block.
      * See "how taint works" above pp_subst() */
-    if (PL_tainting) {
+    if (TAINTING_get) {
 	if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 	    cx->sb_rxtainted |= SUBST_TAINT_PAT;
 
@@ -448,10 +354,10 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     PERL_UNUSED_CONTEXT;
 
     if (!p || p[1] < RX_NPARENS(rx)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
-	i = 7 + RX_NPARENS(rx) * 2;
+#ifdef PERL_ANY_COW
+	i = 7 + (RX_NPARENS(rx)+1) * 2;
 #else
-	i = 6 + RX_NPARENS(rx) * 2;
+	i = 6 + (RX_NPARENS(rx)+1) * 2;
 #endif
 	if (!p)
 	    Newx(p, i, UV);
@@ -460,18 +366,20 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 	*rsp = (void*)p;
     }
 
+    /* what (if anything) to free on croak */
     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
     RX_MATCH_COPIED_off(rx);
+    *p++ = RX_NPARENS(rx);
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     *p++ = PTR2UV(RX_SAVED_COPY(rx));
     RX_SAVED_COPY(rx) = NULL;
 #endif
 
-    *p++ = RX_NPARENS(rx);
-
     *p++ = PTR2UV(RX_SUBBEG(rx));
     *p++ = (UV)RX_SUBLEN(rx);
+    *p++ = (UV)RX_SUBOFFSET(rx);
+    *p++ = (UV)RX_SUBCOFFSET(rx);
     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 	*p++ = (UV)RX_OFFS(rx)[i].start;
 	*p++ = (UV)RX_OFFS(rx)[i].end;
@@ -490,18 +398,19 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
     RX_MATCH_COPY_FREE(rx);
     RX_MATCH_COPIED_set(rx, *p);
     *p++ = 0;
+    RX_NPARENS(rx) = *p++;
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     if (RX_SAVED_COPY(rx))
 	SvREFCNT_dec (RX_SAVED_COPY(rx));
     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
     *p++ = 0;
 #endif
 
-    RX_NPARENS(rx) = *p++;
-
     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
     RX_SUBLEN(rx) = (I32)(*p++);
+    RX_SUBOFFSET(rx) = (I32)*p++;
+    RX_SUBCOFFSET(rx) = (I32)*p++;
     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 	RX_OFFS(rx)[i].start = (I32)(*p++);
 	RX_OFFS(rx)[i].end = (I32)(*p++);
@@ -517,19 +426,23 @@ S_rxres_free(pTHX_ void **rsp)
     PERL_UNUSED_CONTEXT;
 
     if (p) {
-#ifdef PERL_POISON
 	void *tmp = INT2PTR(char*,*p);
-	Safefree(tmp);
-	if (*p)
-	    PoisonFree(*p, 1, sizeof(*p));
+#ifdef PERL_POISON
+#ifdef PERL_ANY_COW
+	U32 i = 9 + p[1] * 2;
 #else
-	Safefree(INT2PTR(char*,*p));
+	U32 i = 8 + p[1] * 2;
 #endif
-#ifdef PERL_OLD_COPY_ON_WRITE
-	if (p[1]) {
-	    SvREFCNT_dec (INT2PTR(SV*,p[1]));
-	}
 #endif
+
+#ifdef PERL_ANY_COW
+        SvREFCNT_dec (INT2PTR(SV*,p[2]));
+#endif
+#ifdef PERL_POISON
+        PoisonFree(p, i, sizeof(UV));
+#endif
+
+	Safefree(tmp);
 	Safefree(p);
 	*rsp = NULL;
     }
@@ -541,13 +454,13 @@ S_rxres_free(pTHX_ void **rsp)
 PP(pp_formline)
 {
     dVAR; dSP; dMARK; dORIGMARK;
-    register SV * const tmpForm = *++MARK;
+    SV * const tmpForm = *++MARK;
     SV *formsv;		    /* contains text of original format */
-    register U32 *fpc;	    /* format ops program counter */
-    register char *t;	    /* current append position in target string */
+    U32 *fpc;	    /* format ops program counter */
+    char *t;	    /* current append position in target string */
     const char *f;	    /* current position in format string */
-    register I32 arg;
-    register SV *sv = NULL; /* current item */
+    I32 arg;
+    SV *sv = NULL; /* current item */
     const char *item = NULL;/* string value of current item */
     I32 itemsize  = 0;	    /* length of current item, possibly truncated */
     I32 fieldsize = 0;	    /* width of current field */
@@ -1305,7 +1218,7 @@ PP(pp_flop)
 	SvGETMAGIC(right);
 
 	if (RANGE_IS_NUMERIC(left,right)) {
-	    register IV i, j;
+	    IV i, j;
 	    IV max;
 	    if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
 		(SvOK(right) && SvNV_nomg(right) > IV_MAX))
@@ -1389,12 +1302,12 @@ STATIC I32
 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
 {
     dVAR;
-    register I32 i;
+    I32 i;
 
     PERL_ARGS_ASSERT_DOPOPTOLABEL;
 
     for (i = cxstack_ix; i >= 0; i--) {
-	register const PERL_CONTEXT * const cx = &cxstack[i];
+	const PERL_CONTEXT * const cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	case CXt_SUB:
@@ -1465,7 +1378,7 @@ Perl_block_gimme(pTHX)
 	return G_ARRAY;
     default:
 	Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
-	/* NOTREACHED */
+	assert(0); /* NOTREACHED */
 	return 0;
     }
 }
@@ -1506,7 +1419,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
 
     for (i = startingblock; i >= 0; i--) {
-	register const PERL_CONTEXT * const cx = &cxstk[i];
+	const PERL_CONTEXT * const cx = &cxstk[i];
 	switch (CxTYPE(cx)) {
 	default:
 	    continue;
@@ -1526,7 +1439,7 @@ S_dopoptoeval(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-	register const PERL_CONTEXT *cx = &cxstack[i];
+	const PERL_CONTEXT *cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	default:
 	    continue;
@@ -1544,7 +1457,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-	register const PERL_CONTEXT * const cx = &cxstack[i];
+	const PERL_CONTEXT * const cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	case CXt_SUB:
@@ -1574,7 +1487,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-	register const PERL_CONTEXT *cx = &cxstack[i];
+	const PERL_CONTEXT *cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	default:
 	    continue;
@@ -1602,7 +1515,7 @@ S_dopoptowhen(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-	register const PERL_CONTEXT *cx = &cxstack[i];
+	const PERL_CONTEXT *cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	default:
 	    continue;
@@ -1625,7 +1538,7 @@ Perl_dounwind(pTHX_ I32 cxix)
 
     while (cxstack_ix > cxix) {
 	SV *sv;
-        register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 	DEBUG_CX("UNWIND");						\
 	/* Note: we don't need to restore the base context info till the end. */
 	switch (CxTYPE(cx)) {
@@ -1735,7 +1648,7 @@ Perl_die_unwind(pTHX_ SV *msv)
 	if (cxix >= 0) {
 	    I32 optype;
 	    SV *namesv;
-	    register PERL_CONTEXT *cx;
+	    PERL_CONTEXT *cx;
 	    SV **newsp;
 	    COP *oldcop;
 	    JMPENV *restartjmpenv;
@@ -1793,13 +1706,13 @@ Perl_die_unwind(pTHX_ SV *msv)
 	    PL_restartjmpenv = restartjmpenv;
 	    PL_restartop = restartop;
 	    JMPENV_JUMP(3);
-	    /* NOTREACHED */
+	    assert(0); /* NOTREACHED */
 	}
     }
 
     write_to_stderr(exceptsv);
     my_failure_exit();
-    /* NOTREACHED */
+    assert(0); /* NOTREACHED */
 }
 
 PP(pp_xor)
@@ -1833,9 +1746,9 @@ frame for the sub call itself.
 const PERL_CONTEXT *
 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
 {
-    register I32 cxix = dopoptosub(cxstack_ix);
-    register const PERL_CONTEXT *cx;
-    register const PERL_CONTEXT *ccstack = cxstack;
+    I32 cxix = dopoptosub(cxstack_ix);
+    const PERL_CONTEXT *cx;
+    const PERL_CONTEXT *ccstack = cxstack;
     const PERL_SI *top_si = PL_curstackinfo;
 
     for (;;) {
@@ -1875,7 +1788,7 @@ PP(pp_caller)
 {
     dVAR;
     dSP;
-    register const PERL_CONTEXT *cx;
+    const PERL_CONTEXT *cx;
     const PERL_CONTEXT *dbcx;
     I32 gimme;
     const HEK *stash_hek;
@@ -1898,9 +1811,10 @@ PP(pp_caller)
     }
 
     DEBUG_CX("CALLER");
-    assert(CopSTASHPV(cx->blk_oldcop));
-    assert(SvOOK((HV*)CopSTASH(cx->blk_oldcop)));
-    stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
+    assert(CopSTASH(cx->blk_oldcop));
+    stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
+      ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
+      : NULL;
     if (GIMME != G_ARRAY) {
         EXTEND(SP, 1);
 	if (!stash_hek)
@@ -1929,7 +1843,7 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
 	GV * const cvgv = CvGV(dbcx->blk_sub.cv);
 	/* So is ccstack[dbcxix]. */
-	if (isGV(cvgv)) {
+	if (cvgv && isGV(cvgv)) {
 	    SV * const sv = newSV(0);
 	    gv_efullname3(sv, cvgv, NULL);
 	    mPUSHs(sv);
@@ -1952,7 +1866,9 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_EVAL) {
 	/* eval STRING */
 	if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
-	    PUSHs(cx->blk_eval.cur_text);
+	    PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+				 SvCUR(cx->blk_eval.cur_text)-2,
+				 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
 	    PUSHs(&PL_sv_no);
 	}
 	/* require */
@@ -1983,17 +1899,15 @@ PP(pp_caller)
 	Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
 	AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
     }
-    /* XXX only hints propagated via op_private are currently
-     * visible (others are not easily accessible, since they
-     * use the global PL_hints) */
     mPUSHi(CopHINTS_get(cx->blk_oldcop));
     {
 	SV * mask ;
 	STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
 
-	if  (old_warnings == pWARN_NONE ||
-		(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
+	if  (old_warnings == pWARN_NONE)
             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+	else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
+            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
@@ -2022,9 +1936,13 @@ PP(pp_reset)
 {
     dVAR;
     dSP;
-    const char * const tmps =
-	(MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
-    sv_reset(tmps, CopSTASH(PL_curcop));
+    const char * tmps;
+    STRLEN len = 0;
+    if (MAXARG < 1 || (!TOPs && !POPs))
+	tmps = NULL, len = 0;
+    else
+	tmps = SvPVx_const(POPs, len);
+    sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
     PUSHs(&PL_sv_yes);
     RETURN;
 }
@@ -2045,13 +1963,16 @@ PP(pp_dbstate)
 	    || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
     {
 	dSP;
-	register PERL_CONTEXT *cx;
+	PERL_CONTEXT *cx;
 	const I32 gimme = G_ARRAY;
 	U8 hasargs;
 	GV * const gv = PL_DBgv;
-	register CV * const cv = GvCV(gv);
+	CV * cv = NULL;
+
+        if (gv && isGV_with_GP(gv))
+            cv = GvCV(gv);
 
-	if (!cv)
+	if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
 	    DIE(aTHX_ "No DB::DB routine defined");
 
 	if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
@@ -2068,10 +1989,8 @@ PP(pp_dbstate)
 	SPAGAIN;
 
 	if (CvISXSUB(cv)) {
-	    CvDEPTH(cv)++;
 	    PUSHMARK(SP);
 	    (void)(*CvXSUB(cv))(aTHX_ cv);
-	    CvDEPTH(cv)--;
 	    FREETMPS;
 	    LEAVE;
 	    return NORMAL;
@@ -2081,8 +2000,12 @@ PP(pp_dbstate)
 	    PUSHSUB_DB(cx);
 	    cx->blk_sub.retop = PL_op->op_next;
 	    CvDEPTH(cv)++;
+	    if (CvDEPTH(cv) >= 2) {
+		PERL_STACK_OVERFLOW_CHECK();
+		pad_push(CvPADLIST(cv), CvDEPTH(cv));
+	    }
 	    SAVECOMPPAD();
-	    PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+	    PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
 	    RETURNOP(CvSTART(cv));
 	}
     }
@@ -2132,7 +2055,7 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla
 PP(pp_enter)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
 
     ENTER_with_name("block");
@@ -2146,7 +2069,7 @@ PP(pp_enter)
 PP(pp_leave)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
@@ -2172,7 +2095,7 @@ PP(pp_leave)
 PP(pp_enteriter)
 {
     dVAR; dSP; dMARK;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
     void *itervar; /* location of the iteration variable */
     U8 cxtype = CXt_LOOP_FOR;
@@ -2295,7 +2218,7 @@ PP(pp_enteriter)
 PP(pp_enterloop)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
 
     ENTER_with_name("loop1");
@@ -2311,7 +2234,7 @@ PP(pp_enterloop)
 PP(pp_leaveloop)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -2448,7 +2371,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
 PP(pp_return)
 {
     dVAR; dSP; dMARK;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     bool popsub2 = FALSE;
     bool clear_errsv = FALSE;
     bool lval = FALSE;
@@ -2592,7 +2515,7 @@ PP(pp_leavesublv)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV *sv;
 
     if (CxMULTICALL(&cxstack[cxstack_ix]))
@@ -2614,38 +2537,60 @@ PP(pp_leavesublv)
     return cx->blk_sub.retop;
 }
 
-PP(pp_last)
+static I32
+S_unwind_loop(pTHX_ const char * const opname)
 {
-    dVAR; dSP;
+    dVAR;
     I32 cxix;
-    register PERL_CONTEXT *cx;
-    I32 pop2 = 0;
-    I32 gimme;
-    I32 optype;
-    OP *nextop = NULL;
-    SV **newsp;
-    PMOP *newpm;
-    SV **mark;
-    SV *sv = NULL;
-
-
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE(aTHX_ "Can't \"last\" outside a loop block");
+	    /* diag_listed_as: Can't "last" outside a loop block */
+	    Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
     }
     else {
-        cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
-                           (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
+	dSP;
+	STRLEN label_len;
+	const char * const label =
+	    PL_op->op_flags & OPf_STACKED
+		? SvPV(TOPs,label_len)
+		: (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
+	const U32 label_flags =
+	    PL_op->op_flags & OPf_STACKED
+		? SvUTF8(POPs)
+		: (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
+	PUTBACK;
+        cxix = dopoptolabel(label, label_len, label_flags);
 	if (cxix < 0)
-	    DIE(aTHX_ "Label not found for \"last %"SVf"\"",
-                                        SVfARG(newSVpvn_flags(cPVOP->op_pv,
-                                                    strlen(cPVOP->op_pv),
-                                                    ((cPVOP->op_private & OPpPV_IS_UTF8)
-                                                    ? SVf_UTF8 : 0) | SVs_TEMP)));
+	    /* diag_listed_as: Label not found for "last %s" */
+	    Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
+				       opname,
+                                       SVfARG(PL_op->op_flags & OPf_STACKED
+                                              && !SvGMAGICAL(TOPp1s)
+                                              ? TOPp1s
+                                              : newSVpvn_flags(label,
+                                                    label_len,
+                                                    label_flags | SVs_TEMP)));
     }
     if (cxix < cxstack_ix)
 	dounwind(cxix);
+    return cxix;
+}
+
+PP(pp_last)
+{
+    dVAR;
+    PERL_CONTEXT *cx;
+    I32 pop2 = 0;
+    I32 gimme;
+    I32 optype;
+    OP *nextop = NULL;
+    SV **newsp;
+    PMOP *newpm;
+    SV **mark;
+    SV *sv = NULL;
+
+    S_unwind_loop(aTHX_ "last");
 
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
@@ -2676,9 +2621,8 @@ PP(pp_last)
     }
 
     TAINT_NOT;
-    SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
+    PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
 				pop2 == CXt_SUB ? SVs_TEMP : 0);
-    PUTBACK;
 
     LEAVE;
     cxstack_ix--;
@@ -2706,31 +2650,13 @@ PP(pp_last)
 PP(pp_next)
 {
     dVAR;
-    I32 cxix;
-    register PERL_CONTEXT *cx;
-    I32 inner;
+    PERL_CONTEXT *cx;
+    const I32 inner = PL_scopestack_ix;
 
-    if (PL_op->op_flags & OPf_SPECIAL) {
-	cxix = dopoptoloop(cxstack_ix);
-	if (cxix < 0)
-	    DIE(aTHX_ "Can't \"next\" outside a loop block");
-    }
-    else {
-	cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
-                           (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
- 	if (cxix < 0)
-	    DIE(aTHX_ "Label not found for \"next %"SVf"\"",
-                                        SVfARG(newSVpvn_flags(cPVOP->op_pv, 
-                                                    strlen(cPVOP->op_pv),
-                                                    ((cPVOP->op_private & OPpPV_IS_UTF8)
-                                                    ? SVf_UTF8 : 0) | SVs_TEMP)));
-    }
-    if (cxix < cxstack_ix)
-	dounwind(cxix);
+    S_unwind_loop(aTHX_ "next");
 
     /* clear off anything above the scope we're re-entering, but
      * save the rest until after a possible continue block */
-    inner = PL_scopestack_ix;
     TOPBLOCK(cx);
     if (PL_scopestack_ix < inner)
 	leave_scope(PL_scopestack[PL_scopestack_ix]);
@@ -2741,30 +2667,11 @@ PP(pp_next)
 PP(pp_redo)
 {
     dVAR;
-    I32 cxix;
-    register PERL_CONTEXT *cx;
+    const I32 cxix = S_unwind_loop(aTHX_ "redo");
+    PERL_CONTEXT *cx;
     I32 oldsave;
-    OP* redo_op;
-
-    if (PL_op->op_flags & OPf_SPECIAL) {
-	cxix = dopoptoloop(cxstack_ix);
-	if (cxix < 0)
-	    DIE(aTHX_ "Can't \"redo\" outside a loop block");
-    }
-    else {
-	cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
-                           (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
- 	if (cxix < 0)
-	    DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
-                                        SVfARG(newSVpvn_flags(cPVOP->op_pv,
-                                                    strlen(cPVOP->op_pv),
-                                                    ((cPVOP->op_private & OPpPV_IS_UTF8)
-                                                    ? SVf_UTF8 : 0) | SVs_TEMP)));
-    }
-    if (cxix < cxstack_ix)
-	dounwind(cxix);
+    OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
 
-    redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
     if (redo_op->op_type == OP_ENTER) {
 	/* pop one less context to avoid $x being freed in while (my $x..) */
 	cxstack_ix++;
@@ -2785,7 +2692,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
 {
     dVAR;
     OP **ops = opstack;
-    static const char too_deep[] = "Target of goto is too deeply nested";
+    static const char* const too_deep = "Target of goto is too deeply nested";
 
     PERL_ARGS_ASSERT_DOFINDLABEL;
 
@@ -2850,27 +2757,26 @@ PP(pp_goto)
     dVAR; dSP;
     OP *retop = NULL;
     I32 ix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
 #define GOTO_DEPTH 64
     OP *enterops[GOTO_DEPTH];
     const char *label = NULL;
     STRLEN label_len = 0;
     U32 label_flags = 0;
     const bool do_dump = (PL_op->op_type == OP_DUMP);
-    static const char must_have_label[] = "goto must have label";
+    static const char* const must_have_label = "goto must have label";
 
     if (PL_op->op_flags & OPf_STACKED) {
 	SV * const sv = POPs;
+	SvGETMAGIC(sv);
 
 	/* This egregious kludge implements goto &subroutine */
 	if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
 	    I32 cxix;
-	    register PERL_CONTEXT *cx;
+	    PERL_CONTEXT *cx;
 	    CV *cv = MUTABLE_CV(SvRV(sv));
-	    SV** mark;
-	    I32 items = 0;
+	    AV *arg = GvAV(PL_defgv);
 	    I32 oldsave;
-	    bool reified = 0;
 
 	retry:
 	    if (!CvROOT(cv) && !CvXSUB(cv)) {
@@ -2898,13 +2804,17 @@ PP(pp_goto)
 	    FREETMPS;
 	    cxix = dopoptosub(cxstack_ix);
 	    if (cxix < 0)
+	    {
+		SvREFCNT_dec(cv);
 		DIE(aTHX_ "Can't goto subroutine outside a subroutine");
+	    }
 	    if (cxix < cxstack_ix)
 		dounwind(cxix);
 	    TOPBLOCK(cx);
 	    SPAGAIN;
 	    /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
 	    if (CxTYPE(cx) == CXt_EVAL) {
+		SvREFCNT_dec(cv);
 		if (CxREALEVAL(cx))
 		/* diag_listed_as: Can't goto subroutine from an eval-%s */
 		    DIE(aTHX_ "Can't goto subroutine from an eval-string");
@@ -2913,35 +2823,25 @@ PP(pp_goto)
 		    DIE(aTHX_ "Can't goto subroutine from an eval-block");
 	    }
 	    else if (CxMULTICALL(cx))
+	    {
+		SvREFCNT_dec(cv);
 		DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
+	    }
 	    if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
-		/* put @_ back onto stack */
 		AV* av = cx->blk_sub.argarray;
 
-		items = AvFILLp(av) + 1;
-		EXTEND(SP, items+1); /* @_ could have been extended. */
-		Copy(AvARRAY(av), SP + 1, items, SV*);
-		SvREFCNT_dec(GvAV(PL_defgv));
-		GvAV(PL_defgv) = cx->blk_sub.savearray;
-		CLEAR_ARGARRAY(av);
-		/* abandon @_ if it got reified */
-		if (AvREAL(av)) {
-		    reified = 1;
+		/* abandon the original @_ if it got reified or if it is
+		   the same as the current @_ */
+		if (AvREAL(av) || av == arg) {
 		    SvREFCNT_dec(av);
 		    av = newAV();
-		    av_extend(av, items-1);
 		    AvREIFY_only(av);
 		    PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
 		}
+		else CLEAR_ARGARRAY(av);
 	    }
-	    else if (CvISXSUB(cv)) {	/* put GvAV(defgv) back onto stack */
-		AV* const av = GvAV(PL_defgv);
-		items = AvFILLp(av) + 1;
-		EXTEND(SP, items+1); /* @_ could have been extended. */
-		Copy(AvARRAY(av), SP + 1, items, SV*);
-	    }
-	    mark = SP;
-	    SP += items;
+	    /* We donate this refcount later to the callee’s pad. */
+	    SvREFCNT_inc_simple_void(arg);
 	    if (CxTYPE(cx) == CXt_SUB &&
 		!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
 		SvREFCNT_dec(cx->blk_sub.cv);
@@ -2952,6 +2852,7 @@ PP(pp_goto)
 	     * our precious cv.  See bug #99850. */
 	    if (!CvROOT(cv) && !CvXSUB(cv)) {
 		const GV * const gv = CvGV(cv);
+		SvREFCNT_dec(arg);
 		if (gv) {
 		    SV * const tmpstr = sv_newmortal();
 		    gv_efullname3(tmpstr, gv, NULL);
@@ -2966,12 +2867,30 @@ PP(pp_goto)
 	    SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
 	    if (CvISXSUB(cv)) {
 		OP* const retop = cx->blk_sub.retop;
-		SV **newsp PERL_UNUSED_DECL;
-		I32 gimme PERL_UNUSED_DECL;
-		if (reified) {
+		SV **newsp;
+		I32 gimme;
+		const SSize_t items = AvFILLp(arg) + 1;
+		SV** mark;
+
+                PERL_UNUSED_VAR(newsp);
+                PERL_UNUSED_VAR(gimme);
+
+		/* put GvAV(defgv) back onto stack */
+		EXTEND(SP, items+1); /* @_ could have been extended. */
+		Copy(AvARRAY(arg), SP + 1, items, SV*);
+		mark = SP;
+		SP += items;
+		if (AvREAL(arg)) {
 		    I32 index;
 		    for (index=0; index<items; index++)
-			sv_2mortal(SP[-index]);
+			SvREFCNT_inc_void(sv_2mortal(SP[-index]));
+		}
+		SvREFCNT_dec(arg);
+		if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
+		    /* Restore old @_ */
+		    arg = GvAV(PL_defgv);
+		    GvAV(PL_defgv) = cx->blk_sub.savearray;
+		    SvREFCNT_dec(arg);
 		}
 
 		/* XS subs don't have a CxSUB, so pop it */
@@ -2984,12 +2903,7 @@ PP(pp_goto)
 		return retop;
 	    }
 	    else {
-		AV* const padlist = CvPADLIST(cv);
-		if (CxTYPE(cx) == CXt_EVAL) {
-		    PL_in_eval = CxOLD_IN_EVAL(cx);
-		    PL_eval_root = cx->blk_eval.old_eval_root;
-		    cx->cx_type = CXt_SUB;
-		}
+		PADLIST * const padlist = CvPADLIST(cv);
 		cx->blk_sub.cv = cv;
 		cx->blk_sub.olddepth = CvDEPTH(cv);
 
@@ -3006,41 +2920,26 @@ PP(pp_goto)
 		PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
 		if (CxHASARGS(cx))
 		{
-		    AV *const av = MUTABLE_AV(PAD_SVl(0));
-
-		    cx->blk_sub.savearray = GvAV(PL_defgv);
-		    GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
 		    CX_CURPAD_SAVE(cx->blk_sub);
-		    cx->blk_sub.argarray = av;
 
-		    if (items >= AvMAX(av) + 1) {
-			SV **ary = AvALLOC(av);
-			if (AvARRAY(av) != ary) {
-			    AvMAX(av) += AvARRAY(av) - AvALLOC(av);
-			    AvARRAY(av) = ary;
-			}
-			if (items >= AvMAX(av) + 1) {
-			    AvMAX(av) = items - 1;
-			    Renew(ary,items+1,SV*);
-			    AvALLOC(av) = ary;
-			    AvARRAY(av) = ary;
-			}
-		    }
-		    ++mark;
-		    Copy(mark,AvARRAY(av),items,SV*);
-		    AvFILLp(av) = items - 1;
-		    assert(!AvREAL(av));
-		    if (reified) {
-			/* transfer 'ownership' of refcnts to new @_ */
-			AvREAL_on(av);
-			AvREIFY_off(av);
-		    }
-		    while (items--) {
-			if (*mark)
-			    SvTEMP_off(*mark);
-			mark++;
+		    /* cx->blk_sub.argarray has no reference count, so we
+		       need something to hang on to our argument array so
+		       that cx->blk_sub.argarray does not end up pointing
+		       to freed memory as the result of undef *_.  So put
+		       it in the callee’s pad, donating our refer-
+		       ence count. */
+		    SvREFCNT_dec(PAD_SVl(0));
+		    PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+
+		    /* GvAV(PL_defgv) might have been modified on scope
+		       exit, so restore it. */
+		    if (arg != GvAV(PL_defgv)) {
+			AV * const av = GvAV(PL_defgv);
+			GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
+			SvREFCNT_dec(av);
 		    }
 		}
+		else SvREFCNT_dec(arg);
 		if (PERLDB_SUB) {	/* Checking curstash breaks DProf. */
 		    Perl_get_db_sub(aTHX_ NULL, cv);
 		    if (PERLDB_GOTO) {
@@ -3056,7 +2955,7 @@ PP(pp_goto)
 	    }
 	}
 	else {
-	    label       = SvPV_const(sv, label_len);
+	    label       = SvPV_nomg_const(sv, label_len);
             label_flags = SvUTF8(sv);
 	}
     }
@@ -3317,149 +3216,13 @@ S_docatch(pTHX_ OP *o)
 	JMPENV_POP;
 	PL_op = oldop;
 	JMPENV_JUMP(ret);
-	/* NOTREACHED */
+	assert(0); /* NOTREACHED */
     }
     JMPENV_POP;
     PL_op = oldop;
     return NULL;
 }
 
-/* James Bond: Do you expect me to talk?
-   Auric Goldfinger: No, Mr. Bond. I expect you to die.
-
-   This code is an ugly hack, doesn't work with lexicals in subroutines that are
-   called more than once, and is only used by regcomp.c, for (?{}) blocks.
-
-   Currently it is not used outside the core code. Best if it stays that way.
-
-   Hence it's now deprecated, and will be removed.
-*/
-OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
-/* sv Text to convert to OP tree. */
-/* startop op_free() this to undo. */
-/* code Short string id of the caller. */
-{
-    PERL_ARGS_ASSERT_SV_COMPILE_2OP;
-    return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
-}
-
-/* Don't use this. It will go away without warning once the regexp engine is
-   refactored not to use it.  */
-OP *
-Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
-			      PAD **padp)
-{
-    dVAR; dSP;				/* Make POPBLOCK work. */
-    PERL_CONTEXT *cx;
-    SV **newsp;
-    I32 gimme = G_VOID;
-    I32 optype;
-    OP dummy;
-    char tbuf[TYPE_DIGITS(long) + 12 + 10];
-    char *tmpbuf = tbuf;
-    char *safestr;
-    int runtime;
-    CV* runcv = NULL;	/* initialise to avoid compiler warnings */
-    STRLEN len;
-    bool need_catch;
-
-    PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
-
-    ENTER_with_name("eval");
-    lex_start(sv, NULL, LEX_START_SAME_FILTER);
-    SAVETMPS;
-    /* switch to eval mode */
-
-    if (IN_PERL_COMPILETIME) {
-	SAVECOPSTASH_FREE(&PL_compiling);
-	CopSTASH_set(&PL_compiling, PL_curstash);
-    }
-    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
-	SV * const sv = sv_newmortal();
-	Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
-		       code, (unsigned long)++PL_evalseq,
-		       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
-	tmpbuf = SvPVX(sv);
-	len = SvCUR(sv);
-    }
-    else
-	len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
-			  (unsigned long)++PL_evalseq);
-    SAVECOPFILE_FREE(&PL_compiling);
-    CopFILE_set(&PL_compiling, tmpbuf+2);
-    SAVECOPLINE(&PL_compiling);
-    CopLINE_set(&PL_compiling, 1);
-    /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
-       deleting the eval's FILEGV from the stash before gv_check() runs
-       (i.e. before run-time proper). To work around the coredump that
-       ensues, we always turn GvMULTI_on for any globals that were
-       introduced within evals. See force_ident(). GSAR 96-10-12 */
-    safestr = savepvn(tmpbuf, len);
-    SAVEDELETE(PL_defstash, safestr, len);
-    SAVEHINTS();
-#ifdef OP_IN_REGISTER
-    PL_opsave = op;
-#else
-    SAVEVPTR(PL_op);
-#endif
-
-    /* we get here either during compilation, or via pp_regcomp at runtime */
-    runtime = IN_PERL_RUNTIME;
-    if (runtime)
-    {
-	runcv = find_runcv(NULL);
-
-	/* At run time, we have to fetch the hints from PL_curcop. */
-	PL_hints = PL_curcop->cop_hints;
-	if (PL_hints & HINT_LOCALIZE_HH) {
-	    /* SAVEHINTS created a new HV in PL_hintgv, which we
-	       need to GC */
-	    SvREFCNT_dec(GvHV(PL_hintgv));
-	    GvHV(PL_hintgv) =
-	     refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
-	    hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
-	}
-	SAVECOMPILEWARNINGS();
-	PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
-	cophh_free(CopHINTHASH_get(&PL_compiling));
-	/* XXX Does this need to avoid copying a label? */
-	PL_compiling.cop_hints_hash
-	 = cophh_copy(PL_curcop->cop_hints_hash);
-    }
-
-    PL_op = &dummy;
-    PL_op->op_type = OP_ENTEREVAL;
-    PL_op->op_flags = 0;			/* Avoid uninit warning. */
-    PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
-    PUSHEVAL(cx, 0);
-    need_catch = CATCH_GET;
-    CATCH_SET(TRUE);
-
-    if (runtime)
-	(void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
-    else
-	(void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
-    CATCH_SET(need_catch);
-    POPBLOCK(cx,PL_curpm);
-    POPEVAL(cx);
-
-    (*startop)->op_type = OP_NULL;
-    (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
-    /* XXX DAPM do this properly one year */
-    *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
-    LEAVE_with_name("eval");
-    if (IN_PERL_COMPILETIME)
-	CopHINTS_set(&PL_compiling, PL_hints);
-#ifdef OP_IN_REGISTER
-    op = PL_opsave;
-#endif
-    PERL_UNUSED_VAR(newsp);
-    PERL_UNUSED_VAR(optype);
-
-    return PL_eval_start;
-}
-
 
 /*
 =for apidoc find_runcv
@@ -3476,8 +3239,16 @@ than in the scope of the debugger itself).
 CV*
 Perl_find_runcv(pTHX_ U32 *db_seqp)
 {
+    return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
+}
+
+/* If this becomes part of the API, it might need a better name. */
+CV *
+Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
+{
     dVAR;
     PERL_SI	 *si;
+    int		 level = 0;
 
     if (db_seqp)
 	*db_seqp = PL_curcop->cop_seq;
@@ -3485,20 +3256,34 @@ Perl_find_runcv(pTHX_ U32 *db_seqp)
         I32 ix;
 	for (ix = si->si_cxix; ix >= 0; ix--) {
 	    const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
+	    CV *cv = NULL;
 	    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
-		CV * const cv = cx->blk_sub.cv;
+		cv = cx->blk_sub.cv;
 		/* skip DB:: code */
 		if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
 		    *db_seqp = cx->blk_oldcop->cop_seq;
 		    continue;
 		}
-		return cv;
 	    }
 	    else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
-		return cx->blk_eval.cv;
+		cv = cx->blk_eval.cv;
+	    if (cv) {
+		switch (cond) {
+		case FIND_RUNCV_padid_eq:
+		    if (!CvPADLIST(cv)
+		     || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
+			continue;
+		    return cv;
+		case FIND_RUNCV_level_eq:
+		    if (level++ != arg) continue;
+		    /* GERONIMO! */
+		default:
+		    return cv;
+		}
+	    }
 	}
     }
-    return PL_main_cv;
+    return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
 }
 
 
@@ -3524,36 +3309,35 @@ S_try_yyparse(pTHX_ int gramtype)
     default:
 	JMPENV_POP;
 	JMPENV_JUMP(ret);
-	/* NOTREACHED */
+	assert(0); /* NOTREACHED */
     }
     JMPENV_POP;
     return ret;
 }
 
 
-/* Compile a require/do, an eval '', or a /(?{...})/.
- * In the last case, startop is non-null, and contains the address of
- * a pointer that should be set to the just-compiled code.
+/* Compile a require/do or an eval ''.
+ *
  * outside is the lexically enclosing CV (if any) that invoked us.
+ * seq     is the current COP scope value.
+ * hh      is the saved hints hash, if any.
+ *
  * Returns a bool indicating whether the compile was successful; if so,
- * PL_eval_start contains the first op of the compiled ocde; otherwise,
- * pushes undef (also croaks if startop != NULL).
- */
-
-/* This function is called from three places, sv_compile_2op, pp_require
- * and pp_entereval.  These can be distinguished as follows:
- *    sv_compile_2op - startop is non-null
- *    pp_require     - startop is null; saveop is not entereval
- *    pp_entereval   - startop is null; saveop is entereval
+ * PL_eval_start contains the first op of the compiled code; otherwise,
+ * pushes undef.
+ *
+ * This function is called from two places: pp_require and pp_entereval.
+ * These can be distinguished by whether PL_op is entereval.
  */
 
 STATIC bool
-S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
+S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
 {
     dVAR; dSP;
     OP * const saveop = PL_op;
+    bool clear_hints = saveop->op_type != OP_ENTEREVAL;
     COP * const oldcurcop = PL_curcop;
-    bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+    bool in_require = (saveop->op_type == OP_REQUIRE);
     int yystatus;
     CV *evalcv;
 
@@ -3600,7 +3384,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
     PL_madskills = 0;
 #endif
 
-    if (!startop) ENTER_with_name("evalcomp");
+    ENTER_with_name("evalcomp");
     SAVESPTR(PL_compcv);
     PL_compcv = evalcv;
 
@@ -3608,52 +3392,49 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
 
     PL_eval_root = NULL;
     PL_curcop = &PL_compiling;
-    if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
+    if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
 	PL_in_eval |= EVAL_KEEPERR;
     else
 	CLEAR_ERRSV();
 
-    if (!startop) {
-	bool clear_hints = saveop->op_type != OP_ENTEREVAL;
-	SAVEHINTS();
-	if (clear_hints) {
-	    PL_hints = 0;
-	    hv_clear(GvHV(PL_hintgv));
-	}
-	else {
-	    PL_hints = saveop->op_private & OPpEVAL_COPHH
-			 ? oldcurcop->cop_hints : saveop->op_targ;
-	    if (hh) {
-		/* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
-		SvREFCNT_dec(GvHV(PL_hintgv));
-		GvHV(PL_hintgv) = hh;
-	    }
-	}
-	SAVECOMPILEWARNINGS();
-	if (clear_hints) {
-	    if (PL_dowarn & G_WARN_ALL_ON)
-	        PL_compiling.cop_warnings = pWARN_ALL ;
-	    else if (PL_dowarn & G_WARN_ALL_OFF)
-	        PL_compiling.cop_warnings = pWARN_NONE ;
-	    else
-	        PL_compiling.cop_warnings = pWARN_STD ;
+    SAVEHINTS();
+    if (clear_hints) {
+	PL_hints = 0;
+	hv_clear(GvHV(PL_hintgv));
+    }
+    else {
+	PL_hints = saveop->op_private & OPpEVAL_COPHH
+		     ? oldcurcop->cop_hints : saveop->op_targ;
+	if (hh) {
+	    /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+	    SvREFCNT_dec(GvHV(PL_hintgv));
+	    GvHV(PL_hintgv) = hh;
 	}
-	else {
-	    PL_compiling.cop_warnings =
-		DUP_WARNINGS(oldcurcop->cop_warnings);
-	    cophh_free(CopHINTHASH_get(&PL_compiling));
-	    if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
-		/* The label, if present, is the first entry on the chain. So rather
-		   than writing a blank label in front of it (which involves an
-		   allocation), just use the next entry in the chain.  */
-		PL_compiling.cop_hints_hash
-		    = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
-		/* Check the assumption that this removed the label.  */
-		assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
-	    }
-	    else
-		PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
+    }
+    SAVECOMPILEWARNINGS();
+    if (clear_hints) {
+	if (PL_dowarn & G_WARN_ALL_ON)
+	    PL_compiling.cop_warnings = pWARN_ALL ;
+	else if (PL_dowarn & G_WARN_ALL_OFF)
+	    PL_compiling.cop_warnings = pWARN_NONE ;
+	else
+	    PL_compiling.cop_warnings = pWARN_STD ;
+    }
+    else {
+	PL_compiling.cop_warnings =
+	    DUP_WARNINGS(oldcurcop->cop_warnings);
+	cophh_free(CopHINTHASH_get(&PL_compiling));
+	if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
+	    /* The label, if present, is the first entry on the chain. So rather
+	       than writing a blank label in front of it (which involves an
+	       allocation), just use the next entry in the chain.  */
+	    PL_compiling.cop_hints_hash
+		= cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
+	    /* Check the assumption that this removed the label.  */
+	    assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
 	}
+	else
+	    PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
     }
 
     CALL_BLOCK_HOOKS(bhk_eval, saveop);
@@ -3668,6 +3449,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
 	PERL_CONTEXT *cx;
 	I32 optype;			/* Used by POPEVAL. */
 	SV *namesv;
+        SV *errsv = NULL;
 
 	cx = NULL;
 	namesv = NULL;
@@ -3683,15 +3465,14 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
 		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;
-	    }
+	    POPBLOCK(cx,PL_curpm);
+	    POPEVAL(cx);
+	    namesv = cx->blk_eval.old_namesv;
 	    /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
 	    LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
 	}
 
+	errsv = ERRSV;
 	if (in_require) {
 	    if (!cx) {
 		/* If cx is still NULL, it means that we didn't go in the
@@ -3705,40 +3486,30 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
 			   &PL_sv_undef, 0);
 	    Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
-		       SVfARG(ERRSV
-                                ? ERRSV
-                                : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
-	}
-	else if (startop) {
-	    if (yystatus != 3) {
-		POPBLOCK(cx,PL_curpm);
-		POPEVAL(cx);
-	    }
-	    Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
-		       SVfARG(ERRSV
-                                ? ERRSV
+		       SVfARG(errsv
+                                ? errsv
                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
 	}
 	else {
-	    if (!*(SvPVx_nolen_const(ERRSV))) {
-	        sv_setpvs(ERRSV, "Compilation error");
+	    if (!*(SvPV_nolen_const(errsv))) {
+	        sv_setpvs(errsv, "Compilation error");
 	    }
 	}
 	if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
 	PUTBACK;
 	return FALSE;
     }
-    else if (!startop) LEAVE_with_name("evalcomp");
+    else
+	LEAVE_with_name("evalcomp");
+
     CopLINE_set(&PL_compiling, 0);
-    if (startop) {
-	*startop = PL_eval_root;
-    } else
-	SAVEFREEOP(PL_eval_root);
+    SAVEFREEOP(PL_eval_root);
+    cv_forget_slab(evalcv);
 
     DEBUG_x(dump_eval());
 
     /* Register with debugger: */
-    if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
+    if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
 	CV * const cv = get_cvs("DB::postponed", 0);
 	if (cv) {
 	    dSP;
@@ -3814,7 +3585,7 @@ S_doopen_pm(pTHX_ SV *name)
 PP(pp_require)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV *sv;
     const char *name;
     STRLEN len;
@@ -3822,6 +3593,9 @@ PP(pp_require)
     STRLEN unixlen;
 #ifdef VMS
     int vms_unixname = 0;
+    char *unixnamebuf;
+    char *unixdir;
+    char *unixdirbuf;
 #endif
     const char *tryname = NULL;
     SV *namesv = NULL;
@@ -3834,11 +3608,12 @@ PP(pp_require)
     SV *hook_sv = NULL;
     SV *encoding;
     OP *op;
+    int saved_errno;
 
     sv = POPs;
     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
 	sv = sv_2mortal(new_version(sv));
-	if (!sv_derived_from(PL_patchlevel, "version"))
+	if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
 	    upg_version(PL_patchlevel, TRUE);
 	if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
 	    if ( vcmp(sv,PL_patchlevel) <= 0 )
@@ -3906,7 +3681,9 @@ PP(pp_require)
      * To prevent this, the key must be stored in UNIX format if the VMS
      * name can be translated to UNIX.
      */
-    if ((unixname = tounixspec(name, NULL)) != NULL) {
+    
+    if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
+        && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
 	unixlen = strlen(unixname);
 	vms_unixname = 1;
     }
@@ -3931,6 +3708,8 @@ PP(pp_require)
 	}
     }
 
+    LOADING_FILE_PROBE(unixname);
+
     /* prepare to compile file */
 
     if (path_is_absolute(name)) {
@@ -3938,7 +3717,7 @@ PP(pp_require)
 	tryname = name;
 	tryrsfp = doopen_pm(sv);
     }
-    if (!tryrsfp) {
+    if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
 	AV * const ar = GvAVn(PL_incgv);
 	I32 i;
 #ifdef VMS
@@ -4081,8 +3860,8 @@ PP(pp_require)
 		    }
 
 #ifdef VMS
-		    char *unixdir;
-		    if ((unixdir = tounixpath(dir, NULL)) == NULL)
+		    if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
+			|| ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
 			continue;
 		    sv_setpv(namesv, unixdir);
 		    sv_catpv(namesv, unixname);
@@ -4130,45 +3909,66 @@ PP(pp_require)
 			}
 			break;
 		    }
-		    else if (errno == EMFILE)
-			/* no point in trying other paths if out of handles */
-			break;
+                    else if (errno == EMFILE || errno == EACCES) {
+                        /* no point in trying other paths if out of handles;
+                         * on the other hand, if we couldn't open one of the
+                         * files, then going on with the search could lead to
+                         * unexpected results; see perl #113422
+                         */
+                        break;
+                    }
 		  }
 		}
 	    }
 	}
     }
+    saved_errno = errno; /* sv_2mortal can realloc things */
     sv_2mortal(namesv);
     if (!tryrsfp) {
 	if (PL_op->op_type == OP_REQUIRE) {
-	    if(errno == EMFILE) {
+	    if(saved_errno == EMFILE || saved_errno == EACCES) {
 		/* diag_listed_as: Can't locate %s */
-		DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
+		DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
 	    } else {
 	        if (namesv) {			/* did we lookup @INC? */
 		    AV * const ar = GvAVn(PL_incgv);
 		    I32 i;
+		    SV *const msg = newSVpvs_flags("", SVs_TEMP);
 		    SV *const inc = newSVpvs_flags("", SVs_TEMP);
 		    for (i = 0; i <= AvFILL(ar); i++) {
 			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_catpvn(msg, "::", 2);
+			    }
+			    else {
+				sv_catpvn(msg, c, 1);
+			    }
+			}
+			sv_catpv(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 (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
+			sv_catpv(msg, " (did you run h2ph?)");
+		    }
 
 		    /* 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
-			);
+			"Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
+			name, msg, inc);
 		}
 	    }
 	    DIE(aTHX_ "Can't locate %s", name);
 	}
 
+	CLEAR_ERRSV();
 	RETPUSHUNDEF;
     }
     else
@@ -4218,7 +4018,7 @@ PP(pp_require)
     encoding = PL_encoding;
     PL_encoding = NULL;
 
-    if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
+    if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
 	op = DOCATCH(PL_eval_start);
     else
 	op = PL_op->op_next;
@@ -4226,6 +4026,8 @@ PP(pp_require)
     /* Restore encoding. */
     PL_encoding = encoding;
 
+    LOADED_FILE_PROBE(unixname);
+
     return op;
 }
 
@@ -4245,7 +4047,7 @@ PP(pp_hintseval)
 PP(pp_entereval)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV *sv;
     const I32 gimme = GIMME_V;
     const U32 was = PL_breakable_sub_gen;
@@ -4346,7 +4148,7 @@ PP(pp_entereval)
     
     PUTBACK;
 
-    if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
+    if (doeval(gimme, runcv, seq, saved_hh)) {
 	if (was != PL_breakable_sub_gen /* Some subs defined here. */
 	    ? (PERLDB_LINE || PERLDB_SAVESRC)
 	    :  PERLDB_SAVESRC_NOSUBS) {
@@ -4376,7 +4178,7 @@ PP(pp_leaveeval)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     OP *retop;
     const U8 save_flags = PL_op -> op_flags;
     I32 optype;
@@ -4430,7 +4232,7 @@ Perl_delete_eval_scope(pTHX)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 optype;
 	
     POPBLOCK(cx,newpm);
@@ -4481,7 +4283,7 @@ PP(pp_leavetry)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 optype;
 
     PERL_ASYNC_CHECK();
@@ -4501,14 +4303,21 @@ PP(pp_leavetry)
 PP(pp_entergiven)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
     
     ENTER_with_name("given");
     SAVETMPS;
 
-    SAVECLEARSV(PAD_SVl(PL_op->op_targ));
-    sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
+    if (PL_op->op_targ) {
+	SAVEPADSVANDMORTALIZE(PL_op->op_targ);
+	SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
+	PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
+    }
+    else {
+	SAVE_DEFSV;
+	DEFSV_set(POPs);
+    }
 
     PUSHBLOCK(cx, CXt_GIVEN, SP);
     PUSHGIVEN(cx);
@@ -4519,7 +4328,7 @@ PP(pp_entergiven)
 PP(pp_leavegiven)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -5067,7 +4876,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 PP(pp_enterwhen)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
 
     /* This is essentially an optimization: if the match
@@ -5092,7 +4901,7 @@ PP(pp_leavewhen)
 {
     dVAR; dSP;
     I32 cxix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -5136,7 +4945,7 @@ PP(pp_continue)
 {
     dVAR; dSP;
     I32 cxix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -5164,7 +4973,7 @@ PP(pp_break)
 {
     dVAR;   
     I32 cxix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
 
     cxix = dopoptogiven(cxstack_ix); 
     if (cxix < 0)
@@ -5187,17 +4996,17 @@ static MAGIC *
 S_doparseform(pTHX_ SV *sv)
 {
     STRLEN len;
-    register char *s = SvPV(sv, len);
-    register char *send;
-    register char *base = NULL; /* start of current field */
-    register I32 skipspaces = 0; /* number of contiguous spaces seen */
+    char *s = SvPV(sv, len);
+    char *send;
+    char *base = NULL; /* start of current field */
+    I32 skipspaces = 0; /* number of contiguous spaces seen */
     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
     bool repeat    = FALSE; /* ~~ seen on this line */
     bool postspace = FALSE; /* a text field may need right padding */
     U32 *fops;
-    register U32 *fpc;
+    U32 *fpc;
     U32 *linepc = NULL;	    /* position of last FF_LINEMARK */
-    register I32 arg;
+    I32 arg;
     bool ischop;	    /* it's a ^ rather than a @ */
     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
@@ -5477,6 +5286,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
     char *prune_from = NULL;
     bool read_from_cache = FALSE;
     STRLEN umaxlen;
+    SV *err = NULL;
 
     PERL_ARGS_ASSERT_RUN_USER_FILTER;
 
@@ -5555,7 +5365,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	    PUSHs(filter_state);
 	}
 	PUTBACK;
-	count = call_sv(filter_sub, G_SCALAR);
+	count = call_sv(filter_sub, G_SCALAR|G_EVAL);
 	SPAGAIN;
 
 	if (count > 0) {
@@ -5563,6 +5373,11 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	    if (SvOK(out)) {
 		status = SvIV(out);
 	    }
+            else {
+                SV * const errsv = ERRSV;
+                if (SvTRUE_NN(errsv))
+                    err = newSVsv(errsv);
+            }
 	}
 
 	PUTBACK;
@@ -5570,7 +5385,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	LEAVE_with_name("call_filter_sub");
     }
 
-    if(SvOK(upstream)) {
+    if (SvIsCOW(upstream)) sv_force_normal(upstream);
+    if(!err && SvOK(upstream)) {
 	got_p = SvPV(upstream, got_len);
 	if (umaxlen) {
 	    if (got_len > umaxlen) {
@@ -5584,7 +5400,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	    }
 	}
     }
-    if (prune_from) {
+    if (!err && prune_from) {
 	/* Oh. Too long. Stuff some in our cache.  */
 	STRLEN cached_len = got_p + got_len - prune_from;
 	SV *const cache = datasv;
@@ -5613,7 +5429,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        have touched the SV upstream, so it may be undefined.  If we naively
        concatenate it then we get a warning about use of uninitialised value.
     */
-    if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+    if (!err && upstream != buf_sv &&
+        (SvOK(upstream) || SvGMAGICAL(upstream))) {
 	sv_catsv(buf_sv, upstream);
     }
 
@@ -5629,6 +5446,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	}
 	filter_del(S_run_user_filter);
     }
+
+    if (err)
+        croak_sv(err);
+
     if (status == 0 && read_from_cache) {
 	/* If we read some data from the cache (and by getting here it implies
 	   that we emptied the cache) then we aren't yet at EOF, and mustn't
@@ -5668,8 +5489,8 @@ S_path_is_absolute(const char *name)
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */