1#!perl -w
2
3# test the various call-into-perl-from-C functions
4# DAPM Aug 2004
5
6BEGIN {
7    chdir 't' if -d 't';
8    @INC = '../lib';
9    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
10    require Config; import Config;
11    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
12	# Look, I'm using this fully-qualified variable more than once!
13	my $arch = $MacPerl::Architecture;
14        print "1..0 # Skip: XS::APItest was not built\n";
15        exit 0;
16    }
17}
18
19use warnings;
20use strict;
21
22# Test::More doesn't have fresh_perl_is() yet
23# use Test::More tests => 240;
24
25BEGIN {
26    require './test.pl';
27    plan(240);
28    use_ok('XS::APItest')
29};
30
31#########################
32
33sub f {
34    shift;
35    unshift @_, 'b';
36    pop @_;
37    @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
38}
39
40sub d {
41    no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
42    die "its_dead_jim\n";
43}
44
45my $obj = bless [], 'Foo';
46
47sub Foo::meth {
48    return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
49    shift;
50    shift;
51    unshift @_, 'b';
52    pop @_;
53    @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
54}
55
56sub Foo::d {
57    no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
58    die "its_dead_jim\n";
59}
60
61for my $test (
62    # flags      args           expected         description
63    [ G_VOID,    [ ],           [ qw(z 1) ],     '0 args, G_VOID' ],
64    [ G_VOID,    [ qw(a p q) ], [ qw(z 1) ],     '3 args, G_VOID' ],
65    [ G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR' ],
66    [ G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR' ],
67    [ G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY' ],
68    [ G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
69    [ G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
70    [ G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
71)
72{
73    my ($flags, $args, $expected, $description) = @$test;
74
75    ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
76	"$description call_sv(\\&f)");
77
78    ok(eq_array( [ call_sv(*f,  $flags, @$args) ], $expected),
79	"$description call_sv(*f)");
80
81    ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
82	"$description call_sv('f')");
83
84    ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
85	"$description call_pv('f')");
86
87    ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
88	$expected), "$description eval_sv('f(args)')");
89
90    ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
91	"$description call_method('meth')");
92
93    for my $keep (0, G_KEEPERR) {
94	my $desc = $description . ($keep ? ' G_KEEPERR' : '');
95	my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n"
96			    : "its_dead_jim\n";
97	$@ = "before\n";
98	ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
99		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
100		    "$desc G_EVAL call_sv('d')");
101	is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
102
103	$@ = "before\n";
104	ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ],
105		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
106		    "$desc G_EVAL call_pv('d')");
107	is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
108
109	$@ = "before\n";
110	ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
111		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
112		    "$desc eval_sv('d()')");
113	is($@, $exp_err, "$desc eval_sv('d()') - \$@");
114
115	$@ = "before\n";
116	ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
117		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
118		    "$desc G_EVAL call_method('d')");
119	is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
120    }
121
122    ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
123	$expected), "$description G_NOARGS call_sv('f')");
124
125    ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
126	$expected), "$description G_NOARGS call_pv('f')");
127
128    ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
129	$expected), "$description G_NOARGS eval_sv('f(@_)')");
130
131    # XXX call_method(G_NOARGS) isn't tested: I'm assuming
132    # it's not a sensible combination. DAPM.
133
134    ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
135	[ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
136
137    ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
138	[ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
139
140    ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
141	[ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1),
142		"its_dead_jim\n", '' ]),
143	"$description eval { eval_sv('d') }");
144
145    ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
146	[ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
147
148};
149
150is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
151is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
152is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
153is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
154is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
155is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
156
157# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
158# a new jump level but before pushing an eval context, leading to
159# stack corruption
160
161fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint');
162use XS::APItest;
163
164my $x = 0;
165sub f {
166    eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
167    $x++;
168    $a <=> $b;
169}
170
171eval { my @a = sort f 2, 1;  $x++};
172print "x=$x\n";
173EOF
174
175