From: Dave Mitchell <davem@fdisolutions.com>
Date: Sat, 7 Aug 2004 15:10:40 +0000 (+0000)
Subject: Add tests for XS call_*() API
X-Git-Tag: perl-5.9.2~714
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/d1f347d75f2751e771d6a00c52f4e5f14bfd93ea

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<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 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<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 f0c29f8..1feded8 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 0000000..b33e12a
--- /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 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<no warnings 'misc'>.
 
 The G_KEEPERR flag was introduced in Perl version 5.002.