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 { |
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 | |
43d2322d |
22 | # Test::More doesn't have fresh_perl_is() yet |
dedbcade |
23 | # use Test::More tests => 240; |
d1f347d7 |
24 | |
dedbcade |
25 | BEGIN { |
26 | require './test.pl'; |
27 | plan(240); |
28 | use_ok('XS::APItest') |
29 | }; |
d1f347d7 |
30 | |
31 | ######################### |
32 | |
33 | sub f { |
34 | shift; |
35 | unshift @_, 'b'; |
36 | pop @_; |
37 | @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; |
38 | } |
39 | |
40 | sub d { |
41 | no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning |
42 | die "its_dead_jim\n"; |
43 | } |
44 | |
45 | my $obj = bless [], 'Foo'; |
46 | |
47 | sub Foo::meth { |
48 | return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; |
49 | shift; |
50 | shift; |
51 | unshift @_, 'b'; |
52 | pop @_; |
53 | @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; |
54 | } |
55 | |
56 | sub Foo::d { |
57 | no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning |
58 | die "its_dead_jim\n"; |
59 | } |
60 | |
61 | for my $test ( |
62 | # flags args expected description |
63 | [ G_VOID, [ ], [ qw(z 1) ], '0 args, G_VOID' ], |
64 | [ G_VOID, [ qw(a p q) ], [ qw(z 1) ], '3 args, G_VOID' ], |
65 | [ G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], |
66 | [ G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], |
67 | [ G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], |
68 | [ G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], |
69 | [ G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], |
70 | [ G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], |
71 | ) |
72 | { |
73 | my ($flags, $args, $expected, $description) = @$test; |
74 | |
75 | ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected), |
76 | "$description call_sv(\\&f)"); |
77 | |
78 | ok(eq_array( [ call_sv(*f, $flags, @$args) ], $expected), |
79 | "$description call_sv(*f)"); |
80 | |
81 | ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected), |
82 | "$description call_sv('f')"); |
83 | |
84 | ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected), |
85 | "$description call_pv('f')"); |
86 | |
87 | ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], |
88 | $expected), "$description eval_sv('f(args)')"); |
89 | |
90 | ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected), |
91 | "$description call_method('meth')"); |
92 | |
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 | $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), |
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 | $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), |
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 | $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), |
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 | $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), |
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 | [ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1), |
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 | |
161 | fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, '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 | |