Check API compatibility when loading xs modules

This adds PL_apiversion, allowing the API version of a running interpreter to be
introspected. It is used in the new XS_APIVERSION_BOOTCHECK macro, which is
added to the _boot function of every XS module, to compare it against the API
version the module has been compiled against. If the versions do not match, an
exception is thrown.

This doesn't fully prevent binary incompatible extensions to be loaded. It
merely compares PERL_API_* between compile- and runtime, and does not attempt to
solve the problem of identifying binary incompatible perls with the same API
version (i.e. the same perl version configured with and without DEBUGGING).

8 files changed, 43 insertions, 4 deletions

diff --git a/XSUB.h b/XSUB.h
index f3ba8027cd..939a7a64f7 100644
--- a/XSUB.h
+++ b/XSUB.h
@@ -243,6 +243,10 @@ Macro to verify that a PM module's $VERSION variable matches the XS
 module's C<XS_VERSION> variable.  This is usually handled automatically by
 C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
 
+=for apidoc Ams||XS_APIVERSION_BOOTCHECK
+Macro to verify that the perl api version an XS module has been compiled against
+matches the api version of the perl interpreter it's being loaded into.
+
 =head1 Simple Exception Handling Macros
 
 =for apidoc Ams||dXCPT
@@ -335,6 +339,26 @@ Rethrows a previously caught exception.  See L<perlguts/"Exception Handling">.
 #  define XS_VERSION_BOOTCHECK
 #endif
 
+#define XS_APIVERSION_BOOTCHECK						\
+    STMT_START {							\
+	SV *_xpt = NULL;						\
+	SV *_compver = Perl_newSVpv(aTHX_ "v" PERL_API_VERSION_STRING, 0); \
+	SV *_runver = new_version(PL_apiversion);			\
+	_compver = upg_version(_compver, 0);				\
+	if (vcmp(_compver, _runver)) {					\
+	    _xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf		\
+				 " of %s does not match %"SVf,		\
+				 SVfARG(Perl_sv_2mortal(aTHX_ vstringify(_compver))), \
+				 SvPV_nolen_const(ST(0)),		\
+				 SVfARG(Perl_sv_2mortal(aTHX_ vstringify(_runver)))); \
+	    Perl_sv_2mortal(aTHX_ _xpt);				\
+	}								\
+	SvREFCNT_dec(_compver);						\
+	SvREFCNT_dec(_runver);						\
+	if (_xpt)							\
+	    Perl_croak_sv(aTHX_ _xpt);					\
+    } STMT_END
+
 #ifdef NO_XSLOCKS
 #  define dXCPT             dJMPENV; int rEtV = 0
 #  define XCPT_TRY_START    JMPENV_PUSH(rEtV); if (rEtV == 0)
@@ -343,9 +367,9 @@ Rethrows a previously caught exception.  See L<perlguts/"Exception Handling">.
 #  define XCPT_RETHROW      JMPENV_JUMP(rEtV)
 #endif
 
-/* 
-   The DBM_setFilter & DBM_ckFilter macros are only used by 
-   the *DB*_File modules 
+/*
+   The DBM_setFilter & DBM_ckFilter macros are only used by
+   the *DB*_File modules
 */
 
 #define DBM_setFilter(db_type,code)				\
diff --git a/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index 385e2fb2ec..cde1a409ca 100644
--- a/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/cpan/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -1004,8 +1004,11 @@ EOF
   print Q(<<"EOF");
 #    PERL_UNUSED_VAR(cv); /* -W */
 #    PERL_UNUSED_VAR(items); /* -W */
+##ifdef XS_APIVERSION_BOOTCHECK
+#    XS_APIVERSION_BOOTCHECK;
+##endif
 EOF
-    
+
   print Q(<<"EOF") if $WantVersionChk ;
 #    XS_VERSION_BOOTCHECK ;
 #
