1#!perl -w 2use strict; 3 4use Test::More; 5 6BEGIN { use_ok('XS::APItest') }; 7 8use vars qw($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 123done_testing(); 124