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     chdir 't' if -d 't';
   8     @INC = '../lib';
   9     push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
  10     require Config; import Config;
  11     if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
  12         # Look, I'm using this fully-qualified variable more than once!
  13         my $arch = $MacPerl::Architecture;
  14         print "1..0 # Skip: XS::APItest was not built\n";
  15         exit 0;
  16     }
  17 }
  18
  19 use warnings;
  20 use strict;
  21
  22 use Test::More tests => 239;
  23
  24 BEGIN { use_ok('XS::APItest') };
  25
  26 #########################
  27
  28 sub f {
  29     shift;
  30     unshift @_, 'b';
  31     pop @_;
  32     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
  33 }
  34
  35 sub d {
  36     no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
  37     die "its_dead_jim\n";
  38 }
  39
  40 my $obj = bless [], 'Foo';
  41
  42 sub Foo::meth {
  43     return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
  44     shift;
  45     shift;
  46     unshift @_, 'b';
  47     pop @_;
  48     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
  49 }
  50
  51 sub Foo::d {
  52     no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
  53     die "its_dead_jim\n";
  54 }
  55
  56 for my $test (
  57     # flags      args           expected         description
  58     [ G_VOID,    [ ],           [ qw(z 1) ],     '0 args, G_VOID' ],
  59     [ G_VOID,    [ qw(a p q) ], [ qw(z 1) ],     '3 args, G_VOID' ],
  60     [ G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR' ],
  61     [ G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR' ],
  62     [ G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY' ],
  63     [ G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
  64     [ G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
  65     [ G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
  66 )
  67 {
  68     my ($flags, $args, $expected, $description) = @$test;
  69
  70     ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
  71         "$description call_sv(\\&f)");
  72
  73     ok(eq_array( [ call_sv(*f,  $flags, @$args) ], $expected),
  74         "$description call_sv(*f)");
  75
  76     ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
  77         "$description call_sv('f')");
  78
  79     ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
  80         "$description call_pv('f')");
  81
  82     ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
  83         $expected), "$description eval_sv('f(args)')");
  84
  85     ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
  86         "$description call_method('meth')");
  87
  88     for my $keep (0, G_KEEPERR) {
  89         my $desc = $description . ($keep ? ' G_KEEPERR' : '');
  90         my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n"
  91                             : "its_dead_jim\n";
  92         $@ = "before\n";
  93         ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
  94                     $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
  95                     "$desc G_EVAL call_sv('d')");
  96         is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
  97
  98         $@ = "before\n";
  99         ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ],
 100                     $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
 101                     "$desc G_EVAL call_pv('d')");
 102         is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
 103
 104         $@ = "before\n";
 105         ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
 106                     $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
 107                     "$desc eval_sv('d()')");
 108         is($@, $exp_err, "$desc eval_sv('d()') - \$@");
 109
 110         $@ = "before\n";
 111         ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
 112                     $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
 113                     "$desc G_EVAL call_method('d')");
 114         is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
 115     }
 116
 117     ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
 118         $expected), "$description G_NOARGS call_sv('f')");
 119
 120     ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
 121         $expected), "$description G_NOARGS call_pv('f')");
 122
 123     ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
 124         $expected), "$description G_NOARGS eval_sv('f(@_)')");
 125
 126     # XXX call_method(G_NOARGS) isn't tested: I'm assuming
 127     # it's not a sensible combination. DAPM.
 128
 129     ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
 130         [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
 131
 132     ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
 133         [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
 134
 135     ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
 136         [ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1),
 137                 "its_dead_jim\n", undef ]),
 138         "$description eval { eval_sv('d') }");
 139
 140     ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
 141         [ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
 142
 143 };
 144
 145 is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
 146 is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
 147 is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
 148 is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
 149 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
 150 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");