summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--XSUB.h60
-rw-r--r--dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm25
-rw-r--r--dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm6
-rw-r--r--embed.fnc6
-rw-r--r--embed.h1
-rw-r--r--embedvar.h1
-rw-r--r--ext/DynaLoader/dlutils.c2
-rw-r--r--ext/re/re.xs2
-rw-r--r--intrpvar.h1
-rw-r--r--op.c86
-rw-r--r--pod/perldiag.pod5
-rw-r--r--proto.h18
-rw-r--r--sv.c1
-rw-r--r--util.c58
-rw-r--r--util.h28
15 files changed, 193 insertions, 107 deletions
diff --git a/XSUB.h b/XSUB.h
index 547cd46eb9..8e38df2291 100644
--- a/XSUB.h
+++ b/XSUB.h
@@ -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;
}
diff --git a/embed.fnc b/embed.fnc
index 822f2c1a2e..9d209b7c2e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -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
diff --git a/embed.h b/embed.h
index 122b3d0c1c..938d7d3734 100644
--- a/embed.h
+++ b/embed.h
@@ -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 *)
diff --git a/op.c b/op.c
index 184f4aec51..d14bdc9acd 100644
--- a/op.c
+++ b/op.c
@@ -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
diff --git a/proto.h b/proto.h
index 6d020121c9..4e36949468 100644
--- a/proto.h
+++ b/proto.h
@@ -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);
diff --git a/sv.c b/sv.c
index f8d3fe27a8..54f939f044 100644
--- a/sv.c
+++ b/sv.c
@@ -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);
diff --git a/util.c b/util.c
index e43159fbb0..f9ca30603f 100644
--- a/util.c
+++ b/util.c
@@ -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) {
diff --git a/util.h b/util.h
index 172723353c..6e63f3bc2e 100644
--- a/util.h
+++ b/util.h
@@ -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
View Lorry Controller Status