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

bulk88 · bulk88 · commit e3ff370bcf3c · 2024-11-01T12:24:31.000-04:00
-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. This commit was specifically written for #16654 but there are dozens or 100s of them #19112
diff --git 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
@@ -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
@@ -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
@@ -125,9 +125,7 @@ XXX Remove this section if F<Porting/corelist-perldelta.pl> did not add any cont
 
 =item *
 
-L<XXX> 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<XS::APItest> has been upgraded from version 1.38 to 1.39.
 
 =item *
 
diff --git 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
@@ -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 = 0;
 #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 = 1;
+          goto die_mismatched_rmv_c_args;
+        }
     }
 
     if(key & HSf_SETXSUBFN) {     /* this might be called from a module bootstrap */
@@ -5599,32 +5600,67 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
         if (PERLDB_LINE_OR_SAVESRC)
             (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
+       uninited data if we are executing in a surprise 2nd, auto-loaded by OS,
+       diff maj ver, libperl.so/.dll.*/
+        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))
-                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 */
+                    Perl_croak_nocontext("Perl API version %s of %s does not match %s",
+                                          api_p, SvPV_nolen(PL_stack_base[ax + 0]),
+                                          "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);
