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.

1 files changed, 89 insertions, 1 deletions

diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 9a84f88a51..b048a9705e 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