From 4aca2f62efca883199d7975f34b7fb876c280366 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sat, 2 Oct 2010 11:13:09 +0100
Subject: [PATCH] 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.
---
 ext/XS-APItest/t/call.t | 90 ++++++++++++++++++++++++++++++++++++++++-
 perl.c                  | 13 +++---
 2 files changed, 95 insertions(+), 8 deletions(-)

diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 9a84f88a51f..b048a9705e3 100644
--- 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 cf42087be2e..0a58b7c76be 100644
--- 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;