#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 */
+# define dXSBOOTARGSXSAPIVERCHK \
+ I32 ax = XS_BOTHVERSION_POPMARK_BOOTCHECK; \
+ SV **mark = PL_stack_base + ax; dSP; dITEMS
+# define dXSBOOTARGSAPIVERCHK \
+ I32 ax = XS_APIVERSION_POPMARK_BOOTCHECK; \
+ SV **mark = PL_stack_base + ax; dSP; dITEMS
#endif
#define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
#ifdef XS_VERSION
# define XS_VERSION_BOOTCHECK \
- Perl_xs_version_bootcheck(aTHX_ items, ax, STR_WITH_LEN(XS_VERSION))
+ Perl_xs_handshake(HS_KEY(FALSE, "", XS_VERSION), HS_CXT, items, ax, XS_VERSION)
#else
# define XS_VERSION_BOOTCHECK
#endif
#define XS_APIVERSION_BOOTCHECK \
- Perl_xs_apiversion_bootcheck(ST(0), STR_WITH_LEN("v" PERL_API_VERSION_STRING))
+ Perl_xs_handshake(HS_KEY(FALSE, "v" PERL_API_VERSION_STRING, ""), HS_CXT, 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)
+#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)
+#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)
+#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
#ifdef NO_XSLOCKS
# define dXCPT dJMPENV; int rEtV = 0
#else
# define CvPADLIST_set(sv, padlist) (CvPADLIST(sv) = (padlist))
#endif
-/* CvRESERVED is a placeholder and will be going away soon */
-#define CvRESERVED(sv) *(assert_(CvISXSUB((CV*)(sv))) \
- &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_reserved))
+#define CvHSCXT(sv) *(assert_(CvISXSUB((CV*)(sv))) \
+ &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt))
#ifdef DEBUGGING
# if PTRSIZE == 8
# define PoisonPADLIST(sv) \
Revision history for Perl extension ExtUtils::ParseXS.
+3.26 - not released yet
+ - Support added for XS handshake API introduced in 5.21.6.
+ - backported S_croak_xs_usage optimized on threaded builds
+
3.24 - Wed Mar 5 18:20:00 CET 2014
- Native Android build fixes
- More lenient syntax for embedded TYPEMAP blocks in XS:
print Q(<<"EOF");
#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
#XS_EXTERNAL(boot_$self->{Module_cname})
-EOF
-
- print Q(<<"EOF");
#[[
+##if PERL_VERSION_LE(5, 21, 5)
# dVAR; dXSARGS;
+##else
+# dVAR; ${\($self->{WantVersionChk} ?
+ 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')}
+##endif
EOF
#Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
print Q(<<"EOF");
# PERL_UNUSED_VAR(cv); /* -W */
# PERL_UNUSED_VAR(items); /* -W */
-##ifdef XS_APIVERSION_BOOTCHECK
+EOF
+
+ if( $self->{WantVersionChk}){
+ print Q(<<"EOF") ;
+##if PERL_VERSION_LE(5, 21, 5)
+# XS_VERSION_BOOTCHECK;
+## ifdef XS_APIVERSION_BOOTCHECK
# XS_APIVERSION_BOOTCHECK;
+## endif
##endif
+
EOF
+ } else {
+ print Q(<<"EOF") ;
+##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK)
+# XS_APIVERSION_BOOTCHECK;
+##endif
- print Q(<<"EOF") if $self->{WantVersionChk};
-# XS_VERSION_BOOTCHECK;
-#
EOF
+ }
print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces};
# {
}
print Q(<<'EOF');
-##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
-# if (PL_unitcheckav)
-# call_list(PL_scopestack_ix, PL_unitcheckav);
-##endif
-EOF
-
- print Q(<<"EOF");
+##if PERL_VERSION_LE(5, 21, 5)
+## if PERL_VERSION_GE(5, 9, 0)
+# if (PL_unitcheckav)
+# call_list(PL_scopestack_ix, PL_unitcheckav);
+## endif
# XSRETURN_YES;
+##else
+# Perl_xs_boot_epilog(aTHX_ ax);
+##endif
#]]
#
EOF
/* prototype to pass -Wmissing-prototypes */
STATIC void
-S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+S_croak_xs_usage(const CV *const cv, const char *const params);
STATIC void
-S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+S_croak_xs_usage(const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
- Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+ Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
else
- Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+ Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
- Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+ Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
-#ifdef PERL_IMPLICIT_CONTEXT
-#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
-#else
#define croak_xs_usage S_croak_xs_usage
-#endif
#endif
use strict;
use warnings;
$| = 1;
-use Test::More tests => 5;
+use Test::More tests => 4;
use File::Spec;
use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib');
use ExtUtils::ParseXS::Utilities qw(
my @statements = (
'#ifndef PERL_UNUSED_VAR',
'#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE',
- '#ifdef PERL_IMPLICIT_CONTEXT',
'#ifdef newXS_flags',
);
}
}
else
- Perl_dump_indent(aTHX_ level, file, " RESERVED = 0x%p\n", CvRESERVED(sv));
+ Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
{
const CV * const outside = CvOUTSIDE(sv);
Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
|NN const char *const params
npr |void |croak_no_mem
nprX |void |croak_popstack
+fnprx |void |noperl_die|NN const char* pat|...
#if defined(WIN32)
norx |void |win32_croak_not_implemented|NN const char * fname
#endif
: XS_VERSION_BOOTCHECK
Xpo |void |xs_version_bootcheck|U32 items|U32 ax|NN const char *xs_p \
|STRLEN xs_len
-: This function is an implementation detail. The public API for this is
-: XS_APIVERSION_BOOTCHECK
-Xpon |void |xs_apiversion_bootcheck|NN SV *module|NN const char *api_p \
- |STRLEN api_len
-
+Xpon |I32 |xs_handshake |const U32 key|NN void * v_my_perl|...
+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
#endif
#define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c)
#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
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(aTHX_ a)
#define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b)
#define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c)
#define watch(a) Perl_watch(aTHX_ a)
#define write_to_stderr(a) Perl_write_to_stderr(aTHX_ a)
+#define xs_boot_epilog(a) Perl_xs_boot_epilog(aTHX_ a)
#define yyerror(a) Perl_yyerror(aTHX_ a)
#define yyerror_pv(a,b) Perl_yyerror_pv(aTHX_ a,b)
#define yyerror_pvn(a,b,c) Perl_yyerror_pvn(aTHX_ a,b,c)
#endif
SV *
-CvRESERVED(cv)
+CvHSCXT(cv)
B::CV cv
CODE:
- RETVAL = newSViv(CvISXSUB(cv) ? PTR2IV(CvRESERVED(cv)) : 0);
+ RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
OUTPUT:
RETVAL
FLAGS = 0x100c # $] >= 5.015
OUTSIDE_SEQ = 0
PADLIST = 0x0 # $] < 5.021006
- RESERVED = $ADDR # $] >= 5.021006
+ HSCXT = $ADDR # $] >= 5.021006
OUTSIDE = 0x0 \\(null\\)');
do_test('isUV should show on PVMG',
#endif
#define MY_CXT_KEY "DynaLoader::_guts" XS_VERSION
+/* disable version checking since DynaLoader can't be DynaLoaded */
+#undef dXSBOOTARGSXSAPIVERCHK
+#define dXSBOOTARGSXSAPIVERCHK dXSARGS
+
typedef struct {
SV* x_dl_last_error; /* pointer to allocated memory for
last error message */
/* We have to be in a different .xs so that we can do this: */
#undef XS_VERSION
-#define XS_VERSION ""
+#define XS_VERSION " "
#undef PERL_API_VERSION_STRING
#define PERL_API_VERSION_STRING "1.0.16"
#include "XSUB.h"
use strict;
use warnings;
-our $VERSION = "0.27";
+our $VERSION = "0.28";
our @ISA = qw(Exporter);
our @EXPORT_OK = ('regmust',
qw(is_regexp regexp_pattern
#include "XSUB.h"
#include "re_comp.h"
+#undef dXSBOOTARGSXSAPIVERCHK
+/* skip API version checking due to different interp struct size but,
+ this hack is until #123007 is resolved */
+#define dXSBOOTARGSXSAPIVERCHK dXSARGS
START_EXTERN_C
assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
+#ifndef PERL_IMPLICIT_CONTEXT
+ CvHSCXT(cv) = &PL_stack_sp;
+#else
PoisonPADLIST(cv);
+#endif
if (name)
process_special_blocks(0, name, gv, cv);
Safefree(padlist);
CvPADLIST_set(&cvbody, NULL);
}
- else if (CvISXSUB(&cvbody)) /* future union */
- CvRESERVED(&cvbody) = NULL;
+ else if (CvISXSUB(&cvbody))
+ CvHSCXT(&cvbody) = NULL;
/* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
return 1;
}
+/* removes boilerplate code at the end of each boot_Module xsub */
+void
+Perl_xs_boot_epilog(pTHX_ const U32 ax)
+{
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ XSRETURN_YES;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
#undef PERLVARI
#undef PERLVARIC
+#if !defined(MULTIPLICITY)
+/* Set up PERLVAR macros for populating structs */
+# define PERLVAR(prefix,var,type) type prefix##var;
+/* 'var' is an array of length 'n' */
+# define PERLVARA(prefix,var,n,type) type prefix##var[n];
+/* initialize 'var' to init' */
+# define PERLVARI(prefix,var,type,init) type prefix##var;
+/* like PERLVARI, but make 'var' a const */
+# define PERLVARIC(prefix,var,type,init) type prefix##var;
+
+/* this is never instantiated, is it just used for sizeof(struct PerlHandShakeInterpreter) */
+struct PerlHandShakeInterpreter {
+# include "intrpvar.h"
+};
+# undef PERLVAR
+# undef PERLVARA
+# undef PERLVARI
+# undef PERLVARIC
+#endif
+
START_EXTERN_C
/* dummy variables that hold pointers to both runops functions, thus forcing
#endif
+/* print a failure format string message to stderr and fail exit the process
+ using only libc without depending on any perl data structures being
+ initialized.
+*/
+
+void
+Perl_noperl_die(const char* pat, ...)
+{
+ va_list(arglist);
+ PERL_ARGS_ASSERT_NOPERL_DIE;
+ va_start(arglist, pat);
+ vfprintf(stderr, pat, arglist);
+ va_end(arglist);
+ exit(1);
+}
+
/*
* Local variables:
* c-indentation-style: bsd
(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
+
+(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.
+
=item Buffer overflow in prime_env_iter: %s
(W internal) A warning peculiar to VMS. While Perl was preparing to
#define PERL_ARGS_ASSERT_NINSTR \
assert(big); assert(bigend); assert(little); assert(lend)
+PERL_CALLCONV_NO_RET void Perl_noperl_die(const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NOPERL_DIE \
+ assert(pat)
+
PERL_CALLCONV int Perl_nothreadhook(pTHX);
PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o)
__attribute__warn_unused_result__
#define PERL_ARGS_ASSERT_WRITE_TO_STDERR \
assert(msv)
-PERL_CALLCONV void Perl_xs_apiversion_bootcheck(SV *module, const char *api_p, STRLEN api_len)
- __attribute__nonnull__(1)
+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);
-#define PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK \
- assert(module); assert(api_p)
+#define PERL_ARGS_ASSERT_XS_HANDSHAKE \
+ assert(v_my_perl)
PERL_CALLCONV void Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len)
__attribute__nonnull__(pTHX_3);
: gv_dup(CvGV(sstr), param);
if (!CvISXSUB(sstr)) {
- if(CvPADLIST(sstr))
- CvPADLIST_set(dstr, padlist_dup(CvPADLIST(sstr), param));
- else
- CvPADLIST_set(dstr, NULL);
- } else { /* future union here */
- CvRESERVED(dstr) = NULL;
- }
+ PADLIST * padlist = CvPADLIST(sstr);
+ if(padlist)
+ padlist = padlist_dup(padlist, param);
+ CvPADLIST_set(dstr, padlist);
+ } else
+/* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */
+ PoisonPADLIST(dstr);
+
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
char * xcv_file; \
union { \
PADLIST * xcv_padlist; \
- void * xcv_reserved; \
+ void * xcv_hscxt; \
} xcv_padlist_u; \
CV * xcv_outside; \
U32 xcv_outside_seq; /* the COP sequence (at the point of our \
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
+
+/* The meaning of the varargs is determined U32 key arg. This is not a format
+ string. The U32 key is assembled with HS_KEY.
+
+ v_my_perl arg is "PerlInterpreter * my_perl" if PERL_IMPLICIT_CONTEXT and
+ otherwise "CV * cv" (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 sucessfully can load IO.dll into the process but
+ simultaniously it loaded a interp 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 (v=void) can not 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 reports the XS mod's key as
+ gibberish (it is really my_perl ptr) (threaded XS mod), or if threaded perl
+ 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]) */
+I32
+Perl_xs_handshake(const U32 key, void * v_my_perl, ...)
+{
+ va_list args;
+ U32 items, ax;
+#ifdef PERL_IMPLICIT_CONTEXT
+ dTHX;
+#endif
+ PERL_ARGS_ASSERT_XS_HANDSHAKE;
+ va_start(args, v_my_perl);
+
+ if((key & HSm_KEY_MATCH) != (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH))
+ noperl_die("BOOT:: Invalid handshake key got %X needed %X"
+ ", binaries are mismatched", (key & HSm_KEY_MATCH)
+ , (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH));
+/* 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;
+#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 = (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 %X needed %X"
+ ", binaries are mismatched", got, need);
+ }
+
+ 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))
+ Perl_xs_version_bootcheck(aTHX_
+ items, ax, va_arg(args, char*), xsverlen);
+ }
+ va_end(args);
+ return ax;
+}
+
void
Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
STRLEN xs_len)
}
}
-void
-Perl_xs_apiversion_bootcheck(SV *module, const char *api_p,
- STRLEN api_len)
-{
- PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
-
- if(api_len != 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(module), "v" PERL_API_VERSION_STRING);
- }
-}
-
/*
=for apidoc my_strlcat
#endif /* USE_C_BACKTRACE */
+/* Use a packed 32 bit constant "key" to start the handshake. The key defines
+ ABI compatibility, and how to process the vararg list.
+
+ Note, some bits may be taken from INTRPSIZE (but then a simple x86 AX register
+ can't be used to read it) and 4 bits from API version len can also be taken,
+ since v00.00.00 is 9 bytes long. XS version length should not have any bits
+ taken since XS_VERSION lengths can get quite long since they are user
+ 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 HS_APIVERLEN_MAX HSm_APIVERLEN
+#define HSm_XSVERLEN 0x0000FF00 /* if 0, not present, dont check, die if over 255*/
+#define HS_XSVERLEN_MAX 0xFF
+#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 */
+#define HSm_KEY_MATCH (HSm_INTRPSIZE|HSf_IMP_CXT)
+
+
+#define HS_GETINTERPSIZE(key) ((key) >> 16)
+/* if in the future "" and NULL must be separated, XSVERLEN would be 0
+means arg not present, 1 is empty string/null byte */
+/* (((key) & 0x0000FF00) >> 8) is less efficient on Visual C */
+#define HS_GETXSVERLEN(key) ((key) >> 8 & 0xFF)
+#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) \
+ (((interpsize) << 16) \
+ | ((xsverlen) > HS_XSVERLEN_MAX \
+ ? (Perl_croak_nocontext("panic: handshake overflow"), HS_XSVERLEN_MAX) \
+ : (xsverlen) << 8) \
+ | (cBOOL(cxt) ? HSf_IMP_CXT : 0) \
+ | (cBOOL(popmark) ? HSf_POPMARK : 0) \
+ | ((apiverlen) > HS_APIVERLEN_MAX \
+ ? (Perl_croak_nocontext("panic: handshake overflow"), HS_APIVERLEN_MAX) \
+ : (apiverlen)))
+/* overflows above will optimize away unless they will execute */
+
+/* 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") */
+#ifdef PERL_IMPLICIT_CONTEXT
+# define HS_KEY(popmark, apiver, xsver) \
+ HS_KEYp(sizeof(PerlInterpreter), TRUE, 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, \
+ sizeof("" apiver "")-1, sizeof("" xsver "")-1)
+# define HS_CXT cv
+#endif
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / commitdiff