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