eval_sv() and eval_pv() don't fail on syntax err

[perl #3719] eval_sv("some syntax err") cleared $@ and didn't return
a failure indication. This also affected eval_pv() which calls eval_sv().
Fix this and add lots of tests.

diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 9a84f88..b048a97 100644 (file)
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -11,12 +11,16 @@ use strict;
 
 BEGIN {
     require '../../t/test.pl';
-    plan(342);
+    plan(392);
     use_ok('XS::APItest')
 };
 
 #########################
 
+# f(): general test sub to be called by call_sv() etc.
+# Return the called args, but with the first arg replaced with 'b',
+# and the last arg replaced with x/y/z depending on context
+#
 sub f {
     shift;
     unshift @_, 'b';
@@ -186,6 +190,90 @@ is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
 
+
+# #3719 - check that the eval call variants handle exceptions correctly,
+# and do the right thing with $@, both with and without G_KEEPERR set.
+
+sub f99 { 99 };
+
+
+for my $fn_type (0..2) { #   0:eval_pv   1:eval_sv   2:call_sv
+
+    my $warn_msg;
+    local $SIG{__WARN__} = sub { $warn_msg = $_[0] };
+
+    for my $code_type (0..3) {
+
+       # call_sv can only handle function names, not code snippets
+       next if $fn_type == 2 and ($code_type == 1 or $code_type == 2);
+
+       my $code = (
+           'f99',                          # ok
+           '$x=',                          # compile-time err
+           'BEGIN { die "die in BEGIN"}',  # compile-time exception
+           'd',                            # run-time exception
+       )[$code_type];
+
+       for my $keep (0, G_KEEPERR) {
+           next if $keep == G_KEEPERR; # XXX not fixed yet
+           my $keep_desc = $keep ? 'G_KEEPERR' : '0';
+
+           my $desc;
+           my $expect = ($code_type == 0) ? 1 : 0;
+
+           undef $warn_msg;
+           $@ = 'pre-err';
+
+           my @ret;
+           if ($fn_type == 0) { # eval_pv
+               # eval_pv returns its result rather than a 'succeed' boolean
+               $expect = $expect ? '99' : undef;
+
+               # eval_pv doesn't support G_KEEPERR, but it has a croak
+               # boolean arg instead, so switch on that instead
+               if ($keep) {
+                   $desc = "eval { eval_pv('$code', 1) }";
+                   @ret = eval { eval_pv($code, 1); '99' };
+                   # die in eval returns empty list
+                   push @ret, undef unless @ret;
+               }
+               else {
+                   $desc = "eval_pv('$code', 0)";
+                   @ret = eval_pv($code, 0);
+               }
+           }
+           elsif ($fn_type == 1) { # eval_sv
+               $desc = "eval_sv('$code', G_ARRAY|$keep_desc)";
+               @ret = eval_sv($code, G_ARRAY|$keep);
+           }
+           elsif ($fn_type == 2) { # call_sv
+               $desc = "call_sv('$code', G_EVAL|G_ARRAY|$keep_desc)";
+               @ret = call_sv($code, G_EVAL|G_ARRAY|$keep);
+           }
+           is(scalar @ret, ($code_type == 0 && $fn_type != 0) ? 2 : 1,
+                           "$desc - number of returned args");
+           is($ret[-1], $expect, "$desc - return value");
+
+           if ($keep && $fn_type != 0) {
+               is($@, 'pre-err', "$desc - \$@ unmodified");
+               $@ = $warn_msg;
+           }
+           else {
+               is($warn_msg, undef, "$desc - __WARN__ not called");
+               unlike($@, 'pre-err', "$desc - \$@ modified");
+           }
+           like($@,
+               (
+                   qr/^$/,
+                   qr/syntax error/,
+                   qr/die in BEGIN/,
+                   qr/its_dead_jim/,
+               )[$code_type],
+               "$desc - the correct error message");
+       }
+    }
+}
+
 # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
 # a new jump level but before pushing an eval context, leading to
 # stack corruption

diff --git a/perl.c b/perl.c
index cf42087..0a58b7c 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -80,12 +80,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 #  define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
 #endif
 
-#define CALL_BODY_EVAL(myop) \
-    if (PL_op == (myop)) \
-       PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \
-    if (PL_op) \
-       CALLRUNOPS(aTHX);
-
 #define CALL_BODY_SUB(myop) \
     if (PL_op == (myop)) \
        PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
@@ -2715,7 +2709,11 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     switch (ret) {
     case 0:
  redo_body:
-       CALL_BODY_EVAL((OP*)&myop);
+       assert(PL_op == (OP*)(&myop));
+       PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
+       if (!PL_op)
+           goto fail; /* failed in compilation */
+       CALLRUNOPS(aTHX);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        if (!(flags & G_KEEPERR)) {
            CLEAR_ERRSV();
@@ -2738,6 +2736,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
            PL_restartop = 0;
            goto redo_body;
        }
+      fail:
        PL_stack_sp = PL_stack_base + oldmark;
        if ((flags & G_WANT) == G_ARRAY)
            retval = 0;