#!perl -w
use strict;
use Test::More;
BEGIN { use_ok('XS::APItest') };
use vars qw($XS_VERSION $VERSION);
# This is what the code expects
my $real_version = $XS::APItest::VERSION;
sub default {
return ($_[0], undef) if @_;
return ($XS_VERSION, 'XS_VERSION') if defined $XS_VERSION;
return ($VERSION, 'VERSION');
}
sub expect_good {
my $package = $_[0];
my $version = @_ >= 2 ? ", $_[1]" : '';
local $Test::Builder::Level = $Test::Builder::Level + 1;
is_deeply([XS_VERSION_defined(@_)], [],
"Is good for $package$version");
is_deeply([XS_VERSION_undef(@_)], [],
"Is good for $package$version with #undef XS_VERSION");
}
sub expect_bad {
my $what = shift;
my $package = $_[0];
my $desc; # String to use in test descriptions
if (defined $what) {
$what = quotemeta('$' . $package . '::' . $what);
} else {
$what = 'bootstrap parameter';
}
if (@_ >= 2) {
$desc = "$_[0], $_[1]";
} else {
$desc = $_[0];
}
is(eval {XS_VERSION_defined(@_); "Oops"}, undef, "Is bad for $desc");
like($@,
qr/$package object version $real_version does not match $what/,
'expected error message');
is_deeply([XS_VERSION_undef(@_)], [],
"but is good for $desc with #undef XS_VERSION");
}
# With neither $VERSION nor $XS_VERSION defined, no check is made if no version
# is passed in
expect_good('dummy_package');
foreach ($real_version, version->new($real_version)) {
expect_good('dummy_package', $_);
}
foreach (3.14, version->new(3.14)) {
expect_bad(undef, 'dummy_package', $_);
}
my @versions = ($real_version, version->new($real_version),
3.14, version->new(3.14));
# Package variables
foreach $XS_VERSION (undef, @versions) {
foreach $VERSION (undef, @versions) {
my ($expect, $what) = default();
if (defined $expect) {
if ($expect eq $real_version) {
expect_good('main');
} else {
expect_bad($what, 'main');
}
}
foreach my $param (@versions) {
my ($expect, $what) = default($param);
if ($expect eq $real_version) {
expect_good('main', $param);
} else {
expect_bad($what, 'main', $param);
}
}
}
}
{
my $count = 0;
{
package Counter;
our @ISA = 'version';
sub new {
++$count;
return version::new(@_);
}
sub DESTROY {
--$count;
}
}
{
my $var = Counter->new();
is ($count, 1, "1 object exists");
is (eval {XS_VERSION_empty('main', $var); 1}, undef);
like ($@, qr/Invalid version format \(version required\)/);
}
is ($count, 0, "no objects exist");
}
is_deeply([XS_APIVERSION_valid("Pie")], [], "XS_APIVERSION_BOOTCHECK passes");
is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef,
"XS_APIVERSION_BOOTCHECK croaks for an invalid version");
like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/,
"expected error");
my @xsreturn;
@xsreturn = XS::APItest::XSUB::xsreturn(2);
is scalar @xsreturn, 2, 'returns a list of 2 elements';
is $xsreturn[0], 0;
is $xsreturn[1], 1;
my $xsreturn = XS::APItest::XSUB::xsreturn(3);
is $xsreturn, 2, 'returns the last item on the stack';
( $xsreturn ) = XS::APItest::XSUB::xsreturn(3);
is $xsreturn, 0, 'gets the first item on the stack';
is XS::APItest::XSUB::xsreturn_iv(), -2**31+1, 'XSRETURN_IV returns signed int';
is XS::APItest::XSUB::xsreturn_uv(), 2**31+1, 'XSRETURN_UV returns unsigned int';
is XS::APItest::XSUB::xsreturn_nv(), 0.25, 'XSRETURN_NV returns double';
is XS::APItest::XSUB::xsreturn_pv(), "returned", 'XSRETURN_PV returns string';
is XS::APItest::XSUB::xsreturn_pvn(), "returned", 'XSRETURN_PVN returns string with length';
ok !XS::APItest::XSUB::xsreturn_no(), 'XSRETURN_NO returns falsey';
ok XS::APItest::XSUB::xsreturn_yes(), 'XSRETURN_YES returns truthy';
is XS::APItest::XSUB::xsreturn_undef(), undef, 'XSRETURN_UNDEF returns undef in scalar context';
my @xs_undef = XS::APItest::XSUB::xsreturn_undef();
is scalar @xs_undef, 1, 'XSRETURN_UNDEF returns a single-element list';
is $xs_undef[0], undef, 'XSRETURN_UNDEF returns undef in list context';
my @xs_empty = XS::APItest::XSUB::xsreturn_empty();
is scalar @xs_empty, 0, 'XSRETURN_EMPTY returns empty list in array context';
my $xs_empty = XS::APItest::XSUB::xsreturn_empty();
is $xs_empty, undef, 'XSRETURN_EMPTY returns undef in scalar context';
done_testing();