diff options
-rw-r--r-- | XSUB.h | 60 | ||||
-rw-r--r-- | dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm | 25 | ||||
-rw-r--r-- | dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm | 6 | ||||
-rw-r--r-- | embed.fnc | 6 | ||||
-rw-r--r-- | embed.h | 1 | ||||
-rw-r--r-- | embedvar.h | 1 | ||||
-rw-r--r-- | ext/DynaLoader/dlutils.c | 2 | ||||
-rw-r--r-- | ext/re/re.xs | 2 | ||||
-rw-r--r-- | intrpvar.h | 1 | ||||
-rw-r--r-- | op.c | 86 | ||||
-rw-r--r-- | pod/perldiag.pod | 5 | ||||
-rw-r--r-- | proto.h | 18 | ||||
-rw-r--r-- | sv.c | 1 | ||||
-rw-r--r-- | util.c | 58 | ||||
-rw-r--r-- | util.h | 28 |
15 files changed, 193 insertions, 107 deletions
@@ -170,16 +170,23 @@ is a lexical $_ in scope. #else # define dXSARGS \ dSP; dAXMARK; dITEMS -/* These 2 macros are specialized replacements for dXSARGS macro. They may be - replaced with dXSARGS if no version checking is desired. The 2 macros factor - out common code in every BOOT XSUB. Computation of vars mark and items will - optimize away in most BOOT functions. Var ax can never be optimized away - since BOOT must return &PL_sv_yes by default from xsubpp */ +/* These 3 macros are replacements for dXSARGS macro only in bootstrap. + They factor out common code in every BOOT XSUB. Computation of vars mark + and items will optimize away in most BOOT functions. Var ax can never be + optimized away since BOOT must return &PL_sv_yes by default from xsubpp. + Note these macros are not drop in replacements for dXSARGS since they set + PL_xsubfilename. */ # define dXSBOOTARGSXSAPIVERCHK \ - I32 ax = XS_BOTHVERSION_POPMARK_BOOTCHECK; \ + I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ SV **mark = PL_stack_base + ax; dSP; dITEMS # define dXSBOOTARGSAPIVERCHK \ - I32 ax = XS_APIVERSION_POPMARK_BOOTCHECK; \ + I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ + SV **mark = PL_stack_base + ax; dSP; dITEMS +/* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do +#undef dXSBOOTARGSXSAPIVERCHK +#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */ +# define dXSBOOTARGSNOVERCHK \ + I32 ax = XS_SETXSUBFN_POPMARK; \ SV **mark = PL_stack_base + ax; dSP; dITEMS #endif @@ -336,37 +343,58 @@ Rethrows a previously caught exception. See L<perlguts/"Exception Handling">. #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ - Perl_xs_handshake(HS_KEY(FALSE, "", XS_VERSION), HS_CXT, items, ax, XS_VERSION) + Perl_xs_handshake(HS_KEY(FALSE, FALSE, "", XS_VERSION), HS_CXT, __FILE__, \ + items, ax, XS_VERSION) #else # define XS_VERSION_BOOTCHECK #endif #define XS_APIVERSION_BOOTCHECK \ - Perl_xs_handshake(HS_KEY(FALSE, "v" PERL_API_VERSION_STRING, ""), HS_CXT, items, ax, "v" PERL_API_VERSION_STRING) + Perl_xs_handshake(HS_KEY(FALSE, FALSE, "v" PERL_API_VERSION_STRING, ""), \ + HS_CXT, __FILE__, items, ax, "v" PERL_API_VERSION_STRING) /* public API, this is a combination of XS_VERSION_BOOTCHECK and XS_APIVERSION_BOOTCHECK in 1, and is backportable */ #ifdef XS_VERSION # define XS_BOTHVERSION_BOOTCHECK \ - Perl_xs_handshake(HS_KEY(FALSE, "v" PERL_API_VERSION_STRING, XS_VERSION) \ - , HS_CXT, items, ax, "v" PERL_API_VERSION_STRING, XS_VERSION) + Perl_xs_handshake(HS_KEY(FALSE, FALSE, "v" PERL_API_VERSION_STRING, XS_VERSION), \ + HS_CXT, __FILE__, items, ax, "v" PERL_API_VERSION_STRING, XS_VERSION) #else /* should this be a #error? if you want both checked, you better supply XS_VERSION right? */ # define XS_BOTHVERSION_BOOTCHECK XS_APIVERSION_BOOTCHECK #endif /* private API */ -# define XS_APIVERSION_POPMARK_BOOTCHECK \ - Perl_xs_handshake(HS_KEY(TRUE, "v" PERL_API_VERSION_STRING, "") \ - , HS_CXT, "v" PERL_API_VERSION_STRING) +#define XS_APIVERSION_POPMARK_BOOTCHECK \ + Perl_xs_handshake(HS_KEY(FALSE, TRUE, "v" PERL_API_VERSION_STRING, ""), \ + HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING) #ifdef XS_VERSION # define XS_BOTHVERSION_POPMARK_BOOTCHECK \ - Perl_xs_handshake(HS_KEY(TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION) \ - , HS_CXT, "v" PERL_API_VERSION_STRING, XS_VERSION) + Perl_xs_handshake(HS_KEY(FALSE, TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION), \ + HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING, XS_VERSION) #else /* should this be a #error? if you want both checked, you better supply XS_VERSION right? */ # define XS_BOTHVERSION_POPMARK_BOOTCHECK XS_APIVERSION_POPMARK_BOOTCHECK #endif +#define XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK \ + Perl_xs_handshake(HS_KEY(TRUE, TRUE, "v" PERL_API_VERSION_STRING, ""), \ + HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING) +#ifdef XS_VERSION +# define XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK \ + Perl_xs_handshake(HS_KEY(TRUE, TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION),\ + HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING, XS_VERSION) +#else +/* should this be a #error? if you want both checked, you better supply XS_VERSION right? */ +# define XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK +#endif + +/* For a normal bootstrap without API or XS version checking. + Useful for static XS modules or debugging/testing scenarios. + If this macro gets heavily used in the future, it should separated into + a separate function independent of Perl_xs_handshake for efficiency */ +#define XS_SETXSUBFN_POPMARK \ + Perl_xs_handshake(HS_KEY(TRUE, TRUE, "", "") | HSf_NOCHK, HS_CXT, __FILE__) + #ifdef NO_XSLOCKS # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 70a6445b16..75feda5888 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -797,12 +797,15 @@ EOF # EOF - $self->{newXS} = "newXS"; $self->{proto} = ""; - + unless($self->{ProtoThisXSUB}) { + $self->{newXS} = "newXS_deffile"; + $self->{file} = ""; + } + else { # Build the prototype string for the xsub - if ($self->{ProtoThisXSUB}) { $self->{newXS} = "newXSproto_portable"; + $self->{file} = ", file"; if ($self->{ProtoThisXSUB} eq 2) { # User has specified empty prototype @@ -831,14 +834,14 @@ EOF foreach my $xname (sort keys %{ $self->{XsubAliases} }) { my $value = $self->{XsubAliases}{$xname}; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); -# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}, file$self->{proto}); +# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # XSANY.any_i32 = $value; EOF } } elsif (@{ $self->{Attributes} }) { push(@{ $self->{InitFileCode} }, Q(<<"EOF")); -# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto}); +# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); EOF } @@ -847,18 +850,18 @@ EOF my $value = $self->{Interfaces}{$yname}; $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); -# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}, file$self->{proto}); +# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # $self->{interface_macro_set}(cv,$value); EOF } } - elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro + elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro push(@{ $self->{InitFileCode} }, - " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n"); + " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } else { push(@{ $self->{InitFileCode} }, - " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n"); + " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } # END 'PARAGRAPH' 'while' loop @@ -876,7 +879,7 @@ EOF /* Making a sub named "$self->{Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("$self->{Package}") to return true. */ - (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil, file$self->{proto}); + (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); MAKE_FETCHMETHOD_WORK } @@ -1336,7 +1339,7 @@ sub OVERLOAD_handler { $self->{Overload} = 1 unless $self->{Overload}; my $overload = "$self->{Package}\::(".$1; push(@{ $self->{InitFileCode} }, - " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}, file$self->{proto});\n"); + " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } } diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index 7f957595fd..30ea74f3ff 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -491,6 +491,12 @@ S_croak_xs_usage(const CV *const cv, const char *const params) #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ +#if PERL_VERSION_LE(5, 21, 5) +# define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file) +#else +# define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) +#endif + EOF return 1; } @@ -989,9 +989,10 @@ Abm |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto \ |NULLOK OP* block p |CV * |newXS_len_flags|NULLOK const char *name|STRLEN len \ |NN XSUBADDR_t subaddr\ - |NN const char *const filename \ + |NULLOK const char *const filename \ |NULLOK const char *const proto \ |NULLOK SV **const_svp|U32 flags +pX |CV * |newXS_deffile |NN const char *name|NN XSUBADDR_t subaddr ApM |CV * |newXS_flags |NULLOK const char *name|NN XSUBADDR_t subaddr\ |NN const char *const filename \ |NULLOK const char *const proto|U32 flags @@ -2696,7 +2697,8 @@ Apo |void* |my_cxt_init |NN int *index|size_t size : XS_VERSION_BOOTCHECK Xpo |void |xs_version_bootcheck|U32 items|U32 ax|NN const char *xs_p \ |STRLEN xs_len -Xpon |I32 |xs_handshake |const U32 key|NN void * v_my_perl|... +Xpon |I32 |xs_handshake |const U32 key|NN void * v_my_perl\ + |NN const char * file| ... Xp |void |xs_boot_epilog |const U32 ax #ifndef HAS_STRLCAT Apnod |Size_t |my_strlcat |NULLOK char *dst|NULLOK const char *src|Size_t size @@ -1255,6 +1255,7 @@ #define newATTRSUB_x(a,b,c,d,e,f) Perl_newATTRSUB_x(aTHX_ a,b,c,d,e,f) #define newSTUB(a,b) Perl_newSTUB(aTHX_ a,b) #define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c) +#define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) #define nextargv(a,b) Perl_nextargv(aTHX_ a,b) #define noperl_die Perl_noperl_die diff --git a/embedvar.h b/embedvar.h index 94b7a00ef4..60c897b494 100644 --- a/embedvar.h +++ b/embedvar.h @@ -350,6 +350,7 @@ #define PL_warnhook (vTHX->Iwarnhook) #define PL_watchaddr (vTHX->Iwatchaddr) #define PL_watchok (vTHX->Iwatchok) +#define PL_xsubfilename (vTHX->Ixsubfilename) #endif /* MULTIPLICITY */ diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index cd489e5129..f8b23ccf0e 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -22,7 +22,7 @@ /* disable version checking since DynaLoader can't be DynaLoaded */ #undef dXSBOOTARGSXSAPIVERCHK -#define dXSBOOTARGSXSAPIVERCHK dXSARGS +#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK typedef struct { SV* x_dl_last_error; /* pointer to allocated memory for diff --git a/ext/re/re.xs b/ext/re/re.xs index 444997b4ac..9545d1dba0 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -11,7 +11,7 @@ #undef dXSBOOTARGSXSAPIVERCHK /* skip API version checking due to different interp struct size but, this hack is until #123007 is resolved */ -#define dXSBOOTARGSXSAPIVERCHK dXSARGS +#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK START_EXTERN_C diff --git a/intrpvar.h b/intrpvar.h index f5d8020d95..c8b0b8d053 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -313,6 +313,7 @@ PERLVAR(I, envgv, GV *) PERLVAR(I, incgv, GV *) PERLVAR(I, hintgv, GV *) PERLVAR(I, origfilename, char *) +PERLVARI(I, xsubfilename, const char *, NULL) PERLVAR(I, diehook, SV *) PERLVAR(I, warnhook, SV *) @@ -8790,6 +8790,24 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, return cv; } +/* +=for apidoc U||newXS + +Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be +static storage, as it is used directly as CvFILE(), without a copy being made. + +=cut +*/ + +CV * +Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) +{ + PERL_ARGS_ASSERT_NEWXS; + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 + ); +} + CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, @@ -8802,6 +8820,15 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, } CV * +Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr) +{ + PERL_ARGS_ASSERT_NEWXS_DEFFILE; + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0 + ); +} + +CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, SV **const_svp, @@ -8811,17 +8838,16 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, bool interleave = FALSE; PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; - + if (!subaddr) + Perl_croak_nocontext("panic: no address for '%s' in '%s'", + name, filename ? filename : PL_xsubfilename); { GV * const gv = gv_fetchpvn( name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", name ? len : PL_curstash ? sizeof("__ANON__") - 1: sizeof("__ANON__::__ANON__") - 1, GV_ADDMULTI | flags, SVt_PVCV); - - if (!subaddr) - Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); - + if ((cv = (name ? GvCV(gv) : NULL))) { if (GvCVGEN(gv)) { /* just a cached method */ @@ -8856,13 +8882,22 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, gv_method_changed(gv); /* newXS */ } } - if (!name) - CvANON_on(cv); + CvGV_set(cv, gv); - (void)gv_fetchfile(filename); - CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be - an external constant string */ - assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ + if(filename) { + (void)gv_fetchfile(filename); + assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ + if (flags & XS_DYNAMIC_FILENAME) { + CvDYNFILE_on(cv); + CvFILE(cv) = savepv(filename); + } else { + /* NOTE: not copied, as it is expected to be an external constant string */ + CvFILE(cv) = (char *)filename; + } + } else { + assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename); + CvFILE(cv) = (char*)PL_xsubfilename; + } CvISXSUB_on(cv); CvXSUB(cv) = subaddr; #ifndef PERL_IMPLICIT_CONTEXT @@ -8870,15 +8905,14 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, #else PoisonPADLIST(cv); #endif - + if (name) process_special_blocks(0, name, gv, cv); - } + else + CvANON_on(cv); + } /* <- not a conditional branch */ + - if (flags & XS_DYNAMIC_FILENAME) { - CvFILE(cv) = savepv(filename); - CvDYNFILE_on(cv); - } sv_setpv(MUTABLE_SV(cv), proto); if (interleave) LEAVE; return cv; @@ -8907,24 +8941,6 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake) return cv; } -/* -=for apidoc U||newXS - -Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be -static storage, as it is used directly as CvFILE(), without a copy being made. - -=cut -*/ - -CV * -Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) -{ - PERL_ARGS_ASSERT_NEWXS; - return newXS_len_flags( - name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 - ); -} - void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 86a525b848..ef29b3ace2 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -549,11 +549,12 @@ copiable. (P) When starting a new thread or returning values from a thread, Perl encountered an invalid data type. -=item BOOT:: Invalid handshake key got %X needed %X, binaries are mismatched +=item %s: Invalid handshake key got %p needed %p, binaries are mismatched (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. +library was compiled against. Reinstalling the XS module will likely fix this +error. =item Buffer overflow in prime_env_iter: %s @@ -3115,6 +3115,12 @@ PERL_CALLCONV CV* Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const c #define PERL_ARGS_ASSERT_NEWXS \ assert(subaddr); assert(filename) +PERL_CALLCONV CV * Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_NEWXS_DEFFILE \ + assert(name); assert(subaddr) + PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); @@ -3122,10 +3128,9 @@ PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, assert(subaddr); assert(filename) PERL_CALLCONV CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, SV **const_svp, U32 flags) - __attribute__nonnull__(pTHX_3) - __attribute__nonnull__(pTHX_4); + __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS \ - assert(subaddr); assert(filename) + assert(subaddr) PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll); PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype) @@ -5161,10 +5166,11 @@ PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv) assert(msv) PERL_CALLCONV void Perl_xs_boot_epilog(pTHX_ const U32 ax); -PERL_CALLCONV I32 Perl_xs_handshake(const U32 key, void * v_my_perl, ...) - __attribute__nonnull__(2); +PERL_CALLCONV I32 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) + __attribute__nonnull__(2) + __attribute__nonnull__(3); #define PERL_ARGS_ASSERT_XS_HANDSHAKE \ - assert(v_my_perl) + assert(v_my_perl); assert(file) PERL_CALLCONV void Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) __attribute__nonnull__(pTHX_3); @@ -14608,6 +14608,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_incgv = gv_dup_inc(proto_perl->Iincgv, param); PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param); PL_origfilename = SAVEPV(proto_perl->Iorigfilename); + PL_xsubfilename = proto_perl->Ixsubfilename; PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); @@ -5352,35 +5352,38 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) and unthreaded XS module, threaded perl will look at uninit C stack or uninit register to get var key (remember it assumes 1st arg is interp cxt). -Perl_xs_handshake(U32 key, void * v_my_perl, [U32 items, U32 ax], [char * api_version], [char * xs_version]) */ +Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, +[U32 items, U32 ax], [char * api_version], [char * xs_version]) */ I32 -Perl_xs_handshake(const U32 key, void * v_my_perl, ...) +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, v_my_perl); + va_start(args, file); - if((key & HSm_KEY_MATCH) != (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH)) - noperl_die("BOOT:: Invalid handshake key got %"UVXf" needed %"UVXf - ", binaries are mismatched", - (UV)(key & HSm_KEY_MATCH), - (UV)(HS_KEY(FALSE, "", "") & HSm_KEY_MATCH)); + got = (void *)(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 */ - { - void * got; - void * need; #ifdef PERL_IMPLICIT_CONTEXT - tTHX xs_interp = (tTHX)v_my_perl; - got = xs_interp; - need = my_perl; + 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, @@ -5389,15 +5392,24 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, ...) 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 = (CV*)v_my_perl; - SV *** xs_spp = (SV***)CvHSCXT(cv); - got = xs_spp; - need = &PL_stack_sp; -#endif - if(got != need)/* recycle branch and string from above */ - noperl_die("BOOT:: Invalid handshake key got %"UVXf - " needed %"UVXf", binaries are mismatched", - (UV)got, (UV)need); + 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: Invalid handshake key got %p" + " needed %p, binaries are mismatched", + 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 */ + (void)gv_fetchfile(file); } if(key & HSf_POPMARK) { @@ -173,16 +173,21 @@ typedef struct { selectable. These spare bits allow for additional features for the varargs stuff or ABI compat test flags in the future. */ -#define HSm_APIVERLEN 0x0000003F /* perl version string won't be more than 63 chars */ +#define HSm_APIVERLEN 0x0000001F /* perl version string won't be more than 31 chars */ #define HS_APIVERLEN_MAX HSm_APIVERLEN #define HSm_XSVERLEN 0x0000FF00 /* if 0, not present, dont check, die if over 255*/ #define HS_XSVERLEN_MAX 0xFF +/* uses var file to set default filename for newXS_deffile to use for CvFILE */ +#define HSf_SETXSUBFN 0x00000020 #define HSf_POPMARK 0x00000040 /* popmark mode or you must supply ax and items */ #define HSf_IMP_CXT 0x00000080 /* ABI, threaded/PERL_IMPLICIT_CONTEXT, pTHX_ present */ #define HSm_INTRPSIZE 0xFFFF0000 /* ABI, interp struct size */ -/* a mask where these bits must always match between a XS mod and interp */ -/* and maybe HSm_APIVERLEN one day if Perl_xs_apiversion_bootcheck is changed to a memcmp */ +/* A mask of bits in the key which must always match between a XS mod and interp. + Also if all ABI bits in a key are true, skip all ABI checks, it is very + the unlikely interp size will all 1 bits */ +/* Maybe HSm_APIVERLEN one day if Perl_xs_apiversion_bootcheck is changed to a memcmp */ #define HSm_KEY_MATCH (HSm_INTRPSIZE|HSf_IMP_CXT) +#define HSf_NOCHK HSm_KEY_MATCH /* if all ABI bits are 1 in the key, dont chk */ #define HS_GETINTERPSIZE(key) ((key) >> 16) @@ -193,12 +198,14 @@ means arg not present, 1 is empty string/null byte */ #define HS_GETAPIVERLEN(key) ((key) & HSm_APIVERLEN) /* internal to util.h macro to create a packed handshake key, all args must be constants */ -/* U32 return = (U16 interpsize, bool cxt, bool popmark, U6 (SIX!) apiverlen, U8 xsverlen) */ -#define HS_KEYp(interpsize, cxt, popmark, apiverlen, xsverlen) \ +/* U32 return = (U16 interpsize, bool cxt, bool setxsubfn, bool popmark, + U5 (FIVE!) apiverlen, U8 xsverlen) */ +#define HS_KEYp(interpsize, cxt, setxsubfn, popmark, apiverlen, xsverlen) \ (((interpsize) << 16) \ | ((xsverlen) > HS_XSVERLEN_MAX \ ? (Perl_croak_nocontext("panic: handshake overflow"), HS_XSVERLEN_MAX) \ : (xsverlen) << 8) \ + | (cBOOL(setxsubfn) ? HSf_SETXSUBFN : 0) \ | (cBOOL(cxt) ? HSf_IMP_CXT : 0) \ | (cBOOL(popmark) ? HSf_POPMARK : 0) \ | ((apiverlen) > HS_APIVERLEN_MAX \ @@ -208,15 +215,16 @@ means arg not present, 1 is empty string/null byte */ /* public macro for core usage to create a packed handshake key but this is not public API. This more friendly version already collected all ABI info */ -/* U32 return = (bool popmark, "litteral_string_api_ver", "litteral_string_xs_ver") */ +/* U32 return = (bool setxsubfn, bool popmark, "litteral_string_api_ver", + "litteral_string_xs_ver") */ #ifdef PERL_IMPLICIT_CONTEXT -# define HS_KEY(popmark, apiver, xsver) \ - HS_KEYp(sizeof(PerlInterpreter), TRUE, popmark, \ +# define HS_KEY(setxsubfn, popmark, apiver, xsver) \ + HS_KEYp(sizeof(PerlInterpreter), TRUE, setxsubfn, popmark, \ sizeof("" apiver "")-1, sizeof("" xsver "")-1) # define HS_CXT aTHX #else -# define HS_KEY(popmark, apiver, xsver) \ - HS_KEYp(sizeof(struct PerlHandShakeInterpreter), FALSE, popmark, \ +# define HS_KEY(setxsubfn, popmark, apiver, xsver) \ + HS_KEYp(sizeof(struct PerlHandShakeInterpreter), FALSE, setxsubfn, popmark, \ sizeof("" apiver "")-1, sizeof("" xsver "")-1) # define HS_CXT cv #endif |