From: Dave Mitchell Date: Sat, 7 Aug 2004 15:10:40 +0000 (+0000) Subject: Add tests for XS call_*() API X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d1f347d75f2751e771d6a00c52f4e5f14bfd93ea;p=p5sagit%2Fp5-mst-13.2.git Add tests for XS call_*() API p4raw-id: //depot/perl@23203 --- diff --git a/MANIFEST b/MANIFEST index bdbac65..b8f73c8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -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 dd36fbf..1fdae73 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. Output is sent to STDOUT. +=item B, B, B + +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 + +Evalulates the passed SV. Result handling is done the same as for +C etc. + +=item B + +Excercises the C function of the same name in scalar context. Returns the +same SV that the C function returns. + +=item B + +Excercises the C function of the same name. Returns nothing. + =back =head1 SEE ALSO @@ -147,7 +185,7 @@ Hugo van der Sanden Ehv@crypt.compulink.co.ukE =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 9b3d331..c675b83 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 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 40f1d65..dd520af 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. The G_KEEPERR flag was introduced in Perl version 5.002.