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;
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
=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
--- /dev/null
+#!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) } - \$@");
https://perl5.git.perl.org / perl5.git / commitdiff