| 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 | |
| dedbcade |
22 | # Test::MJore doesn't have fresh_perl_is() yet |
| 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 | |
| dedbcade |
140 | #use Data::Dumper; print Dumper([ eval { eval_sv('d', $flags), $@ }, $@ ]); |
| 141 | # print Dumper([ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1), |
| 142 | # "its_dead_jim\n", undef ]); |
| d1f347d7 |
143 | ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ], |
| 144 | [ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1), |
| dedbcade |
145 | "its_dead_jim\n", '' ]), |
| d1f347d7 |
146 | "$description eval { eval_sv('d') }"); |
| 147 | |
| 148 | ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ], |
| 149 | [ "its_dead_jim\n" ]), "$description eval { call_method('d') }"); |
| 150 | |
| 151 | }; |
| 152 | |
| 153 | is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)"); |
| 154 | is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)"); |
| 155 | is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)"); |
| 156 | is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@"); |
| 157 | is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }"); |
| 158 | is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@"); |
| dedbcade |
159 | |
| 160 | # DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up |
| 161 | # a new jump level but before pushing an eval context, leading to |
| 162 | # stack corruption |
| 163 | |
| 164 | fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint'); |
| 165 | use XS::APItest; |
| 166 | |
| 167 | my $x = 0; |
| 168 | sub f { |
| 169 | eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; }; |
| 170 | $x++; |
| 171 | $a <=> $b; |
| 172 | } |
| 173 | |
| 174 | eval { my @a = sort f 2, 1; $x++}; |
| 175 | print "x=$x\n"; |
| 176 | EOF |
| 177 | |
projects / p5sagit/p5-mst-13.2.git / blame