This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS::APItest tests for XS_VERSION_BOOTCHECK.
authorNicholas Clark <nick@ccl4.org>
Thu, 7 Oct 2010 14:47:14 +0000 (15:47 +0100)
committerNicholas Clark <nick@ccl4.org>
Thu, 7 Oct 2010 14:47:14 +0000 (15:47 +0100)
MANIFEST
ext/XS-APItest/APItest.xs
ext/XS-APItest/Makefile.PL
ext/XS-APItest/XSUB-undef-XS_VERSION.xs [new file with mode: 0644]
ext/XS-APItest/t/xsub_h.t [new file with mode: 0644]

index d779482..314968e 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3404,7 +3404,9 @@ ext/XS-APItest/t/temp_lv_sub.t    XS::APItest: tests for lvalue subs returning temp
 ext/XS-APItest/t/utf16_to_utf8.t       Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/xs_special_subs_require.t     for require too
 ext/XS-APItest/t/xs_special_subs.t     Test that XS BEGIN/CHECK/INIT/END work
+ext/XS-APItest/t/xsub_h.t      Tests for XSUB.h
 ext/XS-APItest/typemap
+ext/XS-APItest/XSUB-undef-XS_VERSION.xs        XS code needing #undef XS_VERSION
 ext/XS-Typemap/Makefile.PL     XS::Typemap extension
 ext/XS-Typemap/README          XS::Typemap extension
 ext/XS-Typemap/stdio.c         XS::Typemap extension
index 4b3d470..3322922 100644 (file)
@@ -605,6 +605,8 @@ static int my_keyword_plugin(pTHX_
     }
 }
 
+XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
+
 #include "const-c.inc"
 
 MODULE = XS::APItest           PACKAGE = XS::APItest
@@ -613,6 +615,17 @@ INCLUDE: const-xs.inc
 
 INCLUDE: numeric.xs
 
+MODULE = XS::APItest           PACKAGE = XS::APItest::XSUB
+
+BOOT:
+    newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
+
+void
+XS_VERSION_defined(...)
+    PPCODE:
+        XS_VERSION_BOOTCHECK;
+        XSRETURN_EMPTY;
+
 MODULE = XS::APItest:Hash              PACKAGE = XS::APItest::Hash
 
 void
index 3af0eb4..084de96 100644 (file)
@@ -10,7 +10,7 @@ WriteMakefile(
     ABSTRACT_FROM      => 'APItest.pm', # retrieve abstract from module
     AUTHOR             => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>, Andrew Main (Zefram) <zefram@fysh.org>',
     'C'                 => ['exception.c', 'core.c', 'notcore.c'],
-    'OBJECT'            => '$(BASEEXT)$(OBJ_EXT) $(O_FILES)',
+    'OBJECT'            => '$(BASEEXT)$(OBJ_EXT) XSUB-undef-XS_VERSION$(OBJ_EXT) $(O_FILES)',
     realclean => {FILES        => 'const-c.inc const-xs.inc'},
     ($Config{gccversion} && $Config{d_attribute_deprecated} ?
       (CCFLAGS => $Config{ccflags} . ' -Wno-deprecated-declarations') : ()),
diff --git a/ext/XS-APItest/XSUB-undef-XS_VERSION.xs b/ext/XS-APItest/XSUB-undef-XS_VERSION.xs
new file mode 100644 (file)
index 0000000..9fdf4d4
--- /dev/null
@@ -0,0 +1,18 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+/* We have to be in a different .xs so that we can do this:  */
+
+#undef XS_VERSION
+#include "XSUB.h"
+
+/* This can't be "MODULE = XS::APItest" as then we get duplicate bootstraps.  */
+MODULE = XS::APItest::XSUB     PACKAGE = XS::APItest::XSUB
+
+PROTOTYPES: DISABLE
+
+void
+XS_VERSION_undef(...)
+    PPCODE:
+        XS_VERSION_BOOTCHECK;
+        XSRETURN_EMPTY;
diff --git a/ext/XS-APItest/t/xsub_h.t b/ext/XS-APItest/t/xsub_h.t
new file mode 100644 (file)
index 0000000..c25b3a9
--- /dev/null
@@ -0,0 +1,92 @@
+#!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 = exists $_[1] ? ", $_[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 (exists $_[1]) {
+       $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);
+           }
+       }
+    }
+}
+
+done_testing();