This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e7c1545b5e61bb29629421234b3eabdf4e52056d
[perl5.git] / 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 => 240;
22
23 BEGIN {
24     require '../../t/test.pl';
25     plan(240);
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     no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
40     die "its_dead_jim\n";
41 }
42
43 my $obj = bless [], 'Foo';
44
45 sub Foo::meth {
46     return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
47     shift;
48     shift;
49     unshift @_, 'b';
50     pop @_;
51     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
52 }
53
54 sub Foo::d {
55     no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
56     die "its_dead_jim\n";
57 }
58
59 for my $test (
60     # flags      args           expected         description
61     [ G_VOID,    [ ],           [ qw(z 1) ],     '0 args, G_VOID' ],
62     [ G_VOID,    [ qw(a p q) ], [ qw(z 1) ],     '3 args, G_VOID' ],
63     [ G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR' ],
64     [ G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR' ],
65     [ G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY' ],
66     [ G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
67     [ G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
68     [ G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
69 )
70 {
71     my ($flags, $args, $expected, $description) = @$test;
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_sv('f', $flags, @$args) ], $expected),
80         "$description call_sv('f')");
81
82     ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
83         "$description call_pv('f')");
84
85     ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
86         $expected), "$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_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n"
96                             : "its_dead_jim\n";
97         $@ = "before\n";
98         ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
99                     $returnval),
100                     "$desc G_EVAL call_sv('d')");
101         is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
102
103         $@ = "before\n";
104         ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], 
105                     $returnval),
106                     "$desc G_EVAL call_pv('d')");
107         is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
108
109         $@ = "before\n";
110         ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
111                     $returnval),
112                     "$desc eval_sv('d()')");
113         is($@, $exp_err, "$desc eval_sv('d()') - \$@");
114
115         $@ = "before\n";
116         ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
117                     $returnval),
118                     "$desc G_EVAL call_method('d')");
119         is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
120     }
121
122     ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
123         $expected), "$description G_NOARGS call_sv('f')");
124
125     ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
126         $expected), "$description G_NOARGS call_pv('f')");
127
128     ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
129         $expected), "$description G_NOARGS eval_sv('f(@_)')");
130
131     # XXX call_method(G_NOARGS) isn't tested: I'm assuming
132     # it's not a sensible combination. DAPM.
133
134     ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
135         [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
136
137     ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
138         [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
139
140     ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
141         [ @$returnval,
142                 "its_dead_jim\n", '' ]),
143         "$description eval { eval_sv('d') }");
144
145     ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
146         [ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
147
148 };
149
150 is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
151 is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
152 is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
153 is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
154 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
155 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
156
157 # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
158 # a new jump level but before pushing an eval context, leading to
159 # stack corruption
160
161 fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint');
162 use XS::APItest;
163
164 my $x = 0;
165 sub f {
166     eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
167     $x++;
168     $a <=> $b;
169 }
170
171 eval { my @a = sort f 2, 1;  $x++};
172 print "x=$x\n";
173 EOF
174