Typemap.xs: avoid leak

[perl5.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index f5ae9e3..a38b9c1 100644 (file)
--- 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.  */
@@ -868,9 +869,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();
@@ -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)
 {
@@ -2658,15 +2662,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) {
@@ -2689,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;
@@ -2715,9 +2746,15 @@ 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() */
@@ -2728,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;
@@ -3065,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");
        }
@@ -3084,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;
@@ -4175,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, "::");
@@ -4184,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 */
@@ -5183,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);