diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS/APItest/APItest.pm | 42 | ||||
| -rw-r--r-- | ext/XS/APItest/APItest.xs | 89 | ||||
| -rw-r--r-- | ext/XS/APItest/MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS/APItest/t/call.t | 150 | ||||
| -rw-r--r-- | pod/perlcall.pod | 6 |
6 files changed, 286 insertions, 3 deletions
@@ -798,6 +798,7 @@ ext/XS/APItest/APItest.xs XS::APItest extension ext/XS/APItest/Makefile.PL XS::APItest extension ext/XS/APItest/MANIFEST XS::APItest extension ext/XS/APItest/README XS::APItest extension +ext/XS/APItest/t/call.t XS::APItest extension ext/XS/APItest/t/hash.t XS::APItest extension ext/XS/APItest/t/printf.t XS::APItest extension ext/XS/APItest/t/push.t XS::APItest extension diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm index dd36fbf2af..1fdae73668 100644 --- a/ext/XS/APItest/APItest.pm +++ b/ext/XS/APItest/APItest.pm @@ -16,9 +16,23 @@ our @EXPORT = qw( print_double print_int print_long print_float print_long_double have_long_double print_flush mpushp mpushn mpushi mpushu mxpushp mxpushn mxpushi mxpushu + call_sv call_pv call_method eval_sv eval_pv require_pv + G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS + G_KEEPERR G_NODEBUG G_METHOD ); -our $VERSION = '0.04'; +# from cop.h +sub G_SCALAR() { 0 } +sub G_ARRAY() { 1 } +sub G_VOID() { 128 } +sub G_DISCARD() { 2 } +sub G_EVAL() { 4 } +sub G_NOARGS() { 8 } +sub G_KEEPERR() { 16 } +sub G_NODEBUG() { 32 } +sub G_METHOD() { 64 } + +our $VERSION = '0.05'; bootstrap XS::APItest $VERSION; @@ -133,6 +147,30 @@ correctly by C<printf>. Output is sent to STDOUT. +=item B<call_sv>, B<call_pv>, B<call_method> + +These exercise the C calls of the same names. Everything after the flags +arg is passed as the the args to the called function. They return whatever +the C function itself pushed onto the stack, plus the return value from +the function; for example + + call_sv( sub { @_, 'c' }, G_ARRAY, 'a', 'b'); # returns 'a', 'b', 'c', 3 + call_sv( sub { @_ }, G_SCALAR, 'a', 'b'); # returns 'b', 1 + +=item B<eval_sv> + +Evalulates the passed SV. Result handling is done the same as for +C<call_sv()> etc. + +=item B<eval_pv> + +Excercises the C function of the same name in scalar context. Returns the +same SV that the C function returns. + +=item B<require_pv> + +Excercises the C function of the same name. Returns nothing. + =back =head1 SEE ALSO @@ -147,7 +185,7 @@ Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt> =head1 COPYRIGHT AND LICENSE -Copyright (C) 2002 Tim Jenness, Christian Soeller, Hugo van der Sanden. +Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden. All Rights Reserved. This library is free software; you can redistribute it and/or modify diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs index 9b3d331e28..c675b839d5 100644 --- a/ext/XS/APItest/APItest.xs +++ b/ext/XS/APItest/APItest.xs @@ -243,3 +243,92 @@ mxpushu() mXPUSHu(2); mXPUSHu(3); XSRETURN(3); + + +void +call_sv(sv, flags, ...) + SV* sv + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_sv(sv, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_pv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_pv(subname, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_method(methname, flags, ...) + char* methname + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_method(methname, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +eval_sv(sv, flags) + SV* sv + I32 flags + PREINIT: + I32 i; + PPCODE: + PUTBACK; + i = eval_sv(sv, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +SV* +eval_pv(p, croak_on_error) + const char* p + I32 croak_on_error + PREINIT: + I32 i; + PPCODE: + PUTBACK; + EXTEND(SP, 1); + PUSHs(eval_pv(p, croak_on_error)); + +void +require_pv(pv) + const char* pv + PREINIT: + I32 i; + PPCODE: + PUTBACK; + require_pv(pv); + + + + diff --git a/ext/XS/APItest/MANIFEST b/ext/XS/APItest/MANIFEST index f0c29f8485..1feded88b8 100644 --- a/ext/XS/APItest/MANIFEST +++ b/ext/XS/APItest/MANIFEST @@ -3,6 +3,7 @@ MANIFEST README APItest.pm APItest.xs +t/call.t t/hash.t t/printf.t t/push.t diff --git a/ext/XS/APItest/t/call.t b/ext/XS/APItest/t/call.t new file mode 100644 index 0000000000..b33e12a8d5 --- /dev/null +++ b/ext/XS/APItest/t/call.t @@ -0,0 +1,150 @@ +#!perl -w + +# test the various call-into-perl-from-C functions +# DAPM Aug 2004 + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bXS\/APItest\b/) { + # Look, I'm using this fully-qualified variable more than once! + my $arch = $MacPerl::Architecture; + print "1..0 # Skip: XS::APItest was not built\n"; + exit 0; + } +} + +use warnings; +use strict; + +use Test::More tests => 239; + +BEGIN { use_ok('XS::APItest') }; + +######################### + +sub f { + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +sub d { + no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning + die "its_dead_jim\n"; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth { + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +sub Foo::d { + no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning + die "its_dead_jim\n"; +} + +for my $test ( + # flags args expected description + [ G_VOID, [ ], [ qw(z 1) ], '0 args, G_VOID' ], + [ G_VOID, [ qw(a p q) ], [ qw(z 1) ], '3 args, G_VOID' ], + [ G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + + ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected), + "$description call_sv(\\&f)"); + + ok(eq_array( [ call_sv(*f, $flags, @$args) ], $expected), + "$description call_sv(*f)"); + + ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected), + "$description call_sv('f')"); + + ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected), + "$description call_pv('f')"); + + ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], + $expected), "$description eval_sv('f(args)')"); + + ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected), + "$description call_method('meth')"); + + for my $keep (0, G_KEEPERR) { + my $desc = $description . ($keep ? ' G_KEEPERR' : ''); + my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n" + : "its_dead_jim\n"; + $@ = "before\n"; + ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_sv('d')"); + is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_pv('d')"); + is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ eval_sv('d()', $flags|$keep) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc eval_sv('d()')"); + is($@, $exp_err, "$desc eval_sv('d()') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_method('d')"); + is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@"); + } + + ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_sv('f')"); + + ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_pv('f')"); + + ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ], + $expected), "$description G_NOARGS eval_sv('f(@_)')"); + + # XXX call_method(G_NOARGS) isn't tested: I'm assuming + # it's not a sensible combination. DAPM. + + ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }"); + + ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }"); + + ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ], + [ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1), + "its_dead_jim\n", undef ]), + "$description eval { eval_sv('d') }"); + + ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_method('d') }"); + +}; + +is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)"); +is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)"); +is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)"); +is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@"); +is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }"); +is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@"); diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 40f1d65a7b..dd520afcaa 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -343,7 +343,11 @@ has no effect when G_EVAL is not used. When G_KEEPERR is used, any errors in the called code will be prefixed with the string "\t(in cleanup)", and appended to the current value -of C<$@>. +of C<$@>. an error will not be appended if that same error string is +already at the end of C<$@>. + +In addition, a warning is generated using the appended string. This can be +disabled using C<no warnings 'misc'>. The G_KEEPERR flag was introduced in Perl version 5.002. |