X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7347ee5481c77d2fdb023e0a1c19943d039ecc86..d7128eb1c501bb76ea7507ab3a119ad7c1150820:/pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index bde8d29..a38b9c1 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -781,7 +781,8 @@ PP(pp_formline)
 			 * for safety */
 			grow = linemax;
 			while (linemark--)
-			    s += UTF8SKIP(s);
+			    s += UTF8_SAFE_SKIP(s,
+                                            (U8 *) SvEND(PL_formtarget));
 			linemark = s - (U8*)SvPVX(PL_formtarget);
 		    }
 		    /* Easy. They agree.  */
@@ -2644,6 +2645,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)
 {
@@ -2662,12 +2666,30 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
 	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) {
@@ -2690,19 +2712,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;
@@ -2716,6 +2746,9 @@ 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");
@@ -2732,7 +2765,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;
@@ -3069,7 +3101,10 @@ PP(pp_goto)
 	}
 
 	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");
 	}
@@ -3088,10 +3123,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];
 		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;
@@ -4179,7 +4219,7 @@ S_require_file(pTHX_ SV *sv)
                         }
 
                         if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
-                            sv_catpv(msg, " (you may need to install the ");
+                            sv_catpvs(msg, " (you may need to install the ");
                             for (c = name; c < e; c++) {
                                 if (*c == '/') {
                                     sv_catpvs(msg, "::");
@@ -4188,14 +4228,14 @@ S_require_file(pTHX_ SV *sv)
                                     sv_catpvn(msg, c, 1);
                                 }
                             }
-                            sv_catpv(msg, " module)");
+                            sv_catpvs(msg, " module)");
                         }
 		    }
 		    else if (memENDs(name, len, ".h")) {
-			sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
+			sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
 		    }
 		    else if (memENDs(name, len, ".ph")) {
-			sv_catpv(msg, " (did you run h2ph?)");
+			sv_catpvs(msg, " (did you run h2ph?)");
 		    }
 
 		    /* diag_listed_as: Can't locate %s */
@@ -5187,8 +5227,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);