Commit | Line | Data |
d1f347d7 |
1 | #!perl -w |
2 | |
3 | # test the various call-into-perl-from-C functions |
4 | # DAPM Aug 2004 |
5 | |
6 | BEGIN { |
d1f347d7 |
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 | |
43d2322d |
20 | # Test::More doesn't have fresh_perl_is() yet |
dedbcade |
21 | # use Test::More tests => 240; |
d1f347d7 |
22 | |
dedbcade |
23 | BEGIN { |
2adbc9b6 |
24 | require '../../t/test.pl'; |
dedbcade |
25 | plan(240); |
26 | use_ok('XS::APItest') |
27 | }; |
d1f347d7 |
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 | |
b8d2d791 |
91 | my $returnval = ((($flags & G_WANT) == G_ARRAY) || ($flags & G_DISCARD)) |
92 | ? [0] : [ undef, 1 ]; |
d1f347d7 |
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) ], |
b8d2d791 |
99 | $returnval), |
d1f347d7 |
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) ], |
b8d2d791 |
105 | $returnval), |
d1f347d7 |
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) ], |
b8d2d791 |
111 | $returnval), |
d1f347d7 |
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) ], |
b8d2d791 |
117 | $returnval), |
d1f347d7 |
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), $@ }, $@ ], |
b8d2d791 |
141 | [ @$returnval, |
dedbcade |
142 | "its_dead_jim\n", '' ]), |
d1f347d7 |
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) } - \$@"); |
dedbcade |
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 | |
2adbc9b6 |
161 | fresh_perl_is(<<'EOF', "x=2", { switches => ['-T', '-I../../lib'] }, 'eval_sv() taint'); |
dedbcade |
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 | |