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(435);
  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 foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
 153     foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
 154         my $warn;
 155         local $SIG{__WARN__} = sub { $warn .= $_[0] };
 156         $@ = $outx;
 157         $warn = "";
 158         call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL);
 159         ok ref($@) eq ref($inx) && $@ eq $inx;
 160         $warn =~ s/ at [^\n]*\n\z//;
 161         is $warn, "";
 162         $@ = $outx;
 163         $warn = "";
 164         call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR);
 165         ok ref($@) eq ref($outx) && $@ eq $outx;
 166         $warn =~ s/ at [^\n]*\n\z//;
 167         is $warn, $inx ? "\t(in cleanup) $inx" : "";
 168     }
 169 }
 170
 171 {
 172     no warnings "misc";
 173     my $warn = "";
 174     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 175     call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
 176     is $warn, "";
 177 }
 178
 179 {
 180     my $warn = "";
 181     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 182     call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
 183     is $warn, "\t(in cleanup) aa\n";
 184 }
 185
 186 is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
 187 is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
 188 is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
 189 is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
 190 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
 191 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
 192
 193
 194 # #3719 - check that the eval call variants handle exceptions correctly,
 195 # and do the right thing with $@, both with and without G_KEEPERR set.
 196
 197 sub f99 { 99 };
 198
 199
 200 for my $fn_type (0..2) { #   0:eval_pv   1:eval_sv   2:call_sv
 201
 202     my $warn_msg;
 203     local $SIG{__WARN__} = sub { $warn_msg .= $_[0] };
 204
 205     for my $code_type (0..3) {
 206
 207         # call_sv can only handle function names, not code snippets
 208         next if $fn_type == 2 and ($code_type == 1 or $code_type == 2);
 209
 210         my $code = (
 211             'f99',                          # ok
 212             '$x=',                          # compile-time err
 213             'BEGIN { die "die in BEGIN"}',  # compile-time exception
 214             'd',                            # run-time exception
 215         )[$code_type];
 216
 217         for my $keep (0, G_KEEPERR) {
 218             my $keep_desc = $keep ? 'G_KEEPERR' : '0';
 219
 220             my $desc;
 221             my $expect = ($code_type == 0) ? 1 : 0;
 222
 223             undef $warn_msg;
 224             $@ = 'pre-err';
 225
 226             my @ret;
 227             if ($fn_type == 0) { # eval_pv
 228                 # eval_pv returns its result rather than a 'succeed' boolean
 229                 $expect = $expect ? '99' : undef;
 230
 231                 # eval_pv doesn't support G_KEEPERR, but it has a croak
 232                 # boolean arg instead, so switch on that instead
 233                 if ($keep) {
 234                     $desc = "eval { eval_pv('$code', 1) }";
 235                     @ret = eval { eval_pv($code, 1); '99' };
 236                     # die in eval returns empty list
 237                     push @ret, undef unless @ret;
 238                 }
 239                 else {
 240                     $desc = "eval_pv('$code', 0)";
 241                     @ret = eval_pv($code, 0);
 242                 }
 243             }
 244             elsif ($fn_type == 1) { # eval_sv
 245                 $desc = "eval_sv('$code', G_ARRAY|$keep_desc)";
 246                 @ret = eval_sv($code, G_ARRAY|$keep);
 247             }
 248             elsif ($fn_type == 2) { # call_sv
 249                 $desc = "call_sv('$code', G_EVAL|G_ARRAY|$keep_desc)";
 250                 @ret = call_sv($code, G_EVAL|G_ARRAY|$keep);
 251             }
 252             is(scalar @ret, ($code_type == 0 && $fn_type != 0) ? 2 : 1,
 253                             "$desc - number of returned args");
 254             is($ret[-1], $expect, "$desc - return value");
 255
 256             if ($keep && $fn_type != 0) {
 257                 # G_KEEPERR doesn't propagate into inner evals, requires etc
 258                 unless ($keep && $code_type == 2) {
 259                     is($@, 'pre-err', "$desc - \$@ unmodified");
 260                 }
 261                 $@ = $warn_msg;
 262             }
 263             else {
 264                 is($warn_msg, undef, "$desc - __WARN__ not called");
 265                 unlike($@, 'pre-err', "$desc - \$@ modified");
 266             }
 267             like($@,
 268                 (
 269                     qr/^$/,
 270                     qr/syntax error/,
 271                     qr/die in BEGIN/,
 272                     qr/its_dead_jim/,
 273                 )[$code_type],
 274                 "$desc - the correct error message");
 275         }
 276     }
 277 }
 278
 279 # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
 280 # a new jump level but before pushing an eval context, leading to
 281 # stack corruption
 282
 283 fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
 284 use XS::APItest;
 285
 286 my $x = 0;
 287 sub f {
 288     eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
 289     $x++;
 290     $a <=> $b;
 291 }
 292
 293 eval { my @a = sort f 2, 1;  $x++};
 294 print "x=$x\n";
 295 EOF
 296