1#!perl -w 2use strict; 3 4use Test::More; 5 6BEGIN { use_ok('XS::APItest') }; 7 8our ($XS_VERSION, $VERSION); 9 10# This is what the code expects 11my $real_version = $XS::APItest::VERSION; 12 13sub default { 14 return ($_[0], undef) if @_; 15 return ($XS_VERSION, 'XS_VERSION') if defined $XS_VERSION; 16 return ($VERSION, 'VERSION'); 17} 18 19sub expect_good { 20 my $package = $_[0]; 21 my $version = @_ >= 2 ? ", $_[1]" : ''; 22 local $Test::Builder::Level = $Test::Builder::Level + 1; 23 is_deeply([XS_VERSION_defined(@_)], [], 24 "Is good for $package$version"); 25 26 is_deeply([XS_VERSION_undef(@_)], [], 27 "Is good for $package$version with #undef XS_VERSION"); 28} 29 30sub expect_bad { 31 my $what = shift; 32 my $package = $_[0]; 33 my $desc; # String to use in test descriptions 34 35 if (defined $what) { 36 $what = quotemeta('$' . $package . '::' . $what); 37 } else { 38 $what = 'bootstrap parameter'; 39 } 40 if (@_ >= 2) { 41 $desc = "$_[0], $_[1]"; 42 } else { 43 $desc = $_[0]; 44 } 45 46 is(eval {XS_VERSION_defined(@_); "Oops"}, undef, "Is bad for $desc"); 47 like($@, 48 qr/$package object version $real_version does not match $what/, 49 'expected error message'); 50 51 is_deeply([XS_VERSION_undef(@_)], [], 52 "but is good for $desc with #undef XS_VERSION"); 53} 54 55# With neither $VERSION nor $XS_VERSION defined, no check is made if no version 56# is passed in 57expect_good('dummy_package'); 58 59foreach ($real_version, version->new($real_version)) { 60 expect_good('dummy_package', $_); 61} 62 63foreach (3.14, version->new(3.14)) { 64 expect_bad(undef, 'dummy_package', $_); 65} 66 67my @versions = ($real_version, version->new($real_version), 68 3.14, version->new(3.14)); 69 70# Package variables 71foreach $XS_VERSION (undef, @versions) { 72 foreach $VERSION (undef, @versions) { 73 my ($expect, $what) = default(); 74 if (defined $expect) { 75 if ($expect eq $real_version) { 76 expect_good('main'); 77 } else { 78 expect_bad($what, 'main'); 79 } 80 } 81 foreach my $param (@versions) { 82 my ($expect, $what) = default($param); 83 if ($expect eq $real_version) { 84 expect_good('main', $param); 85 } else { 86 expect_bad($what, 'main', $param); 87 } 88 } 89 } 90} 91 92{ 93 my $count = 0; 94 { 95 package Counter; 96 our @ISA = 'version'; 97 sub new { 98 ++$count; 99 return version::new(@_); 100 } 101 102 sub DESTROY { 103 --$count; 104 } 105 } 106 107 { 108 my $var = Counter->new(); 109 is ($count, 1, "1 object exists"); 110 is (eval {XS_VERSION_empty('main', $var); 1}, undef); 111 like ($@, qr/Invalid version format \(version required\)/); 112 } 113 114 is ($count, 0, "no objects exist"); 115} 116 117is_deeply([XS_APIVERSION_valid("Pie")], [], "XS_APIVERSION_BOOTCHECK passes"); 118is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef, 119 "XS_APIVERSION_BOOTCHECK croaks for an invalid version"); 120like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/, 121 "expected error"); 122 123my @xsreturn; 124@xsreturn = XS::APItest::XSUB::xsreturn(2); 125is scalar @xsreturn, 2, 'returns a list of 2 elements'; 126is $xsreturn[0], 0; 127is $xsreturn[1], 1; 128 129my $xsreturn = XS::APItest::XSUB::xsreturn(3); 130is $xsreturn, 2, 'returns the last item on the stack'; 131 132( $xsreturn ) = XS::APItest::XSUB::xsreturn(3); 133is $xsreturn, 0, 'gets the first item on the stack'; 134 135is XS::APItest::XSUB::xsreturn_iv(), -2**31+1, 'XSRETURN_IV returns signed int'; 136is XS::APItest::XSUB::xsreturn_uv(), 2**31+1, 'XSRETURN_UV returns unsigned int'; 137is XS::APItest::XSUB::xsreturn_nv(), 0.25, 'XSRETURN_NV returns double'; 138is XS::APItest::XSUB::xsreturn_pv(), "returned", 'XSRETURN_PV returns string'; 139is XS::APItest::XSUB::xsreturn_pvn(), "returned", 'XSRETURN_PVN returns string with length'; 140ok !XS::APItest::XSUB::xsreturn_no(), 'XSRETURN_NO returns falsey'; 141ok XS::APItest::XSUB::xsreturn_yes(), 'XSRETURN_YES returns truthy'; 142 143is XS::APItest::XSUB::xsreturn_undef(), undef, 'XSRETURN_UNDEF returns undef in scalar context'; 144my @xs_undef = XS::APItest::XSUB::xsreturn_undef(); 145is scalar @xs_undef, 1, 'XSRETURN_UNDEF returns a single-element list'; 146is $xs_undef[0], undef, 'XSRETURN_UNDEF returns undef in list context'; 147 148my @xs_empty = XS::APItest::XSUB::xsreturn_empty(); 149is scalar @xs_empty, 0, 'XSRETURN_EMPTY returns empty list in array context'; 150my $xs_empty = XS::APItest::XSUB::xsreturn_empty(); 151is $xs_empty, undef, 'XSRETURN_EMPTY returns undef in scalar context'; 152 153 154done_testing(); 155