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