This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
handle errors in gen_constant_list
authorZefram <zefram@fysh.org>
Sun, 22 Jan 2017 03:20:08 +0000 (03:20 +0000)
committerZefram <zefram@fysh.org>
Sun, 22 Jan 2017 03:20:08 +0000 (03:20 +0000)
When the attempt to constant-fold a list generates an error, that
error should not be signalled at compile time, but merely abort the
attempt at constant folding, so that the error will occur naturally
at runtime.  This is achieved by wrapping the compile-time execution in
gen_constant_list() in a fake eval block.  This brings it in line with
the scalar fold_constants().  Fixes [perl #129320].

op.c
t/comp/fold.t

diff --git a/op.c b/op.c
index 118c519..d2fd198 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4620,27 +4620,80 @@ static OP *
 S_gen_constant_list(pTHX_ OP *o)
 {
     dVAR;
-    OP *curop;
-    const SSize_t oldtmps_floor = PL_tmps_floor;
+    OP *curop, *old_next;
+    SV * const oldwarnhook = PL_warnhook;
+    SV * const olddiehook  = PL_diehook;
+    COP *old_curcop;
+    U8 oldwarn = PL_dowarn;
     SV **svp;
     AV *av;
+    I32 old_cxix;
+    COP not_compiling;
+    int ret = 0;
+    dJMPENV;
 
     list(o);
     if (PL_parser && PL_parser->error_count)
        return o;               /* Don't attempt to run with errors */
 
     curop = LINKLIST(o);
+    old_next = o->op_next;
     o->op_next = 0;
     CALL_PEEP(curop);
     S_prune_chain_head(&curop);
     PL_op = curop;
-    Perl_pp_pushmark(aTHX);
-    CALLRUNOPS(aTHX);
-    PL_op = curop;
-    assert (!(curop->op_flags & OPf_SPECIAL));
-    assert(curop->op_type == OP_RANGE);
-    Perl_pp_anonlist(aTHX);
-    PL_tmps_floor = oldtmps_floor;
+
+    old_cxix = cxstack_ix;
+    create_eval_scope(NULL, G_FAKINGEVAL);
+
+    old_curcop = PL_curcop;
+    StructCopy(old_curcop, &not_compiling, COP);
+    PL_curcop = &not_compiling;
+    /* The above ensures that we run with all the correct hints of the
+       current COP, but that IN_PERL_RUNTIME is true. */
+    assert(IN_PERL_RUNTIME);
+    PL_warnhook = PERL_WARNHOOK_FATAL;
+    PL_diehook  = NULL;
+    JMPENV_PUSH(ret);
+
+    /* Effective $^W=1.  */
+    if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+       PL_dowarn |= G_WARN_ON;
+
+    switch (ret) {
+    case 0:
+       Perl_pp_pushmark(aTHX);
+       CALLRUNOPS(aTHX);
+       PL_op = curop;
+       assert (!(curop->op_flags & OPf_SPECIAL));
+       assert(curop->op_type == OP_RANGE);
+       Perl_pp_anonlist(aTHX);
+       break;
+    case 3:
+       CLEAR_ERRSV();
+       o->op_next = old_next;
+       break;
+    default:
+       JMPENV_POP;
+       PL_warnhook = oldwarnhook;
+       PL_diehook = olddiehook;
+       Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
+           ret);
+    }
+
+    JMPENV_POP;
+    PL_dowarn = oldwarn;
+    PL_warnhook = oldwarnhook;
+    PL_diehook = olddiehook;
+    PL_curcop = old_curcop;
+
+    if (cxstack_ix > old_cxix) {
+        assert(cxstack_ix == old_cxix + 1);
+        assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+        delete_eval_scope();
+    }
+    if (ret)
+       return o;
 
     OpTYPE_set(o, OP_RV2AV);
     o->op_flags &= ~OPf_REF;   /* treat \(1..2) like an ordinary list */
index 4fa0734..a875b5b 100644 (file)
@@ -4,7 +4,7 @@
 # we've not yet verified that use works.
 # use strict;
 
-print "1..30\n";
+print "1..34\n";
 my $test = 0;
 
 # Historically constant folding was performed by evaluating the ops, and if
@@ -180,3 +180,12 @@ is "@values", "4 4",
     is $w, 1, '1+undef_constant is not folded outside warninsg scope';
     BEGIN { $^W = 1 }
 }
+
+$a = eval 'my @z; @z = 0..~0 if 0; 3';
+is ($a, 3, "list constant folding doesn't signal compile-time error");
+is ($@, '', 'no error');
+
+$b = 0;
+$a = eval 'my @z; @z = 0..~0 if $b; 3';
+is ($a, 3, "list constant folding doesn't signal compile-time error");
+is ($@, '', 'no error');