3 # test the various call-into-perl-from-C functions
9 # Test::More doesn't have fresh_perl_is() yet
10 # use Test::More tests => 342;
13 require '../../t/test.pl';
18 #########################
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
28 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
31 our $call_sv_count = 0;
36 is($call_sv_count, 6, "call_sv_C passes");
42 my $obj = bless [], 'Foo';
45 return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
50 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
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' ],
69 my ($flags, $args, $expected, $description) = @$test;
71 ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
72 "$description call_sv(\\&f)");
74 ok(eq_array( [ call_sv(*f, $flags, @$args) ], $expected),
75 "$description call_sv(*f)");
77 ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
78 "$description call_sv('f')");
80 ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
81 "$description call_pv('f')");
83 ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
84 $flags == G_VOID ? [ 0 ] : $expected
86 "$description eval_sv('f(args)')");
88 ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
89 "$description call_method('meth')");
91 my $returnval = ((($flags & G_WANT) == G_ARRAY) || ($flags & G_DISCARD))
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"
99 local $SIG{__WARN__} = sub { $warn .= $_[0] };
102 ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
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");
110 ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ],
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");
118 ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
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");
126 ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
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");
133 ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
134 $expected), "$description G_NOARGS call_sv('f')");
136 ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
137 $expected), "$description G_NOARGS call_pv('f')");
139 ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
140 $flags == G_VOID ? [ 0 ] : $expected
142 "$description G_NOARGS eval_sv('f(@_)')");
144 # XXX call_method(G_NOARGS) isn't tested: I'm assuming
145 # it's not a sensible combination. DAPM.
147 ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
148 [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
150 ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
151 [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
153 ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
155 "its_dead_jim\n", '' ]),
156 "$description eval { eval_sv('d') }");
158 ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
159 [ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
164 # these are the ones documented in perlcall.pod
165 my @flags = (G_DISCARD, G_NOARGS, G_EVAL, G_KEEPERR);
167 $mask |= $_ for (@flags);
168 is(unpack('%32b*', pack('l', $mask)), @flags,
169 "G_DISCARD and the rest are separate bits");
172 foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
173 foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
175 local $SIG{__WARN__} = sub { $warn .= $_[0] };
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//;
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" : "";
194 local $SIG{__WARN__} = sub { $warn .= $_[0] };
195 call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
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";
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) } - \$@");
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.
221 # [ code, is_fn_name, expect_success, has_inner_die, expected_err ]
224 [ 'f99', 1, 1, 0, qr/^$/, ],
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/, ],
230 [ 'd', 1, 0, 0, qr/its_dead_jim/, ],
231 # success with caught exception
232 [ 'eval { die "blah" }; 99', 0, 1, 1, qr/^$/, ],
236 for my $fn_type (qw(eval_pv eval_sv call_sv)) {
239 local $SIG{__WARN__} = sub { $warn_msg .= $_[0] };
241 for my $body (@bodies) {
242 my ($code, $is_fn_name, $expect_success,
243 $has_inner_die, $expected_err_qr) = @$body;
245 # call_sv can only handle function names, not code snippets
246 next if $fn_type eq 'call_sv' and !$is_fn_name;
248 for my $keep (0, G_KEEPERR) {
249 my $keep_desc = $keep ? 'G_KEEPERR' : '0';
252 my $expect = $expect_success;
258 if ($fn_type eq 'eval_pv') {
259 # eval_pv returns its result rather than a 'succeed' boolean
260 $expect = $expect ? '99' : undef;
262 # eval_pv doesn't support G_KEEPERR, but it has a croak
263 # boolean arg instead, so switch on that instead
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;
271 $desc = "eval_pv('$code', 0)";
272 @ret = eval_pv($code, 0);
275 elsif ($fn_type eq 'eval_sv') {
276 $desc = "eval_sv('$code', G_ARRAY|$keep_desc)";
277 @ret = eval_sv($code, G_ARRAY|$keep);
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);
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");
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");
295 is($warn_msg, undef, "$desc - __WARN__ not called");
296 unlike($@, qr/pre-err/, "$desc - \$@ modified");
298 like($@, $expected_err_qr, "$desc - the correct error message");
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
307 fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
312 eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
317 eval { my @a = sort f 2, 1; $x++};