xs_version_bootcheck() must use mortals, as {new,upg}_version() can croak.

It's unlikely that XS_VERSION will contain a bogus version string (for long),
but the value passed in (or derived from $XS_VERSION or $VERSION) might well.
For that case, without this change, temporary SVs created within
xs_version_bootcheck() won't be freed (before interpreter exit).

6 files changed, 51 insertions, 8 deletions

diff --git a/MANIFEST b/MANIFEST
index 314968e07e..6ce960d1e9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3406,6 +3406,7 @@ 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-redefined-macros.xs	XS code needing redefined macros.
 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
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 332292292c..7b3b10cf37 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -606,6 +606,7 @@ static int my_keyword_plugin(pTHX_
 }
 
 XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
+XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
 
 #include "const-c.inc"
 
@@ -619,6 +620,7 @@ MODULE = XS::APItest		PACKAGE = XS::APItest::XSUB
 
 BOOT:
     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
+    newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
 
 void
 XS_VERSION_defined(...)
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index 084de96034..6a0271a913 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 <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) XSUB-undef-XS_VERSION$(OBJ_EXT) $(O_FILES)',
+    'OBJECT'            => '$(BASEEXT)$(OBJ_EXT) XSUB-undef-XS_VERSION$(OBJ_EXT) XSUB-redefined-macros$(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-redefined-macros.xs b/ext/XS-APItest/XSUB-redefined-macros.xs
new file mode 100644
index 0000000000..afbe6741fa
--- /dev/null
+++ b/ext/XS-APItest/XSUB-redefined-macros.xs
@@ -0,0 +1,19 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+/* We have to be in a different .xs so that we can do this:  */
+
+#undef XS_VERSION
+#define XS_VERSION ""
+#include "XSUB.h"
+
+/* This can't be "MODULE = XS::APItest" as then we get duplicate bootstraps.  */
+MODULE = XS::APItest::XSUB1	PACKAGE = XS::APItest::XSUB
+
+PROTOTYPES: DISABLE
+
+void
+XS_VERSION_empty(...)
+    PPCODE:
+        XS_VERSION_BOOTCHECK;
+        XSRETURN_EMPTY;
diff --git a/ext/XS-APItest/t/xsub_h.t b/ext/XS-APItest/t/xsub_h.t
index c25b3a9a8c..8735552152 100644
--- a/ext/XS-APItest/t/xsub_h.t
+++ b/ext/XS-APItest/t/xsub_h.t
@@ -89,4 +89,29 @@ foreach $XS_VERSION (undef, @versions) {
     }
 }
 
+{
+    my $count = 0;
+    {
+	package Counter;
+	our @ISA = 'version';
+	sub new {
+	    ++$count;
+	    return version::new(@_);
+	}
+
+	sub DESTROY {
+	    --$count;
+	}
+    }
+
+    {
+	my $var = Counter->new();
+	is ($count, 1, "1 object exists");
+	is (eval {XS_VERSION_empty('main', $var); 1}, undef);
+	like ($@, qr/Invalid version format \(version required\)/);
+    }
+
+    is ($count, 0, "no objects exist");
+}
+
 done_testing();
diff --git a/util.c b/util.c
index 16fae9a027..e09147fe37 100644
--- a/util.c
+++ b/util.c
@@ -6486,10 +6486,9 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
     }
     if (sv) {
 	SV *xpt = NULL;
-	SV *xssv = Perl_newSVpvn(aTHX_ xs_p, xs_len);
+	SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
 	SV *pmsv = sv_derived_from(sv, "version")
-	    ? SvREFCNT_inc_simple_NN(sv)
-	    : new_version(sv);
+	    ? sv : sv_2mortal(new_version(sv));
 	xssv = upg_version(xssv, 0);
 	if ( vcmp(pmsv,xssv) ) {
 	    xpt = Perl_newSVpvf(aTHX_ "%s object version %"SVf
@@ -6501,11 +6500,8 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
 				vn ? vn : "bootstrap parameter",
 				SVfARG(Perl_sv_2mortal(aTHX_ vstringify(pmsv))));
 	    Perl_sv_2mortal(aTHX_ xpt);
-	}
-	SvREFCNT_dec(xssv);
-	SvREFCNT_dec(pmsv);
-	if (xpt)
 	    Perl_croak_sv(aTHX_ xpt);
+	}
     }
 }