1#!perl -w 2 3# test the various call-into-perl-from-C functions 4# DAPM Aug 2004 5 6use warnings; 7use strict; 8 9# Test::More doesn't have fresh_perl_is() yet 10# use Test::More tests => 344; 11 12BEGIN { 13 require '../../t/test.pl'; 14 plan(542); 15 use_ok('XS::APItest') 16}; 17use Config; 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# 24sub f { 25 shift; 26 unshift @_, 'b'; 27 pop @_; 28 @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; 29} 30 31our $call_sv_count = 0; 32sub i { 33 $call_sv_count++; 34} 35call_sv_C(); 36is($call_sv_count, 7, "call_sv_C passes"); 37 38sub d { 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 { 54 die "its_dead_jim\n"; 55} 56 57for my $test ( 58 # flags args expected description 59 [ G_VOID, [ ], [ 0 ], '0 args, G_VOID' ], 60 [ G_VOID, [ qw(a p q) ], [ 0 ], '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_LIST, [ ], [ qw(x 1) ], '0 args, G_LIST' ], 64 [ G_LIST, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_LIST' ], 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( [ call_argv('f', $flags, @$args) ], $expected), 84 "$description call_argv('f')") or warn "@{[call_argv('f', $flags, @$args)]}"; 85 86 ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], 87 $expected), "$description eval_sv('f(args)')"); 88 89 ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected), 90 "$description call_method('meth')"); 91 92 my $returnval = ((($flags & G_WANT) == G_LIST) || ($flags & G_DISCARD)) 93 ? [0] : [ undef, 1 ]; 94 for my $keep (0, G_KEEPERR) { 95 my $desc = $description . ($keep ? ' G_KEEPERR' : ''); 96 my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : ""; 97 my $exp_err = $keep ? "before\n" 98 : "its_dead_jim\n"; 99 my $warn; 100 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 101 $@ = "before\n"; 102 $warn = ""; 103 ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ], 104 $returnval), 105 "$desc G_EVAL call_sv('d')"); 106 is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@"); 107 is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning"); 108 109 $@ = "before\n"; 110 $warn = ""; 111 ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], 112 $returnval), 113 "$desc G_EVAL call_pv('d')"); 114 is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@"); 115 is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning"); 116 117 $@ = "before\n"; 118 $warn = ""; 119 ok(eq_array( [ call_argv('d', $flags|G_EVAL|$keep, @$args) ], 120 $returnval), 121 "$desc G_EVAL call_argv('d')"); 122 is($@, $exp_err, "$desc G_EVAL call_argv('d') - \$@"); 123 is($warn, $exp_warn, "$desc G_EVAL call_argv('d') - warning"); 124 125 $@ = "before\n"; 126 $warn = ""; 127 ok(eq_array( [ eval_sv('d()', $flags|$keep) ], 128 $returnval), 129 "$desc eval_sv('d()')"); 130 is($@, $exp_err, "$desc eval_sv('d()') - \$@"); 131 is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning"); 132 133 $@ = "before\n"; 134 $warn = ""; 135 ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ], 136 $returnval), 137 "$desc G_EVAL call_method('d')"); 138 is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@"); 139 is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning"); 140 } 141 142 ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ], 143 $expected), "$description G_NOARGS call_sv('f')"); 144 145 ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ], 146 $expected), "$description G_NOARGS call_pv('f')"); 147 148 ok(eq_array( [ sub { call_argv('f', $flags|G_NOARGS, "bad") }->(@$args) ], 149 $expected), "$description G_NOARGS call_argv('f')"); 150 151 ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ], 152 $expected), "$description G_NOARGS eval_sv('f(@_)')"); 153 154 # XXX call_method(G_NOARGS) isn't tested: I'm assuming 155 # it's not a sensible combination. DAPM. 156 157 ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ], 158 [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }"); 159 160 ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ], 161 [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }"); 162 163 ok(eq_array( [ eval { call_argv('d', $flags, @$args) }, $@ ], 164 [ "its_dead_jim\n" ]), "$description eval { call_argv('d') }"); 165 166 ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ], 167 [ @$returnval, 168 "its_dead_jim\n", '' ]), 169 "$description eval { eval_sv('d') }"); 170 171 ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ], 172 [ "its_dead_jim\n" ]), "$description eval { call_method('d') }"); 173 174}; 175 176{ 177 # these are the ones documented in perlcall.pod 178 my @flags = (G_DISCARD, G_NOARGS, G_EVAL, G_KEEPERR); 179 my $mask = 0; 180 $mask |= $_ for (@flags); 181 is(unpack('%32b*', pack('l', $mask)), @flags, 182 "G_DISCARD and the rest are separate bits"); 183} 184 185foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) { 186 foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) { 187 my $warn; 188 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 189 $@ = $outx; 190 $warn = ""; 191 call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL); 192 ok ref($@) eq ref($inx) && $@ eq $inx; 193 $warn =~ s/ at [^\n]*\n\z//; 194 is $warn, ""; 195 $@ = $outx; 196 $warn = ""; 197 call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR); 198 ok ref($@) eq ref($outx) && $@ eq $outx; 199 $warn =~ s/ at [^\n]*\n\z//; 200 is $warn, $inx ? "\t(in cleanup) $inx" : ""; 201 } 202} 203 204{ 205 no warnings "misc"; 206 my $warn = ""; 207 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 208 call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR); 209 is $warn, ""; 210} 211 212{ 213 no warnings "misc"; 214 my $warn = ""; 215 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 216 call_sv(sub { use warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR); 217 is $warn, "\t(in cleanup) aa\n"; 218} 219 220is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)"); 221is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)"); 222is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)"); 223is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@"); 224is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }"); 225is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@"); 226is(eval { eval_pv(q/die $obj/, 1) }, undef, 227 "eval_pv die of an object"); 228ok(ref $@, "object thrown"); 229is($@, $obj, "check object rethrown"); 230 231package False { 232 use overload 233 bool => sub { 0 }, 234 '""' => sub { "Foo" }; 235 sub new { bless {}, shift } 236}; 237my $false = False->new; 238ok(!$false, "our false object is actually false"); 239is(eval { eval_pv(q/die $false;/, 1); 1 }, undef, 240 "check false objects are rethrown"); 241is(overload::StrVal($@), overload::StrVal($false), 242 "check we got the expected object"); 243 244is(eval { eval_sv(q/die $false/, G_RETHROW); 1 }, undef, 245 "check G_RETHROW for thrown object"); 246is(overload::StrVal($@), overload::StrVal($false), 247 "check we got the expected object"); 248is(eval { eval_sv(q/"unterminated/, G_RETHROW); 1 }, undef, 249 "check G_RETHROW for syntax error"); 250like($@, qr/Can't find string terminator/, 251 "check error rethrown"); 252ok(eq_array([ eval { eval_sv(q/"working code"/, G_RETHROW) } ], [ "working code", 1 ]), 253 "check for spurious rethrow"); 254 255# #3719 - check that the eval call variants handle exceptions correctly, 256# and do the right thing with $@, both with and without G_KEEPERR set. 257 258sub f99 { 99 }; 259 260my @bodies = ( 261 # [ code, is_fn_name, expect_success, has_inner_die, expected_err ] 262 263 # ok 264 [ 'f99', 1, 1, 0, qr/^$/, ], 265 # compile-time err 266 [ '$x=', 0, 0, 0, qr/syntax error/, ], 267 # compile-time exception 268 [ 'BEGIN { die "die in BEGIN"}', 0, 0, 1, qr/die in BEGIN/, ], 269 # run-time exception 270 [ 'd', 1, 0, 0, qr/its_dead_jim/, ], 271 # success with caught exception 272 [ 'eval { die "blah" }; 99', 0, 1, 1, qr/^$/, ], 273); 274 275 276for my $fn_type (qw(eval_pv eval_sv call_sv)) { 277 278 my $warn_msg; 279 local $SIG{__WARN__} = sub { $warn_msg .= $_[0] }; 280 281 for my $body (@bodies) { 282 my ($code, $is_fn_name, $expect_success, 283 $has_inner_die, $expected_err_qr) = @$body; 284 285 # call_sv can only handle function names, not code snippets 286 next if $fn_type eq 'call_sv' and !$is_fn_name; 287 288 for my $keep (0, G_KEEPERR) { 289 my $keep_desc = $keep ? 'G_KEEPERR' : '0'; 290 291 my $desc; 292 my $expect = $expect_success; 293 294 undef $warn_msg; 295 $@ = 'pre-err'; 296 297 my @ret; 298 if ($fn_type eq 'eval_pv') { 299 # eval_pv returns its result rather than a 'succeed' boolean 300 $expect = $expect ? '99' : undef; 301 302 # eval_pv doesn't support G_KEEPERR, but it has a croak 303 # boolean arg instead, so switch on that instead 304 if ($keep) { 305 $desc = "eval { eval_pv('$code', 1) }"; 306 @ret = eval { eval_pv($code, 1); '99' }; 307 # die in eval returns empty list 308 push @ret, undef unless @ret; 309 } 310 else { 311 $desc = "eval_pv('$code', 0)"; 312 @ret = eval_pv($code, 0); 313 } 314 } 315 elsif ($fn_type eq 'eval_sv') { 316 $desc = "eval_sv('$code', G_LIST|$keep_desc)"; 317 @ret = eval_sv($code, G_LIST|$keep); 318 } 319 elsif ($fn_type eq 'call_sv') { 320 $desc = "call_sv('$code', G_EVAL|G_LIST|$keep_desc)"; 321 @ret = call_sv($code, G_EVAL|G_LIST|$keep); 322 } 323 is(scalar @ret, ($expect_success && $fn_type ne 'eval_pv') ? 2 : 1, 324 "$desc - number of returned args"); 325 is($ret[-1], $expect, "$desc - return value"); 326 327 if ($keep && $fn_type ne 'eval_pv') { 328 # G_KEEPERR doesn't propagate into inner evals, requires etc 329 unless ($keep && $has_inner_die) { 330 is($@, 'pre-err', "$desc - \$@ unmodified"); 331 } 332 $@ = $warn_msg; 333 } 334 else { 335 is($warn_msg, undef, "$desc - __WARN__ not called"); 336 unlike($@, qr/pre-err/, "$desc - \$@ modified"); 337 } 338 like($@, $expected_err_qr, "$desc - the correct error message"); 339 } 340 } 341} 342 343{ 344 use feature "fc"; 345 use strict; 346 # the XS eval_sv() returns the count of results 347 is(eval_sv('my $z = fc("A") eq fc("a"); 1', G_LIST), 0, 348 "don't inherit hints by default (so the eval fails)"); 349 is(eval_sv('my $z = fc("A") eq fc("a"); 1', G_LIST | G_USEHINTS), 1, 350 "inherit hints when requested (so the eval succeeds)") 351 or diag($@); 352 # prevent Variable "$z" is not imported 353 no warnings 'misc'; 354 is(eval_sv('$z = 1', G_LIST), 1, 355 "don't inherit hints (strict) by default, so the eval succeeds"); 356 is(eval_sv('$z = 1', G_LIST | G_USEHINTS), 0, 357 "inherit hints (strict) when requested, so the eval fails"); 358} 359 360# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up 361# a new jump level but before pushing an eval context, leading to 362# stack corruption 363SKIP: { 364 skip("Your perl was built without taint support", 1) 365 unless $Config{taint_support}; 366 367 fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint'); 368use XS::APItest; 369 370my $x = 0; 371sub f { 372 eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; }; 373 $x++; 374 $a <=> $b; 375} 376 377eval { my @a = sort f 2, 1; $x++}; 378print "x=$x\n"; 379EOF 380} 381