[perl #113684] Make redo/last/next/dump accept expr

These functions have been allowing arbitrary expressions, but would
treat anything that did not resolve to a const op as the empty string.
Not only were arguments swallowed up without warning, but constant
folding could change the behaviour.  Computed labels are allowed for
goto, and there is no reason to disallow them for these other ops.
This can also come in handy for certain types of code generators.

In the process of modifying pp functions to accept arbitrary labels,
I noticed that the label and loop-popping code was identical in three
functions, so I moved it out into a separate static function, to make
the changes easier.

I also had to reorder newLOOPEX significantly, because code under the
goto branch needed to a apply to last, and vice versa.  Using multiple
gotos to switch between the branches created too much of a mess.

I also eliminated the use of SP from pp_last, to avoid copying the
value back and forth between SP and PL_stack_sp.

diff --git a/op.c b/op.c
index 8a45735..d24ea4d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6385,37 +6385,41 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 
     if (type != OP_GOTO) {
        /* "last()" means "last" */
-       if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
+       if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
            o = newOP(type, OPf_SPECIAL);
-       else {
-         const_label:
-           o = newPVOP(type,
-                        label->op_type == OP_CONST
-                            ? SvUTF8(((SVOP*)label)->op_sv)
-                            : 0,
-                        savesharedpv(label->op_type == OP_CONST
-                               ? SvPV_nolen_const(((SVOP*)label)->op_sv)
-                               : ""));
+           goto free_label;
        }
-#ifdef PERL_MAD
-       op_getmad(label,o,'L');
-#else
-       op_free(label);
-#endif
     }
     else {
        /* Check whether it's going to be a goto &function */
        if (label->op_type == OP_ENTERSUB
                && !(label->op_flags & OPf_STACKED))
            label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
-       else if (label->op_type == OP_CONST) {
+    }
+
+    /* Check for a constant argument */
+    if (label->op_type == OP_CONST) {
            SV * const sv = ((SVOP *)label)->op_sv;
            STRLEN l;
            const char *s = SvPV_const(sv,l);
-           if (l == strlen(s)) goto const_label;
-       }
-       o = newUNOP(type, OPf_STACKED, label);
+           if (l == strlen(s)) {
+               o = newPVOP(type,
+                           SvUTF8(((SVOP*)label)->op_sv),
+                           savesharedpv(
+                               SvPV_nolen_const(((SVOP*)label)->op_sv)));
+             free_label:
+#ifdef PERL_MAD
+               op_getmad(label,o,'L');
+#else
+               op_free(label);
+#endif
+               label = NULL;
+           }
     }
+    
+    /* If we still have a label op, we need to create a stacked unop. */
+    if (label) o = newUNOP(type, OPf_STACKED, label);
+
     PL_hints |= HINT_BLOCK_SCOPE;
     return o;
 }

diff --git a/pp_ctl.c b/pp_ctl.c
index f2119a7..1bec840 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2519,10 +2519,49 @@ 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;
+    if (PL_op->op_flags & OPf_SPECIAL) {
+       cxix = dopoptoloop(cxstack_ix);
+       if (cxix < 0)
+           /* diag_listed_as: Can't "last" outside a loop block */
+           Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
+    }
+    else {
+       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)
+           /* 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;
     register PERL_CONTEXT *cx;
     I32 pop2 = 0;
     I32 gimme;
@@ -2533,24 +2572,7 @@ PP(pp_last)
     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");
-    }
-    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 \"last %"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_ "last");
 
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
@@ -2581,9 +2603,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--;
@@ -2611,31 +2632,13 @@ PP(pp_last)
 PP(pp_next)
 {
     dVAR;
-    I32 cxix;
     register PERL_CONTEXT *cx;
-    I32 inner;
+    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]);
@@ -2646,30 +2649,11 @@ PP(pp_next)
 PP(pp_redo)
 {
     dVAR;
-    I32 cxix;
+    const I32 cxix = S_unwind_loop(aTHX_ "redo");
     register 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++;

diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
index 0f075cd..b62b526 100644 (file)
--- a/t/lib/croak/pp_ctl
+++ b/t/lib/croak/pp_ctl
@@ -1,4 +1,10 @@
 __END__
+# NAME dump with computed label
+my $label = "foo";
+dump $label;
+EXPECT
+Can't find label foo at - line 2.
+########
 # NAME when outside given
 use 5.01;
 when(undef){}

diff --git a/t/op/loopctl.t b/t/op/loopctl.t
index d28c191..fcb1237 100644 (file)
--- a/t/op/loopctl.t
+++ b/t/op/loopctl.t
@@ -36,7 +36,7 @@ BEGIN {
 }
 
 require "test.pl";
-plan( tests => 61 );
+plan( tests => 64 );
 
 my $ok;
 
@@ -1067,3 +1067,40 @@ cmp_ok($ok,'==',1,'dynamically scoped');
        "constant optimization doesn't change return value");
     }
 }
+
+# [perl #113684]
+last_113684:
+{
+    label1:
+    {
+        my $label = "label1";
+        eval { last $label };
+        fail("last with non-constant label");
+        last last_113684;
+    }
+    pass("last with non-constant label");
+}
+next_113684:
+{
+    label2:
+    {
+        my $label = "label2";
+        eval { next $label };
+        fail("next with non-constant label");
+        next next_113684;
+    }
+    pass("next with non-constant label");
+}
+redo_113684:
+{
+    my $count;
+    label3:
+    {
+        if ($count++) {
+            pass("redo with non-constant label"); last redo_113684
+        }
+        my $label = "label3";
+        eval { redo $label };
+        fail("redo with non-constant label");
+    }
+}