diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4196bbb7004c..5c4d45ab6c47 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 d17d67c96209..e31c2db4d7cd 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/perldiag.pod b/pod/perldiag.pod index 7f981e8008ff..80834bed3961 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3637,7 +3637,9 @@ does when displayed. (P) A dynamic loading library C<.so> or C<.dll> was being loaded into the process that was built against a different build of perl than the said library was compiled against. Reinstalling the XS module will -likely fix this error. +likely fix this error. This error is a less commonly seen subset of +L +error. =item Locale '%s' contains (at least) the following characters which have unexpected meanings: %s The Perl program will use the expected @@ -5216,7 +5218,31 @@ 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. If the internal +differences between the 2 incompatible Perl versions are large enough to +prevent obtaining the full module name causing this error message, a +C<.c> file name will be shown in this error message instead of the full module +name. The C<.c> file name serves as a hint, to help identify the module +causing this error. + +The term XS module, does not mean, a C<.pm> file. This error is not directly +caused by Perl code inside a particular C<.pm> file or C<.pl> file. +Instead this error is only caused by OS and CPU specific, "shared library" +files created by a C or C++ compiler. This file format is called a +C<.so>, C<.dll>, C<.dylib>, C<.bundle> or C<.sl> on Perl's most popular +operating systems. These shared library files are a part of the XS API +documented in L. + +Each OS has a different file extension or no extension for shared libraries. +But shared library files on all OSes are non-text, unprintable, binary file +formats with raw machine code inside of them created by a C or C++ compiler. + +The C<.so> or C<.dll> or equivalent is usually loaded by a sequence of a +C<.pm> or C<.pl> file making a call to L or +L. Which then calls OS specific mechanisms to load the +shared library file into the Perl process. The OS specific mechanisms +then calls a function or subroutine inside the particular C<.so> or C<.dll> +file. That particular C<.so> or C<.dll> file then throws this error message. =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 fa946b4153c2..9816980b4366 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);