This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
93742b1ba8b57fb95dea50a44e2e0e9ba794cc8a
[perl5.git] / ext / XS-APItest / t / xsub_h.t
1 #!perl -w
2 use strict;
3
4 use Test::More;
5
6 BEGIN { use_ok('XS::APItest') };
7
8 use vars qw($XS_VERSION $VERSION);
9
10 # This is what the code expects
11 my $real_version = $XS::APItest::VERSION;
12
13 sub default {
14     return ($_[0], undef) if @_;
15     return ($XS_VERSION, 'XS_VERSION') if defined $XS_VERSION;
16     return ($VERSION, 'VERSION');
17 }
18
19 sub expect_good {
20     my $package = $_[0];
21     my $version = exists $_[1] ? ", $_[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
30 sub 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 (exists $_[1]) {
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
57 expect_good('dummy_package');
58
59 foreach ($real_version, version->new($real_version)) {
60     expect_good('dummy_package', $_);
61 }
62
63 foreach (3.14, version->new(3.14)) {
64     expect_bad(undef, 'dummy_package', $_);
65 }
66
67 my @versions = ($real_version, version->new($real_version),
68                 3.14, version->new(3.14));
69
70 # Package variables
71 foreach $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
117 is_deeply([XS_APIVERSION_valid("Pie")], [], "XS_APIVERSION_BOOTCHECK passes");
118 is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef,
119    "XS_APIVERSION_BOOTCHECK croaks for an invalid version");
120 like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/,
121      "expected error");
122
123 done_testing();