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';
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
# 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); \
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();
PL_restartop = 0;
goto redo_body;
}
+ fail:
PL_stack_sp = PL_stack_base + oldmark;
if ((flags & G_WANT) == G_ARRAY)
retval = 0;