+
+/* Perl_xs_handshake():
+ implement the various XS_*_BOOTCHECK macros, which are added to .c
+ files by ExtUtils::ParseXS, to check that the perl the module was built
+ with is binary compatible with the running perl.
+
+ usage:
+ Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
+ [U32 items, U32 ax], [char * api_version], [char * xs_version])
+
+ 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
+ "PerlInterpreter *" and represents the callers context; otherwise it is
+ of type "CV *", and is the boot xsub's CV.
+
+ v_my_perl will catch where a threaded future perl526.dll calling IO.dll
+ for example, and IO.dll was linked with threaded perl524.dll, and both
+ perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
+ successfully can load IO.dll into the process but simultaneously it
+ loaded an interpreter of a different version into the process, and XS
+ code will naturally pass SV*s created by perl524.dll for perl526.dll to
+ use through perl526.dll's my_perl->Istack_base.
+
+ v_my_perl cannot be the first arg, since then 'key' will be out of
+ place in a threaded vs non-threaded mixup; and analyzing the key
+ number's bitfields won't reveal the problem, since it will be a valid
+ key (unthreaded perl) on interp side, but croak will report the XS mod's
+ key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
+ it's a threaded perl and an unthreaded XS module, threaded perl will
+ look at an uninit C stack or an uninit register to get 'key'
+ (remember that it assumes that the 1st arg is the interp cxt).
+
+ 'file' is the source filename of the caller.
+*/
+
+I32
+Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
+{
+ va_list args;
+ U32 items, ax;
+ void * got;
+ void * need;
+#ifdef PERL_IMPLICIT_CONTEXT
+ dTHX;
+ tTHX xs_interp;
+#else
+ CV* cv;
+ SV *** xs_spp;
+#endif
+ PERL_ARGS_ASSERT_XS_HANDSHAKE;
+ va_start(args, file);
+
+ got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
+ need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
+ 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
+ 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 */
+#ifdef PERL_IMPLICIT_CONTEXT
+ xs_interp = (tTHX)v_my_perl;
+ got = xs_interp;
+ need = my_perl;
+#else
+/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
+ loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
+ but the DynaLoder/Perl that started the process and loaded the XS DLL is
+ unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
+ through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
+ location in the unthreaded perl binary) stored in CV * to figure out if this
+ Perl_xs_handshake was called by the same pp_entersub */
+ cv = (CV*)v_my_perl;
+ xs_spp = (SV***)CvHSCXT(cv);
+ got = xs_spp;
+ need = &PL_stack_sp;
+#endif
+ 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 handshake key %p, needed %p)\n",
+ file, got, need);
+ }
+
+ if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
+ SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
+ PL_xsubfilename = file; /* so the old name must be restored for
+ additional XSUBs to register themselves */
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
+ }
+
+ if(key & HSf_POPMARK) {
+ ax = POPMARK;
+ { SV **mark = PL_stack_base + ax++;
+ { dSP;
+ items = (I32)(SP - MARK);
+ }
+ }
+ } else {
+ items = va_arg(args, U32);
+ ax = va_arg(args, U32);
+ }
+ {
+ 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);
+ }
+ }
+ {
+ U32 xsverlen;
+ assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
+ if((xsverlen = HS_GETXSVERLEN(key)))
+ S_xs_version_bootcheck(aTHX_
+ items, ax, va_arg(args, char*), xsverlen);
+ }
+ va_end(args);
+ return ax;
+}
+
+
+STATIC void
+S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
https://perl5.git.perl.org / perl5.git / blobdiff