[perl5.git] / ext / XS-APItest / t / call.t

#!perl -w

# test the various call-into-perl-from-C functions
# DAPM Aug 2004

use warnings;
use strict;

# Test::More doesn't have fresh_perl_is() yet
# use Test::More tests => 342;

BEGIN {
    require '../../t/test.pl';
    plan(527);
    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';
    pop @_;
    @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
}

our $call_sv_count = 0;
sub i {
    $call_sv_count++;
}
call_sv_C();
is($call_sv_count, 6, "call_sv_C passes");

sub d {
    die "its_dead_jim\n";
}

my $obj = bless [], 'Foo';

sub Foo::meth {
    return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
    shift;
    shift;
    unshift @_, 'b';
    pop @_;
    @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
}

sub Foo::d {
    die "its_dead_jim\n";
}

for my $test (
    # flags      args           expected         description
    [ G_VOID,    [ ],           [ 0 ],           '0 args, G_VOID' ],
    [ G_VOID,    [ qw(a p q) ], [ 0 ],           '3 args, G_VOID' ],
    [ G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR' ],
    [ G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR' ],
    [ G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY' ],
    [ G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
    [ G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
    [ G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
)
{
    my ($flags, $args, $expected, $description) = @$test;

    ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
	"$description call_sv(\\&f)");

    ok(eq_array( [ call_sv(*f,  $flags, @$args) ], $expected),
	"$description call_sv(*f)");

    ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
	"$description call_sv('f')");

    ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
	"$description call_pv('f')");

    ok(eq_array( [ call_argv('f', $flags, @$args) ], $expected),
	"$description call_argv('f')") or warn "@{[call_argv('f', $flags, @$args)]}";

    ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
        $expected), "$description eval_sv('f(args)')");

    ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
	"$description call_method('meth')");

    my $returnval = ((($flags & G_WANT) == G_ARRAY) || ($flags & G_DISCARD))
	? [0] : [ undef, 1 ];
    for my $keep (0, G_KEEPERR) {
	my $desc = $description . ($keep ? ' G_KEEPERR' : '');
	my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : "";
	my $exp_err = $keep ? "before\n"
			    : "its_dead_jim\n";
	my $warn;
	local $SIG{__WARN__} = sub { $warn .= $_[0] };
	$@ = "before\n";
	$warn = "";
	ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
		    $returnval),
		    "$desc G_EVAL call_sv('d')");
	is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
	is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning");

	$@ = "before\n";
	$warn = "";
	ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], 
		    $returnval),
		    "$desc G_EVAL call_pv('d')");
	is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
	is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning");

	$@ = "before\n";
	$warn = "";
	ok(eq_array( [ call_argv('d', $flags|G_EVAL|$keep, @$args) ], 
		    $returnval),
		    "$desc G_EVAL call_argv('d')");
	is($@, $exp_err, "$desc G_EVAL call_argv('d') - \$@");
	is($warn, $exp_warn, "$desc G_EVAL call_argv('d') - warning");

	$@ = "before\n";
	$warn = "";
	ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
		    $returnval),
		    "$desc eval_sv('d()')");
	is($@, $exp_err, "$desc eval_sv('d()') - \$@");
	is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning");

	$@ = "before\n";
	$warn = "";
	ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
		    $returnval),
		    "$desc G_EVAL call_method('d')");
	is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
	is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning");
    }

    ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
	$expected), "$description G_NOARGS call_sv('f')");

    ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
	$expected), "$description G_NOARGS call_pv('f')");

    ok(eq_array( [ sub { call_argv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
	$expected), "$description G_NOARGS call_argv('f')");

    ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
        $expected), "$description G_NOARGS eval_sv('f(@_)')");

    # XXX call_method(G_NOARGS) isn't tested: I'm assuming
    # it's not a sensible combination. DAPM.

    ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
	[ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");

    ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
	[ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");

    ok(eq_array( [ eval { call_argv('d', $flags, @$args) }, $@ ],
	[ "its_dead_jim\n" ]), "$description eval { call_argv('d') }");

    ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
	[ @$returnval,
		"its_dead_jim\n", '' ]),
	"$description eval { eval_sv('d') }");

    ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
	[ "its_dead_jim\n" ]), "$description eval { call_method('d') }");

};

{
	# these are the ones documented in perlcall.pod
	my @flags = (G_DISCARD, G_NOARGS, G_EVAL, G_KEEPERR);
	my $mask = 0;
	$mask |= $_ for (@flags);
	is(unpack('%32b*', pack('l', $mask)), @flags,
	  "G_DISCARD and the rest are separate bits");
}

foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
    foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
	my $warn;
	local $SIG{__WARN__} = sub { $warn .= $_[0] };
	$@ = $outx;
	$warn = "";
	call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL);
	ok ref($@) eq ref($inx) && $@ eq $inx;
	$warn =~ s/ at [^\n]*\n\z//;
	is $warn, "";
	$@ = $outx;
	$warn = "";
	call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR);
	ok ref($@) eq ref($outx) && $@ eq $outx;
	$warn =~ s/ at [^\n]*\n\z//;
	is $warn, $inx ? "\t(in cleanup) $inx" : "";
    }
}

{
    no warnings "misc";
    my $warn = "";
    local $SIG{__WARN__} = sub { $warn .= $_[0] };
    call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
    is $warn, "";
}

{
    no warnings "misc";
    my $warn = "";
    local $SIG{__WARN__} = sub { $warn .= $_[0] };
    call_sv(sub { use warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
    is $warn, "\t(in cleanup) aa\n";
}

is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
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 };

my @bodies = (
    # [ code, is_fn_name, expect_success, has_inner_die, expected_err ]

    # ok
    [ 'f99',                         1, 1, 0, qr/^$/,           ],
    # compile-time err
    [ '$x=',                         0, 0, 0, qr/syntax error/, ],
    # compile-time exception
    [ 'BEGIN { die "die in BEGIN"}', 0, 0, 1, qr/die in BEGIN/, ],
    # run-time exception
    [ 'd',                           1, 0, 0, qr/its_dead_jim/, ],
    # success with caught exception
    [ 'eval { die "blah" }; 99',     0, 1, 1, qr/^$/,           ],
);


for my $fn_type (qw(eval_pv eval_sv call_sv)) {

    my $warn_msg;
    local $SIG{__WARN__} = sub { $warn_msg .= $_[0] };

    for my $body (@bodies) {
        my ($code, $is_fn_name, $expect_success,
                $has_inner_die, $expected_err_qr)  = @$body;

	# call_sv can only handle function names, not code snippets
	next if $fn_type eq 'call_sv' and !$is_fn_name;

	for my $keep (0, G_KEEPERR) {
	    my $keep_desc = $keep ? 'G_KEEPERR' : '0';

	    my $desc;
	    my $expect = $expect_success;

	    undef $warn_msg;
	    $@ = 'pre-err';

	    my @ret;
	    if ($fn_type eq '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 eq 'eval_sv') {
		$desc = "eval_sv('$code', G_ARRAY|$keep_desc)";
		@ret = eval_sv($code, G_ARRAY|$keep);
	    }
	    elsif ($fn_type eq 'call_sv') {
		$desc = "call_sv('$code', G_EVAL|G_ARRAY|$keep_desc)";
		@ret = call_sv($code, G_EVAL|G_ARRAY|$keep);
	    }
	    is(scalar @ret, ($expect_success && $fn_type ne 'eval_pv') ? 2 : 1,
			    "$desc - number of returned args");
	    is($ret[-1], $expect, "$desc - return value");

	    if ($keep && $fn_type  ne 'eval_pv') {
		# G_KEEPERR doesn't propagate into inner evals, requires etc
		unless ($keep && $has_inner_die) {
		    is($@, 'pre-err', "$desc - \$@ unmodified");
		}
		$@ = $warn_msg;
	    }
	    else {
		is($warn_msg, undef, "$desc - __WARN__ not called");
		unlike($@, qr/pre-err/, "$desc - \$@ modified");
	    }
	    like($@, $expected_err_qr, "$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

fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
use XS::APItest;

my $x = 0;
sub f {
    eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
    $x++;
    $a <=> $b;
}

eval { my @a = sort f 2, 1;  $x++};
print "x=$x\n";
EOF
Commit	Line	Data
d1f347d7 DM	1	#!perl -w
	2
	3	# test the various call-into-perl-from-C functions
	4	# DAPM Aug 2004
	5
d1f347d7 DM	6	use warnings;
	7	use strict;
	8
43d2322d	9	# Test::More doesn't have fresh_perl_is() yet
7ce09284	10	# use Test::More tests => 342;
d1f347d7	11
dedbcade	12	BEGIN {
2adbc9b6	13	require '../../t/test.pl';
c06180d6	14	plan(527);
dedbcade DM	15	use_ok('XS::APItest')
dedbcade DM	16	};
d1f347d7 DM	17
	18	#########################
	19
4aca2f62 DM	20	# f(): general test sub to be called by call_sv() etc.
	21	# Return the called args, but with the first arg replaced with 'b',
	22	# and the last arg replaced with x/y/z depending on context
	23	#
d1f347d7 DM	24	sub f {
	25	shift;
	26	unshift @_, 'b';
	27	pop @_;
	28	@_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
	29	}
	30
a85ce6f0 DD	31	our $call_sv_count = 0;
	32	sub i {
	33	$call_sv_count++;
	34	}
	35	call_sv_C();
	36	is($call_sv_count, 6, "call_sv_C passes");
	37
d1f347d7	38	sub d {
d1f347d7 DM	39	die "its_dead_jim\n";
	40	}
	41
	42	my $obj = bless [], 'Foo';
	43
	44	sub Foo::meth {
	45	return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
	46	shift;
	47	shift;
	48	unshift @_, 'b';
	49	pop @_;
	50	@_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
	51	}
	52
	53	sub Foo::d {
d1f347d7 DM	54	die "its_dead_jim\n";
	55	}
	56
	57	for my $test (
	58	# flags args expected description
2e2d7405 DM	59	[ G_VOID, [ ], [ 0 ], '0 args, G_VOID' ],
2e2d7405 DM	60	[ G_VOID, [ qw(a p q) ], [ 0 ], '3 args, G_VOID' ],
d1f347d7 DM	61	[ G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
	62	[ G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
	63	[ G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
	64	[ G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
	65	[ G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
	66	[ G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
	67	)
	68	{
	69	my ($flags, $args, $expected, $description) = @$test;
	70
	71	ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
	72	"$description call_sv(\\&f)");
	73
	74	ok(eq_array( [ call_sv(*f, $flags, @$args) ], $expected),
	75	"$description call_sv(*f)");
	76
	77	ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
	78	"$description call_sv('f')");
	79
	80	ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
	81	"$description call_pv('f')");
	82
c06180d6 FC	83	ok(eq_array( [ call_argv('f', $flags, @$args) ], $expected),
	84	"$description call_argv('f')") or warn "@{[call_argv('f', $flags, @$args)]}";
	85
d1f347d7	86	ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
2e2d7405	87	$expected), "$description eval_sv('f(args)')");
d1f347d7 DM	88
	89	ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
	90	"$description call_method('meth')");
	91
b8d2d791 NC	92	my $returnval = ((($flags & G_WANT) == G_ARRAY) \|\| ($flags & G_DISCARD))
b8d2d791 NC	93	? [0] : [ undef, 1 ];
d1f347d7 DM	94	for my $keep (0, G_KEEPERR) {
d1f347d7 DM	95	my $desc = $description . ($keep ? ' G_KEEPERR' : '');
7ce09284 Z	96	my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : "";
7ce09284 Z	97	my $exp_err = $keep ? "before\n"
d1f347d7	98	: "its_dead_jim\n";
7ce09284 Z	99	my $warn;
7ce09284 Z	100	local $SIG{__WARN__} = sub { $warn .= $_[0] };
d1f347d7	101	$@ = "before\n";
7ce09284	102	$warn = "";
d1f347d7	103	ok(eq_array( [ call_sv('d', $flags\|G_EVAL\|$keep, @$args) ],
b8d2d791	104	$returnval),
d1f347d7 DM	105	"$desc G_EVAL call_sv('d')");
d1f347d7 DM	106	is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
7ce09284	107	is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning");
d1f347d7 DM	108
d1f347d7 DM	109	$@ = "before\n";
7ce09284	110	$warn = "";
d1f347d7	111	ok(eq_array( [ call_pv('d', $flags\|G_EVAL\|$keep, @$args) ],
b8d2d791	112	$returnval),
d1f347d7 DM	113	"$desc G_EVAL call_pv('d')");
d1f347d7 DM	114	is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
7ce09284	115	is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning");
d1f347d7 DM	116
d1f347d7 DM	117	$@ = "before\n";
7ce09284	118	$warn = "";
c06180d6 FC	119	ok(eq_array( [ call_argv('d', $flags\|G_EVAL\|$keep, @$args) ],
	120	$returnval),
	121	"$desc G_EVAL call_argv('d')");
	122	is($@, $exp_err, "$desc G_EVAL call_argv('d') - \$@");
	123	is($warn, $exp_warn, "$desc G_EVAL call_argv('d') - warning");
	124
	125	$@ = "before\n";
	126	$warn = "";
d1f347d7	127	ok(eq_array( [ eval_sv('d()', $flags\|$keep) ],
b8d2d791	128	$returnval),
d1f347d7 DM	129	"$desc eval_sv('d()')");
d1f347d7 DM	130	is($@, $exp_err, "$desc eval_sv('d()') - \$@");
7ce09284	131	is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning");
d1f347d7 DM	132
d1f347d7 DM	133	$@ = "before\n";
7ce09284	134	$warn = "";
d1f347d7	135	ok(eq_array( [ call_method('d', $flags\|G_EVAL\|$keep, $obj, @$args) ],
b8d2d791	136	$returnval),
d1f347d7 DM	137	"$desc G_EVAL call_method('d')");
d1f347d7 DM	138	is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
7ce09284	139	is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning");
d1f347d7 DM	140	}
	141
	142	ok(eq_array( [ sub { call_sv('f', $flags\|G_NOARGS, "bad") }->(@$args) ],
	143	$expected), "$description G_NOARGS call_sv('f')");
	144
	145	ok(eq_array( [ sub { call_pv('f', $flags\|G_NOARGS, "bad") }->(@$args) ],
	146	$expected), "$description G_NOARGS call_pv('f')");
	147
c06180d6 FC	148	ok(eq_array( [ sub { call_argv('f', $flags\|G_NOARGS, "bad") }->(@$args) ],
	149	$expected), "$description G_NOARGS call_argv('f')");
	150
d1f347d7	151	ok(eq_array( [ sub { eval_sv('f(@_)', $flags\|G_NOARGS) }->(@$args) ],
2e2d7405	152	$expected), "$description G_NOARGS eval_sv('f(@_)')");
d1f347d7 DM	153
	154	# XXX call_method(G_NOARGS) isn't tested: I'm assuming
	155	# it's not a sensible combination. DAPM.
	156
	157	ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
	158	[ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
	159
	160	ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
	161	[ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
	162
c06180d6 FC	163	ok(eq_array( [ eval { call_argv('d', $flags, @$args) }, $@ ],
	164	[ "its_dead_jim\n" ]), "$description eval { call_argv('d') }");
	165
d1f347d7	166	ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
b8d2d791	167	[ @$returnval,
dedbcade	168	"its_dead_jim\n", '' ]),
d1f347d7 DM	169	"$description eval { eval_sv('d') }");
	170
	171	ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
	172	[ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
	173
	174	};
	175
0b06a753 NT	176	{
	177	# these are the ones documented in perlcall.pod
	178	my @flags = (G_DISCARD, G_NOARGS, G_EVAL, G_KEEPERR);
	179	my $mask = 0;
	180	$mask \|= $_ for (@flags);
	181	is(unpack('%32b*', pack('l', $mask)), @flags,
	182	"G_DISCARD and the rest are separate bits");
	183	}
	184
7ce09284 Z	185	foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
	186	foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
	187	my $warn;
	188	local $SIG{__WARN__} = sub { $warn .= $_[0] };
	189	$@ = $outx;
	190	$warn = "";
	191	call_sv(sub { die $inx if $inx }, G_VOID\|G_EVAL);
	192	ok ref($@) eq ref($inx) && $@ eq $inx;
	193	$warn =~ s/ at [^\n]*\n\z//;
	194	is $warn, "";
	195	$@ = $outx;
	196	$warn = "";
	197	call_sv(sub { die $inx if $inx }, G_VOID\|G_EVAL\|G_KEEPERR);
	198	ok ref($@) eq ref($outx) && $@ eq $outx;
	199	$warn =~ s/ at [^\n]*\n\z//;
	200	is $warn, $inx ? "\t(in cleanup) $inx" : "";
	201	}
	202	}
	203
	204	{
	205	no warnings "misc";
	206	my $warn = "";
	207	local $SIG{__WARN__} = sub { $warn .= $_[0] };
	208	call_sv(sub { die "aa\n" }, G_VOID\|G_EVAL\|G_KEEPERR);
	209	is $warn, "";
	210	}
	211
	212	{
fc941f37	213	no warnings "misc";
7ce09284 Z	214	my $warn = "";
7ce09284 Z	215	local $SIG{__WARN__} = sub { $warn .= $_[0] };
fc941f37	216	call_sv(sub { use warnings "misc"; die "aa\n" }, G_VOID\|G_EVAL\|G_KEEPERR);
7ce09284 Z	217	is $warn, "\t(in cleanup) aa\n";
	218	}
	219
d1f347d7 DM	220	is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
	221	is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
	222	is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
	223	is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
	224	is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
	225	is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
dedbcade	226
4aca2f62 DM	227
	228	# #3719 - check that the eval call variants handle exceptions correctly,
	229	# and do the right thing with $@, both with and without G_KEEPERR set.
	230
	231	sub f99 { 99 };
	232
a1f85fba DM	233	my @bodies = (
a1f85fba DM	234	# [ code, is_fn_name, expect_success, has_inner_die, expected_err ]
4aca2f62	235
a1f85fba DM	236	# ok
	237	[ 'f99', 1, 1, 0, qr/^$/, ],
	238	# compile-time err
	239	[ '$x=', 0, 0, 0, qr/syntax error/, ],
	240	# compile-time exception
	241	[ 'BEGIN { die "die in BEGIN"}', 0, 0, 1, qr/die in BEGIN/, ],
	242	# run-time exception
	243	[ 'd', 1, 0, 0, qr/its_dead_jim/, ],
7051b8c3 DM	244	# success with caught exception
7051b8c3 DM	245	[ 'eval { die "blah" }; 99', 0, 1, 1, qr/^$/, ],
a1f85fba DM	246	);
	247
	248
	249	for my $fn_type (qw(eval_pv eval_sv call_sv)) {
4aca2f62 DM	250
4aca2f62 DM	251	my $warn_msg;
6b2fb389	252	local $SIG{__WARN__} = sub { $warn_msg .= $_[0] };
4aca2f62	253
a1f85fba DM	254	for my $body (@bodies) {
	255	my ($code, $is_fn_name, $expect_success,
	256	$has_inner_die, $expected_err_qr) = @$body;
4aca2f62 DM	257
4aca2f62 DM	258	# call_sv can only handle function names, not code snippets
a1f85fba	259	next if $fn_type eq 'call_sv' and !$is_fn_name;
4aca2f62 DM	260
4aca2f62 DM	261	for my $keep (0, G_KEEPERR) {
4aca2f62 DM	262	my $keep_desc = $keep ? 'G_KEEPERR' : '0';
	263
	264	my $desc;
a1f85fba	265	my $expect = $expect_success;
4aca2f62 DM	266
	267	undef $warn_msg;
	268	$@ = 'pre-err';
	269
	270	my @ret;
a1f85fba	271	if ($fn_type eq 'eval_pv') {
4aca2f62 DM	272	# eval_pv returns its result rather than a 'succeed' boolean
	273	$expect = $expect ? '99' : undef;
	274
	275	# eval_pv doesn't support G_KEEPERR, but it has a croak
	276	# boolean arg instead, so switch on that instead
	277	if ($keep) {
	278	$desc = "eval { eval_pv('$code', 1) }";
	279	@ret = eval { eval_pv($code, 1); '99' };
	280	# die in eval returns empty list
	281	push @ret, undef unless @ret;
	282	}
	283	else {
	284	$desc = "eval_pv('$code', 0)";
	285	@ret = eval_pv($code, 0);
	286	}
	287	}
a1f85fba	288	elsif ($fn_type eq 'eval_sv') {
4aca2f62 DM	289	$desc = "eval_sv('$code', G_ARRAY\|$keep_desc)";
	290	@ret = eval_sv($code, G_ARRAY\|$keep);
	291	}
a1f85fba	292	elsif ($fn_type eq 'call_sv') {
4aca2f62 DM	293	$desc = "call_sv('$code', G_EVAL\|G_ARRAY\|$keep_desc)";
	294	@ret = call_sv($code, G_EVAL\|G_ARRAY\|$keep);
	295	}
a1f85fba	296	is(scalar @ret, ($expect_success && $fn_type ne 'eval_pv') ? 2 : 1,
4aca2f62 DM	297	"$desc - number of returned args");
	298	is($ret[-1], $expect, "$desc - return value");
	299
a1f85fba	300	if ($keep && $fn_type ne 'eval_pv') {
6b2fb389	301	# G_KEEPERR doesn't propagate into inner evals, requires etc
a1f85fba	302	unless ($keep && $has_inner_die) {
6b2fb389 DM	303	is($@, 'pre-err', "$desc - \$@ unmodified");
6b2fb389 DM	304	}
4aca2f62 DM	305	$@ = $warn_msg;
	306	}
	307	else {
	308	is($warn_msg, undef, "$desc - __WARN__ not called");
aaa63dae	309	unlike($@, qr/pre-err/, "$desc - \$@ modified");
4aca2f62	310	}
a1f85fba	311	like($@, $expected_err_qr, "$desc - the correct error message");
4aca2f62 DM	312	}
	313	}
	314	}
	315
dedbcade DM	316	# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
	317	# a new jump level but before pushing an eval context, leading to
	318	# stack corruption
	319
2adbc9b6	320	fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
dedbcade DM	321	use XS::APItest;
	322
	323	my $x = 0;
	324	sub f {
	325	eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
	326	$x++;
	327	$a <=> $b;
	328	}
	329
	330	eval { my @a = sort f 2, 1; $x++};
	331	print "x=$x\n";
	332	EOF
	333