In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/7b20c7cd49d506897c54f5ed022a5e5b5f8c594a?hp=3a1b08584501598bc42fd18f6ce9ba051e867bc4>
- Log ----------------------------------------------------------------- commit 7b20c7cd49d506897c54f5ed022a5e5b5f8c594a Author: Nicholas Clark <[email protected]> Date: Thu Oct 7 15:47:14 2010 +0100 XS::APItest tests for XS_VERSION_BOOTCHECK. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 + ext/XS-APItest/APItest.xs | 13 ++++ ext/XS-APItest/Makefile.PL | 2 +- ext/XS-APItest/XSUB-undef-XS_VERSION.xs | 18 ++++++ ext/XS-APItest/t/xsub_h.t | 92 +++++++++++++++++++++++++++++++ 5 files changed, 126 insertions(+), 1 deletions(-) create mode 100644 ext/XS-APItest/XSUB-undef-XS_VERSION.xs create mode 100644 ext/XS-APItest/t/xsub_h.t diff --git a/MANIFEST b/MANIFEST index d779482..314968e 100644 --- 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 diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4b3d470..3322922 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -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 diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index 3af0eb4..084de96 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -10,7 +10,7 @@ WriteMakefile( ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module AUTHOR => 'Tim Jenness <[email protected]>, Christian Soeller <[email protected]>, Hugo van der Sanden <[email protected]>, Andrew Main (Zefram) <[email protected]>', '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 index 0000000..9fdf4d4 --- /dev/null +++ b/ext/XS-APItest/XSUB-undef-XS_VERSION.xs @@ -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 index 0000000..c25b3a9 --- /dev/null +++ b/ext/XS-APItest/t/xsub_h.t @@ -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(); -- Perl5 Master Repository
