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