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

-this fatal error is much more common by general users than
 I (orig author) anticipated when I added this check in 5.21.6/2014.
 I assumed Unix land never had ABI/SEGVing or upgrade problems previous.
 I wrote the code for my dev style, and my personal setup as test cases,
 and test cases with Win32-isms.
 If other OSes get bad-ABI caught, its a plus, but I thought they wouldn't.

-the hexadecimal handshake keys were intended to be a debug tool for core
 devs hacking on something and for XS authors with very complicated
 Makefile.PL s. To catch -D CCFLAGS arg dropouts on the way to the final
 cmd line invocation of the CC.

-I say the handshake keys are a terrible UI for general "power users" and
 non-coder sys admins

-the Perl API version strings ARE available, even with mismatched
 interp struct sizes, and those are much more user friendly to print
 as a error. It should be obvious that from now on, non-power users
 can figure out on their own (no community help) that a way to "fix"
 XS boot handshake is to force "reinstall" the "left side perl"
 or "right side perl" through the OS Pkg Manager.

-after this commit, much more often! but not always, users will see a
 "Perl API 5.X.Y against 5.X+1.Y is incompatible" fatal message instead
 of the those Core-dev only undocumented hex handshake keys. Sadly the
 technical P5P debug info is now gone/lost/hidden if
 "Perl API 5.X.Y against 5.X+1.Y is incompatible" fatal message executes.

-core devs, obv will have v5.X.Y matching v5.X.Y in blead perl, so they
 will still get the handshake keys hex numbers. Since API strings are
 same.

-Package name will get downgraded to "Foo.c" if interp size is wrong, or
 2 libperls in 1 proc happens. But the major improvement is showing left
 and right side Perl API version info.

-The POD text is very wordy and detailed, since it has been observed over
 time, some Perl users, do not know Perl's backend implementation is
 written in the ISO C language. Or other Perl users on various internet
 forums or social media, do not know what the term XS code is.

 While they can sucessful write and debug private personal Perl 5 code,
 they only read the POD of CPAN modules and only use public documented
 APIs of CPAN modules, and rarely or never look at
 "private source" of CPAN modules. Therefore this group of users truly
 do not know MANY MANY p5p core modules and CPAN modules, make call outs
 to another language (C), and are unable to troubleshoot a .so file on
 their filing system is responsible for the error. Since they do not know
 about XS code concept, their troubleshooting goes very wrong as they
 keeping looking and keep incorrect diagnosing the problem to ASCII text
 somewhere in the Perl ecosystem. Either Perl source code, they wrote, or
 CPAN Perl source code, or a CSV, YAML or JSON file related to Perl.

 Make it clear, that some "Perl 5 modules" written in ASCII text in Perl 5
 lang, depend on "foreign" C code and "foreign" .so/.dll files at runtime.
 First time Perl coders, can mistakenly assume the Perl 5 interpreter
 has JIT and self bootstraps to OS binaries from only Perl 5 source like
 Google Chrome V8 and Raku. So they guess, as first time users,
 Perl 5 also does it and has no dependency on legacy technologies like
 C or C++.

This commit was specifically written for

#16654

but there are dozens or 100s of them

#19112

Author: bulk88

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