diff --git a/embedvar.h b/embedvar.h
index 25c033c273..587bc94863 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -65,6 +65,7 @@
 #define PL_Xpv			(vTHX->IXpv)
 #define PL_amagic_generation	(vTHX->Iamagic_generation)
 #define PL_an			(vTHX->Ian)
+#define PL_apiversion		(vTHX->Iapiversion)
 #define PL_argvgv		(vTHX->Iargvgv)
 #define PL_argvout_stack	(vTHX->Iargvout_stack)
 #define PL_argvoutgv		(vTHX->Iargvoutgv)
@@ -395,6 +396,7 @@
 #define PL_IXpv			PL_Xpv
 #define PL_Iamagic_generation	PL_amagic_generation
 #define PL_Ian			PL_an
+#define PL_Iapiversion		PL_apiversion
 #define PL_Iargvgv		PL_argvgv
 #define PL_Iargvout_stack	PL_argvout_stack
 #define PL_Iargvoutgv		PL_argvoutgv
diff --git a/intrpvar.h b/intrpvar.h
index 1e01e43892..21fb933254 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -228,6 +228,7 @@ PERLVAR(Iwarnhook,	SV *)
 
 /* switches */
 PERLVAR(Ipatchlevel,	SV *)
+PERLVAR(Iapiversion,	SV *)
 PERLVAR(Ilocalpatches,	const char * const *)
 PERLVARI(Isplitstr,	const char *, " ")
 
diff --git a/perl.c b/perl.c
index d52d79f41e..404372c4dd 100644
--- a/perl.c
+++ b/perl.c
@@ -348,6 +348,7 @@ perl_construct(pTHXx)
     PL_stashcache = newHV();
 
     PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
+    PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
 
 #ifdef HAS_MMAP
     if (!PL_mmap_page_size) {
@@ -877,6 +878,7 @@ perl_destruct(pTHXx)
     Safefree(PL_inplace);
     PL_inplace = NULL;
     SvREFCNT_dec(PL_patchlevel);
+    SvREFCNT_dec(PL_apiversion);
 
     if (PL_e_script) {
 	SvREFCNT_dec(PL_e_script);
diff --git a/perl.h b/perl.h
index 32cf7873e1..59df0aaba7 100644
--- a/perl.h
+++ b/perl.h
@@ -4900,6 +4900,10 @@ typedef struct exitlistentry {
 				STRINGIFY(PERL_VERSION) "." \
 				STRINGIFY(PERL_SUBVERSION)
 
+#define PERL_API_VERSION_STRING	STRINGIFY(PERL_API_REVISION) "." \
+				STRINGIFY(PERL_API_VERSION) "." \
+				STRINGIFY(PERL_API_SUBVERSION)
+
 #ifdef PERL_GLOBAL_STRUCT
 struct perl_vars {
 #  include "perlvars.h"
diff --git a/perlapi.h b/perlapi.h
index 742bb3a586..869d5123d7 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -166,6 +166,8 @@ END_EXTERN_C
 #define PL_amagic_generation	(*Perl_Iamagic_generation_ptr(aTHX))
 #undef  PL_an
 #define PL_an			(*Perl_Ian_ptr(aTHX))
+#undef  PL_apiversion
+#define PL_apiversion		(*Perl_Iapiversion_ptr(aTHX))
 #undef  PL_argvgv
 #define PL_argvgv		(*Perl_Iargvgv_ptr(aTHX))
 #undef  PL_argvout_stack
diff --git a/sv.c b/sv.c
index 10e41a9c99..b2383fd536 100644
--- a/sv.c
+++ b/sv.c
@@ -12283,6 +12283,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     /* switches */
     PL_minus_c		= proto_perl->Iminus_c;
     PL_patchlevel	= sv_dup_inc(proto_perl->Ipatchlevel, param);
+    PL_apiversion	= sv_dup_inc(proto_perl->Iapiversion, param);
     PL_localpatches	= proto_perl->Ilocalpatches;
     PL_splitstr		= proto_perl->Isplitstr;
     PL_minus_n		= proto_perl->Iminus_n;