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(342);
  15     use_ok('XS::APItest')
  16 };
  17
  18 #########################
  19
  20 sub f {
  21     shift;
  22     unshift @_, 'b';
  23     pop @_;
  24     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
  25 }
  26
  27 sub d {
  28     die "its_dead_jim\n";
  29 }
  30
  31 my $obj = bless [], 'Foo';
  32
  33 sub Foo::meth {
  34     return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
  35     shift;
  36     shift;
  37     unshift @_, 'b';
  38     pop @_;
  39     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
  40 }
  41
  42 sub Foo::d {
  43     die "its_dead_jim\n";
  44 }
  45
  46 for my $test (
  47     # flags      args           expected         description
  48     [ G_VOID,    [ ],           [ qw(z 1) ],     '0 args, G_VOID' ],
  49     [ G_VOID,    [ qw(a p q) ], [ qw(z 1) ],     '3 args, G_VOID' ],
  50     [ G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR' ],
  51     [ G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR' ],
  52     [ G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY' ],
  53     [ G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
  54     [ G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
  55     [ G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
  56 )
  57 {
  58     my ($flags, $args, $expected, $description) = @$test;
  59
  60     ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
  61         "$description call_sv(\\&f)");
  62
  63     ok(eq_array( [ call_sv(*f,  $flags, @$args) ], $expected),
  64         "$description call_sv(*f)");
  65
  66     ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
  67         "$description call_sv('f')");
  68
  69     ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
  70         "$description call_pv('f')");
  71
  72     ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
  73         $expected), "$description eval_sv('f(args)')");
  74
  75     ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
  76         "$description call_method('meth')");
  77
  78     my $returnval = ((($flags & G_WANT) == G_ARRAY) || ($flags & G_DISCARD))
  79         ? [0] : [ undef, 1 ];
  80     for my $keep (0, G_KEEPERR) {
  81         my $desc = $description . ($keep ? ' G_KEEPERR' : '');
  82         my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : "";
  83         my $exp_err = $keep ? "before\n"
  84                             : "its_dead_jim\n";
  85         my $warn;
  86         local $SIG{__WARN__} = sub { $warn .= $_[0] };
  87         $@ = "before\n";
  88         $warn = "";
  89         ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
  90                     $returnval),
  91                     "$desc G_EVAL call_sv('d')");
  92         is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
  93         is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning");
  94
  95         $@ = "before\n";
  96         $warn = "";
  97         ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ],
  98                     $returnval),
  99                     "$desc G_EVAL call_pv('d')");
 100         is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
 101         is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning");
 102
 103         $@ = "before\n";
 104         $warn = "";
 105         ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
 106                     $returnval),
 107                     "$desc eval_sv('d()')");
 108         is($@, $exp_err, "$desc eval_sv('d()') - \$@");
 109         is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning");
 110
 111         $@ = "before\n";
 112         $warn = "";
 113         ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
 114                     $returnval),
 115                     "$desc G_EVAL call_method('d')");
 116         is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
 117         is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning");
 118     }
 119
 120     ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
 121         $expected), "$description G_NOARGS call_sv('f')");
 122
 123     ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
 124         $expected), "$description G_NOARGS call_pv('f')");
 125
 126     ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
 127         $expected), "$description G_NOARGS eval_sv('f(@_)')");
 128
 129     # XXX call_method(G_NOARGS) isn't tested: I'm assuming
 130     # it's not a sensible combination. DAPM.
 131
 132     ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
 133         [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
 134
 135     ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
 136         [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
 137
 138     ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
 139         [ @$returnval,
 140                 "its_dead_jim\n", '' ]),
 141         "$description eval { eval_sv('d') }");
 142
 143     ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
 144         [ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
 145
 146 };
 147
 148 foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
 149     foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
 150         my $warn;
 151         local $SIG{__WARN__} = sub { $warn .= $_[0] };
 152         $@ = $outx;
 153         $warn = "";
 154         call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL);
 155         ok ref($@) eq ref($inx) && $@ eq $inx;
 156         $warn =~ s/ at [^\n]*\n\z//;
 157         is $warn, "";
 158         $@ = $outx;
 159         $warn = "";
 160         call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR);
 161         ok ref($@) eq ref($outx) && $@ eq $outx;
 162         $warn =~ s/ at [^\n]*\n\z//;
 163         is $warn, $inx ? "\t(in cleanup) $inx" : "";
 164     }
 165 }
 166
 167 {
 168     no warnings "misc";
 169     my $warn = "";
 170     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 171     call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
 172     is $warn, "";
 173 }
 174
 175 {
 176     my $warn = "";
 177     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 178     call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
 179     is $warn, "\t(in cleanup) aa\n";
 180 }
 181
 182 is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
 183 is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
 184 is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
 185 is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
 186 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
 187 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
 188
 189 # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
 190 # a new jump level but before pushing an eval context, leading to
 191 # stack corruption
 192
 193 fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
 194 use XS::APItest;
 195
 196 my $x = 0;
 197 sub f {
 198     eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
 199     $x++;
 200     $a <=> $b;
 201 }
 202
 203 eval { my @a = sort f 2, 1;  $x++};
 204 print "x=$x\n";
 205 EOF
 206