util.c: Perl_xs_handshake print API ver mismatch before interp mismatch

ext/XS-APItest/APItest.pm

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.41';
+our $VERSION = '1.42';
 
 require XSLoader;
 

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

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/);

pod/perldiag.pod

@@ -3689,7 +3689,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<"Perl API version %s of %s does not match %s"|perldiag/"Perl API version %s of %s does not match %s">
+error.
 
 =item Locale '%s' contains (at least) the following characters which
 have unexpected meanings: %s  The Perl program will use the expected
@@ -5281,7 +5283,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<perlxs|perlxs>.
+
+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 files
+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 C<.pm> or C<.pl>
+file making a call to L<DynaLoader|DynaLoader> or L<XSLoader|XSLoader>, which
+then calls OS specific mechanisms to load the shared library file into the Perl
+process. The OS specific mechanism 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.
 
 =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/

util.c

@@ -5513,7 +5513,7 @@ Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
    The meaning of the varargs is determined the U32 key arg (which is not
    a format string). The fields of key are assembled by using HS_KEY().
 
-   Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
+   Under PERL_IMPLICIT_CONTEXT, the v_my_perl arg is of type
    "PerlInterpreter *" and represents the callers context; otherwise it is
    of type "CV *", and is the boot xsub's CV.
 
@@ -5535,7 +5535,17 @@ Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
    (remember that it assumes that the 1st arg is the interp cxt).
 
    'file' is the source filename of the caller.
-*/
+
+   Expansion provisions: Argument char * api_version is private to
+   #include "perl.h". EU::MM and XS authors can't modify it. perl.h could
+   place an aligned const pointer to a const static C struct before or after
+   the C string, or just the later. Or add argument #8 and 1 new bit in U32 key.
+   Arg U32 key can't be changed to arg U64 key, on OSes/CPUs with 32bit void*s.
+   Some/all 32b CCs will invisibly splice in "U32 key64_upper" as arg 2,
+   shifting all other args down the C stack, and breaking ABI compat of this C
+   function between any and all old/new permutations of a .xs vs a libperl.
+
+   See GH PR #22719 for other expansion provisions. */
 
 Stack_off_t
 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
@@ -5546,6 +5556,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;
@@ -5561,7 +5572,7 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
     if (UNLIKELY(got != need))
         goto bad_handshake;
 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process
-   by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
+   by a XS DLL compiled against the wrong interp DLL b/c of bad @INC, and the
    2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
    dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
    passed to the XS DLL */
@@ -5585,10 +5596,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,31 +5611,71 @@ 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
+       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);
         if((apiverlen = HS_GETAPIVERLEN(key))) {
             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))
-                croak("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 above */
+                    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_const(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 an interpreter 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 irreversibly
+corrupted now because new Perl API C func function have already been
+linked/injected into the 1st perl.bin from the 2nd incompatible "surprise"
+new libperl.so/.dll in the same process.
+
+A quick process exit using only libc APIs, no perl APIs, is the 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);