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 BEGIN {
   7     push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
   8     require Config; import Config;
   9     if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
  10         # Look, I'm using this fully-qualified variable more than once!
  11         my $arch = $MacPerl::Architecture;
  12         print "1..0 # Skip: XS::APItest was not built\n";
  13         exit 0;
  14     }
  15 }
  16
  17 use warnings;
  18 use strict;
  19
  20 # Test::More doesn't have fresh_perl_is() yet
  21 # use Test::More tests => 342;
  22
  23 BEGIN {
  24     require '../../t/test.pl';
  25     plan(342);
  26     use_ok('XS::APItest')
  27 };
  28
  29 #########################
  30
  31 sub f {
  32     shift;
  33     unshift @_, 'b';
  34     pop @_;
  35     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
  36 }
  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         $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 foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
 160     foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
 161         my $warn;
 162         local $SIG{__WARN__} = sub { $warn .= $_[0] };
 163         $@ = $outx;
 164         $warn = "";
 165         call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL);
 166         ok ref($@) eq ref($inx) && $@ eq $inx;
 167         $warn =~ s/ at [^\n]*\n\z//;
 168         is $warn, "";
 169         $@ = $outx;
 170         $warn = "";
 171         call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR);
 172         ok ref($@) eq ref($outx) && $@ eq $outx;
 173         $warn =~ s/ at [^\n]*\n\z//;
 174         is $warn, $inx ? "\t(in cleanup) $inx" : "";
 175     }
 176 }
 177
 178 {
 179     no warnings "misc";
 180     my $warn = "";
 181     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 182     call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
 183     is $warn, "";
 184 }
 185
 186 {
 187     my $warn = "";
 188     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 189     call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
 190     is $warn, "\t(in cleanup) aa\n";
 191 }
 192
 193 is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
 194 is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
 195 is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
 196 is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
 197 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
 198 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
 199
 200 # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
 201 # a new jump level but before pushing an eval context, leading to
 202 # stack corruption
 203
 204 fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
 205 use XS::APItest;
 206
 207 my $x = 0;
 208 sub f {
 209     eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
 210     $x++;
 211     $a <=> $b;
 212 }
 213
 214 eval { my @a = sort f 2, 1;  $x++};
 215 print "x=$x\n";
 216 EOF
 217