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