diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index d782d91f9ef2c..05df69ef8c782 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.38'; +our $VERSION = '1.39'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 1676ded76c8dd..59890619c26c9 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1941,6 +1941,65 @@ xsreturn_empty() PPCODE: XSRETURN_EMPTY; +void +test_mismatch_xs_handshake_api_ver(...) + ALIAS: + test_mismatch_xs_handshake_bad_struct = 1 + test_mismatch_xs_handshake_bad_struct_and_ver = 2 + PPCODE: + if(ix == 0) { +#ifdef MULTIPLICITY + Perl_xs_handshake(HS_KEYp(sizeof(PerlInterpreter), + TRUE, NULL, FALSE, + sizeof("v1.1337.0")-1, + sizeof("")-1), + HS_CXT, __FILE__, items, ax, + "v1.1337.0"); +#else + Perl_xs_handshake(HS_KEYp(sizeof(struct PerlHandShakeInterpreter), + FALSE, NULL, FALSE, + sizeof("v1.1337.0")-1, + sizeof("")-1), + HS_CXT, __FILE__, items, ax, + "v1.1337.0"); +#endif + } + else if(ix == 1) { +#ifdef MULTIPLICITY + Perl_xs_handshake(HS_KEYp(sizeof(PerlInterpreter)+1, + TRUE, NULL, FALSE, + sizeof("v" PERL_API_VERSION_STRING)-1, + sizeof("")-1), + HS_CXT, __FILE__, items, ax, + "v" PERL_API_VERSION_STRING); +#else + Perl_xs_handshake(HS_KEYp(sizeof(struct PerlHandShakeInterpreter)+1, + FALSE, NULL, FALSE, + sizeof("v" PERL_API_VERSION_STRING)-1, + sizeof("")-1), + HS_CXT, __FILE__, items, ax, + "v" PERL_API_VERSION_STRING); +#endif + } + else { +#ifdef MULTIPLICITY + Perl_xs_handshake(HS_KEYp(sizeof(PerlInterpreter)+1, + TRUE, NULL, FALSE, + sizeof("v1.1337.0")-1, + sizeof("")-1), + HS_CXT, __FILE__, items, ax, + "v1.1337.0"); +#else + Perl_xs_handshake(HS_KEYp(sizeof(struct PerlHandShakeInterpreter)+1, + FALSE, NULL, FALSE, + sizeof("v1.1337.0")-1, + sizeof("")-1), + HS_CXT, __FILE__, items, ax, + "v1.1337.0"); +#endif + } + + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash void diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t index d17d67c96209f..e31c2db4d7cdc 100644 --- a/ext/XS-APItest/t/call.t +++ b/ext/XS-APItest/t/call.t @@ -11,7 +11,7 @@ use strict; BEGIN { require '../../t/test.pl'; - plan(544); + plan(547); use_ok('XS::APItest') }; use Config; @@ -385,3 +385,13 @@ eval { my @a = sort f 2, 1; $x++}; print "x=$x\n"; EOF } + +fresh_perl_like('use XS::APItest;' + .'XS::APItest::XSUB::test_mismatch_xs_handshake_api_ver("Dog");' + , qr/\QPerl API version v1.1337.0 of Dog does not match\E/); +fresh_perl_like('use XS::APItest;' + .'XS::APItest::XSUB::test_mismatch_xs_handshake_bad_struct("Dog");' + , qr/\Q loadable library and perl binaries are mismatched (got first handshake\E/); +fresh_perl_like('use XS::APItest;' + .'XS::APItest::XSUB::test_mismatch_xs_handshake_bad_struct_and_ver("Dog");' + , qr/\QPerl API version v1.1337.0 of APItest.xs does not match\E/); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 7e2cb30bf8427..d751252468687 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -125,9 +125,7 @@ XXX Remove this section if F did not add any cont =item * -L has been upgraded from version A.xx to B.yy. - -XXX If there was something important to note about this change, include that here. +L has been upgraded from version 1.38 to 1.39. =item * diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 1af0dcc364b16..02e253b9bc700 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -5198,7 +5198,10 @@ redirected it with select().) =item Perl API version %s of %s does not match %s (F) The XS module in question was compiled against a different incompatible -version of Perl than the one that has loaded the XS module. +version of Perl than the one that has loaded the XS module. The XS module +name will be replaced by a C<.c> file name, that serves as a hint to the module +name, if the internal differences between the 2 incompatible versions +are large enough to prevent obtaining the module name. =item Perl folding rules are not up-to-date for 0x%X; please use the perlbug utility to report; in regex; marked by S<<-- HERE> in m/%s/ diff --git a/util.c b/util.c index fa946b4153c2d..9816980b43664 100644 --- a/util.c +++ b/util.c @@ -5546,6 +5546,7 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) void * got; void * need; const char *stage = "first"; + bool in_abi_mismatch = FALSE; #ifdef MULTIPLICITY dTHX; tTHX xs_interp; @@ -5585,10 +5586,10 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) stage = "second"; if(UNLIKELY(got != need)) { bad_handshake:/* recycle branch and string from above */ - if(got != (void *)HSf_NOCHK) - noperl_die("%s: loadable library and perl binaries are mismatched" - " (got %s handshake key %p, needed %p)\n", - file, stage, got, need); + if(got != (void *)HSf_NOCHK) { + in_abi_mismatch = TRUE; + goto die_mismatched_rmv_c_args; + } } if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */ @@ -5600,19 +5601,34 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) (void)gv_fetchfile(file); */ } + die_mismatched_rmv_c_args: if(key & HSf_POPMARK) { - ax = POPMARK; - { SV **mark = PL_stack_base + ax++; - { dSP; - items = (Stack_off_t)(SP - MARK); - } + /* Don't touch the local unthreaded or threaded Perl stack if mismatched + ABI. The pointers inside the mark stack vars and @_ vars are + are uninitialized data if we are executing in an unexpected second + libperl.{so,dll} with a different major version. The second libperl + possibly was auto-loaded by the OS, as a dependency of the out of + date XS shared library file. */ + if(in_abi_mismatch) { + ax = Stack_off_t_MAX; /* silence CC & poison */ + items = Stack_off_t_MAX; + } + else { + ax = POPMARK; + SV **mark = PL_stack_base + ax++; + dSP; + items = (Stack_off_t)(SP - MARK); } } else { items = va_arg(args, Stack_off_t); ax = va_arg(args, Stack_off_t); } - assert(ax >= 0); - assert(items >= 0); + + if(!in_abi_mismatch) { + assert(ax >= 0); + assert(items >= 0); + } + { U32 apiverlen; assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); @@ -5620,11 +5636,36 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) char * api_p = va_arg(args, char*); if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 || memNE(api_p, "v" PERL_API_VERSION_STRING, - sizeof("v" PERL_API_VERSION_STRING)-1)) - Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s", - api_p, SVfARG(PL_stack_base[ax + 0]), - "v" PERL_API_VERSION_STRING); - } + sizeof("v" PERL_API_VERSION_STRING)-1)) { + if(in_abi_mismatch) + noperl_die("Perl API version %s of %s does not match %s", + api_p, file, "v" PERL_API_VERSION_STRING); + else {/* use %s for SV * for string literal reuse with abv */ + SV * package_sv = PL_stack_base[ax + 0]; + Perl_croak_nocontext("Perl API version %s of %s does not match %s", + api_p, SvPV_nolen(package_sv), + "v" PERL_API_VERSION_STRING); + } + } /* memcmp() */ + } /* if user wants API Ver Check (xsubpp default is on ) */ + +/* The gentler error above couldn't be shown. Maybe the 2 API ver strings DID +str eq match. So its a interp build time/Configure problem, or 3rd party patches +by OS vendors. Or system perl vs /home "local perl" battles. +No choice but to show the full hex debugging info and die. + +On Unix, the 1st correct original libperl/perl.bin, on ELF, is irreverisbly +corrupted now. B/c new Perl API C func bodies have already been +linked/injected into the 1st perl.bin from the 2nd incompatible "surprise" +new libperl.so/.dll in the same proc. + +A quick process exit using only libc APIs, no perl APIs, is only fool proof, +cross platform way to prevent a SEGV. +*/ + if(in_abi_mismatch) + noperl_die("%s: loadable library and perl binaries are mismatched" + " (got %s handshake key %p, needed %p)\n", + file, stage, got, need); } { U32 xsverlen = HS_GETXSVERLEN(key);