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 => 342; 11 12BEGIN { 13 require '../../t/test.pl'; 14 plan(437); 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# 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, 6, "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, [ ], [ 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 89 my $returnval = ((($flags & G_WANT) == G_ARRAY) || ($flags & G_DISCARD)) 90 ? [0] : [ undef, 1 ]; 91 for my $keep (0, G_KEEPERR) { 92 my $desc = $description . ($keep ? ' G_KEEPERR' : ''); 93 my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : ""; 94 my $exp_err = $keep ? "before\n" 95 : "its_dead_jim\n"; 96 my $warn; 97 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 98 $@ = "before\n"; 99 $warn = ""; 100 ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ], 101 $returnval), 102 "$desc G_EVAL call_sv('d')"); 103 is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@"); 104 is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning"); 105 106 $@ = "before\n"; 107 $warn = ""; 108 ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], 109 $returnval), 110 "$desc G_EVAL call_pv('d')"); 111 is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@"); 112 is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning"); 113 114 $@ = "before\n"; 115 $warn = ""; 116 ok(eq_array( [ eval_sv('d()', $flags|$keep) ], 117 $returnval), 118 "$desc eval_sv('d()')"); 119 is($@, $exp_err, "$desc eval_sv('d()') - \$@"); 120 is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning"); 121 122 $@ = "before\n"; 123 $warn = ""; 124 ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ], 125 $returnval), 126 "$desc G_EVAL call_method('d')"); 127 is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@"); 128 is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning"); 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), $@ }, $@ ], 150 [ @$returnval, 151 "its_dead_jim\n", '' ]), 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 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 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{ 196 no warnings "misc"; 197 my $warn = ""; 198 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 199 call_sv(sub { use warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR); 200 is $warn, "\t(in cleanup) aa\n"; 201} 202 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) } - \$@"); 209 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; 220 local $SIG{__WARN__} = sub { $warn_msg .= $_[0] }; 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) { 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) { 274 # G_KEEPERR doesn't propagate into inner evals, requires etc 275 unless ($keep && $code_type == 2) { 276 is($@, 'pre-err', "$desc - \$@ unmodified"); 277 } 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 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 300fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint'); 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 314