#ifndef H_PERL
#define H_PERL 1
+#if defined(__HP_cc) || defined(__HP_aCC)
+/* The HPUX compiler for Itanium is very picky and warns about
+ * things that gcc doesn't and that we would prefer it does not.
+ * So on that platform silence certain warnings unlaterally. */
+
+/* silence "relational operator ">" always evaluates to 'false'"
+ * warnings. We get a LOT of these from the memwrap checks. */
+#pragma diag_suppress 4276
+
+/* silence "may cause misaligned access" warnings from our "OO in C"
+ * type logic. we do this a lot and if it was broken we would fail tests
+ * all over the place */
+#pragma diag_suppress 4232
+
+#endif /* end HPUX warning disablement */
+
#ifdef PERL_FOR_X2P
/*
* This file is being used for x2p stuff.
#define USE_STDIO
#endif /* PERL_FOR_X2P */
-#ifdef PERL_MICRO
-# include "uconfig.h"
-#else
-# include "config.h"
+/* Treat the SVs on the argument stack as having been reference counted.
+ * (Experimental).
+ */
+/* #define PERL_RC_STACK */
+
+#include "config.h"
+
+/* This fakes up using Mingw for locale handling. In order to not define WIN32
+ * in this file (and hence throughout the code that isn't expecting it), this
+ * doesn't define that, but defines the appropriate things that would otherwise
+ * be defined later in the file. Hence those and here must be kept in sync */
+#ifdef WIN32_USE_FAKE_OLD_MINGW_LOCALES
+# define UINT unsigned int
+# undef USE_THREAD_SAFE_LOCALE
+# define NO_POSIX_2008_LOCALE
+# undef HAS_NL_LANGINFO
+# undef HAS_NL_LANGINFO_L
+# undef _UCRT
+# ifdef USE_LOCALE
+# define TS_W32_BROKEN_LOCALECONV
+# ifdef USE_THREADS
+# define EMULATE_THREAD_SAFE_LOCALES
+# endif
+# endif
#endif
-/* this is used for functions which take a depth trailing
- * argument under debugging */
+/*
+=for apidoc_section $debugging
+=for apidoc CmnW ||comma_aDEPTH
+Some functions when compiled under DEBUGGING take an extra final argument named
+C<depth>, indicating the C stack depth. This argument is omitted otherwise.
+This macro expands to either S<C<, depth>> under DEBUGGING, or to nothing at
+all when not under DEBUGGING, reducing the number of C<#ifdef>'s in the code.
+
+The program is responsible for maintaining the correct value for C<depth>.
+
+=for apidoc CyW ||comma_pDEPTH
+This is used in the prototype declarations for functions that take a L</C<comma_aDEPTH>>
+final parameter, much like L<C<pTHX_>|perlguts/Background and MULTIPLICITY>
+is used in functions that take a thread context initial parameter.
+
+=for apidoc CmnW ||debug_aDEPTH
+Same as L</C<comma_aDEPTH>> but with no leading argument. Intended for functions with
+no normal arguments, and used by L</C<comma_aDEPTH>> itself.
+
+=for apidoc CmnW ||debug_pDEPTH
+Same as L</C<comma_pDEPTH>> but with no leading argument. Intended for functions with
+no normal arguments, and used by L</C<comma_pDEPTH>> itself.
+
+=cut
+ */
+
#ifdef DEBUGGING
-#define _pDEPTH ,U32 depth
-#define _aDEPTH ,depth
+# define debug_pDEPTH U32 depth
+# define comma_pDEPTH ,debug_pDEPTH
+# define debug_aDEPTH depth
+# define comma_aDEPTH ,debug_aDEPTH
#else
-#define _pDEPTH
-#define _aDEPTH
+# define debug_aDEPTH
+# define comma_aDEPTH
+# define debug_pDEPTH
+# define comma_pDEPTH
#endif
/* NOTE 1: that with gcc -std=c89 the __STDC_VERSION__ is *not* defined
# define HAS_C99 1
#endif
-/* See L<perlguts/"The Perl API"> for detailed notes on
- * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
+/* =========================================================================
+ * The defines from here to the following ===== line are unfortunately
+ * duplicated in makedef.pl, and changes here MUST also be made there */
-/* XXX NOTE that from here --> to <-- the same logic is
- * repeated in makedef.pl, so be certain to update
- * both places when editing. */
+/* See L<perlguts/"The Perl API"> for detailed notes on
+ * MULTIPLICITY and PERL_IMPLICIT_SYS */
-#ifdef USE_ITHREADS
+#ifdef USE_THREADS
# if !defined(MULTIPLICITY)
# define MULTIPLICITY
# endif
#endif
-#ifdef MULTIPLICITY
-# ifndef PERL_IMPLICIT_CONTEXT
-# define PERL_IMPLICIT_CONTEXT
-# endif
+/* PERL_IMPLICIT_CONTEXT is a legacy synonym for MULTIPLICITY */
+#if defined(MULTIPLICITY) \
+ && ! defined(PERL_CORE) \
+ && ! defined(PERL_IMPLICIT_CONTEXT)
+# define PERL_IMPLICIT_CONTEXT
+#endif
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(MULTIPLICITY)
+# define MULTIPLICITY
+#endif
+#if defined(PERL_CORE) && defined(PERL_IMPLICIT_CONTEXT)
+# pragma message("PERL_IMPLICIT_CONTEXT was removed from core perl. It does not do anything. Undeffing it for compilation")
+# undef PERL_IMPLICIT_CONTEXT
#endif
/* undef WIN32 when building on Cygwin (for libwin32) - gph */
/* Use the reentrant APIs like localtime_r and getpwent_r */
/* Win32 has naturally threadsafe libraries, no need to use any _r variants.
* XXX KEEP makedef.pl copy of this code in sync */
-#if defined(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(NETWARE) && !defined(WIN32)
+#if defined(MULTIPLICITY) && !defined(USE_REENTRANT_API) && !defined(WIN32)
# define USE_REENTRANT_API
#endif
-/* <--- here ends the logic shared by perl.h and makedef.pl */
+/* end of makedef.pl logic duplication. But there are other groups below.
+ * ========================================================================= */
/*
=for apidoc_section $directives
=cut
*/
-#ifdef PERL_IMPLICIT_CONTEXT
-# ifndef MULTIPLICITY
-# define MULTIPLICITY
-# endif
+#ifdef MULTIPLICITY
# define tTHX PerlInterpreter*
# define pTHX tTHX my_perl PERL_UNUSED_DECL
# define aTHX my_perl
=cut
*/
-#define CPERLscope(x) x
-#define CPERLarg void
-#define CPERLarg_
-#define _CPERLarg
-#define PERL_OBJECT_THIS
-#define _PERL_OBJECT_THIS
-#define PERL_OBJECT_THIS_
-#define CALL_FPTR(fptr) (*fptr)
-#define MEMBER_TO_FPTR(name) name
+# define CPERLscope(x) x
+# define CPERLarg void
+# define CPERLarg_
+# define _CPERLarg
+# define PERL_OBJECT_THIS
+# define _PERL_OBJECT_THIS
+# define PERL_OBJECT_THIS_
+# define CALL_FPTR(fptr) (*fptr)
+# define MEMBER_TO_FPTR(name) name
#endif /* !PERL_CORE */
-#define CALLRUNOPS PL_runops
+#ifdef PERL_RC_STACK
+# define CALLRUNOPS Perl_runops_wrap
+#else
+# define CALLRUNOPS PL_runops
+#endif
#define CALLREGCOMP(sv, flags) Perl_pregcomp(aTHX_ (sv),(flags))
RX_ENGINE(rx)->qr_package(aTHX_ (rx))
#if defined(USE_ITHREADS)
-#define CALLREGDUPE(prog,param) \
+# define CALLREGDUPE(prog,param) \
Perl_re_dup(aTHX_ (prog),(param))
-#define CALLREGDUPE_PVT(prog,param) \
+# define CALLREGDUPE_PVT(prog,param) \
(prog ? RX_ENGINE(prog)->dupe(aTHX_ (prog),(param)) \
: (REGEXP *)NULL)
#endif
# define PERL_IS_GCC 1
#endif
+#define PERL_GCC_VERSION_GE(major,minor,patch) \
+ (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \
+ >= ((100000 * (major)) + (1000 * (minor)) + (patch)))
+#define PERL_GCC_VERSION_GT(major,minor,patch) \
+ (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \
+ > ((100000 * (major)) + (1000 * (minor)) + (patch)))
+#define PERL_GCC_VERSION_LE(major,minor,patch) \
+ (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \
+ <= ((100000 * (major)) + (1000 * (minor)) + (patch)))
+#define PERL_GCC_VERSION_LT(major,minor,patch) \
+ (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \
+ < ((100000 * (major)) + (1000 * (minor)) + (patch)))
+
/* In case Configure was not used (we are using a "canned config"
* such as Win32, or a cross-compilation setup, for example) try going
* by the gcc major and minor versions. One useful URL is
* have HASATTRIBUTE_FORMAT).
*/
-#ifndef PERL_MICRO
#if defined __GNUC__ && !defined(__INTEL_COMPILER)
-# if __GNUC__ == 3 && __GNUC_MINOR__ >= 1 || __GNUC__ > 3 /* 3.1 -> */
+# if PERL_GCC_VERSION_GE(3,1,0)
# define HASATTRIBUTE_DEPRECATED
# endif
-# if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */
+# if PERL_GCC_VERSION_GE(3,0,0) /* XXX Verify this version */
# define HASATTRIBUTE_FORMAT
# if defined __MINGW32__
# define PRINTF_FORMAT_NULL_OK
# endif
# endif
-# if __GNUC__ >= 3 /* 3.0 -> */
+# if PERL_GCC_VERSION_GE(3,0,0)
# define HASATTRIBUTE_MALLOC
# endif
-# if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */
+# if PERL_GCC_VERSION_GE(3,3,0)
# define HASATTRIBUTE_NONNULL
# endif
-# if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */
+# if PERL_GCC_VERSION_GE(2,5,0)
# define HASATTRIBUTE_NORETURN
# endif
-# if __GNUC__ >= 3 /* gcc 3.0 -> */
+# if PERL_GCC_VERSION_GE(3,0,0)
# define HASATTRIBUTE_PURE
# endif
-# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */
+# if PERL_GCC_VERSION_GE(3,4,0)
# define HASATTRIBUTE_UNUSED
# endif
# if __GNUC__ == 3 && __GNUC_MINOR__ == 3 && !defined(__cplusplus)
# define HASATTRIBUTE_UNUSED /* gcc-3.3, but not g++-3.3. */
# endif
-# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */
+# if PERL_GCC_VERSION_GE(3,4,0)
# define HASATTRIBUTE_WARN_UNUSED_RESULT
# endif
-/* always_inline is buggy in gcc <= 4.6 and causes compilation errors */
-# if __GNUC__ == 4 && __GNUC_MINOR__ >= 7 || __GNUC__ > 4 /* 4.7 -> */
+ /* always_inline is buggy in gcc <= 4.6 and causes compilation errors */
+# if PERL_GCC_VERSION_GE(4,7,0)
# define HASATTRIBUTE_ALWAYS_INLINE
# endif
+# if PERL_GCC_VERSION_GE(3,3,0)
+# define HASATTRIBUTE_VISIBILITY
+# endif
#endif
-#endif /* #ifndef PERL_MICRO */
#ifdef HASATTRIBUTE_DEPRECATED
# define __attribute__deprecated__ __attribute__((deprecated))
#endif
#ifdef HASATTRIBUTE_ALWAYS_INLINE
/* always_inline is buggy in gcc <= 4.6 and causes compilation errors */
-# if !defined(PERL_IS_GCC) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7 || __GNUC__ > 4)
+# if !defined(PERL_IS_GCC) || PERL_GCC_VERSION_GE(4,7,0)
# define __attribute__always_inline__ __attribute__((always_inline))
# endif
#endif
+#if defined(HASATTRIBUTE_VISIBILITY) && !defined(_WIN32) && !defined(__CYGWIN__)
+/* On Windows instead of this, we use __declspec(dllexport) and a .def file
+ * Cygwin works by exporting every global symbol, see the definition of ldflags
+ * near the end of hints/cygwin.sh and the visibility attribute doesn't appear
+ * to control that.
+ */
+# define __attribute__visibility__(x) __attribute__((visibility(x)))
+#endif
/* If we haven't defined the attributes yet, define them to blank. */
#ifndef __attribute__deprecated__
#ifndef __attribute__always_inline__
# define __attribute__always_inline__
#endif
+#ifndef __attribute__visibility__
+# define __attribute__visibility__(x)
+#endif
/* Some OS warn on NULL format to printf */
#ifdef PRINTF_FORMAT_NULL_OK
* marking unused variables (they need e.g. a #pragma) and therefore
* cpp macros like PERL_UNUSED_DECL cannot work for this purpose, even
* if it were PERL_UNUSED_DECL(x), which it cannot be (see above).
+*/
+/*
=for apidoc_section $directives
=for apidoc AmnU||PERL_UNUSED_DECL
Tells the compiler that the parameter in the function prototype just before it
=back
=cut
- */
+*/
#ifndef PERL_UNUSED_DECL
# define PERL_UNUSED_DECL __attribute__unused__
* for silencing unused variables that are actually used most of the time,
* but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs,
* or variables/arguments that are used only in certain configurations.
-
-=for apidoc Ams||PERL_UNUSED_ARG|void x
+ */
+/*
+=for apidoc Am;||PERL_UNUSED_ARG|void x
This is used to suppress compiler warnings that a parameter to a function is
not used. This situation can arise, for example, when a parameter is needed
under some configuration conditions, but not others, so that C preprocessor
-conditional compilation causes it be used just some times.
+conditional compilation causes it be used just sometimes.
-=for apidoc Amns||PERL_UNUSED_CONTEXT
+=for apidoc Amn;||PERL_UNUSED_CONTEXT
This is used to suppress compiler warnings that the thread context parameter to
a function is not used. This situation can arise, for example, when a
C preprocessor conditional compilation causes it be used just some times.
-=for apidoc Ams||PERL_UNUSED_VAR|void x
+=for apidoc Am;||PERL_UNUSED_VAR|void x
This is used to suppress compiler warnings that the variable I<x> is not used.
This situation can arise, for example, when a C preprocessor conditional
compilation causes it be used just some times.
=cut
- */
+*/
#ifndef PERL_UNUSED_ARG
# define PERL_UNUSED_ARG(x) ((void)sizeof(x))
#endif
# define PERL_UNUSED_VAR(x) ((void)sizeof(x))
#endif
-#if defined(USE_ITHREADS)
+#if defined(MULTIPLICITY)
# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
#else
# define PERL_UNUSED_CONTEXT
*/
#if defined(PERL_GCC_PEDANTIC) || \
(defined(__GNUC__) && defined(__cplusplus) && \
- ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2))))
+ (PERL_GCC_VERSION_LT(4,2,0)))
# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
# endif
=cut
The __typeof__() is used instead of typeof() since typeof() is not
-available under strict C89, and because of compilers masquerading
+available under strict ISO C, and because of compilers masquerading
as gcc (clang and icc), we want exactly the gcc extension
__typeof__ and nothing else.
# endif
#endif
-#if defined(_MSC_VER)
-/* XXX older MSVC versions have a smallish macro buffer */
-#define PERL_SMALL_MACRO_BUFFER
-#endif
-
/* on gcc (and clang), specify that a warning should be temporarily
* ignored; e.g.
*
*
*/
-#if defined(__clang__) || defined(__clang) || \
- (defined( __GNUC__) && ((__GNUC__ * 100) + __GNUC_MINOR__) >= 406)
+#if defined(__clang__) || defined(__clang) || PERL_GCC_VERSION_GE(4,6,0)
# define GCC_DIAG_PRAGMA(x) _Pragma (#x)
/* clang has "clang diagnostic" pragmas, but also understands gcc. */
# define GCC_DIAG_IGNORE(x) _Pragma("GCC diagnostic push") \
#define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP
#define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP
-#if defined(_MSC_VER) && (_MSC_VER >= 1300)
+#if defined(_MSC_VER)
# define MSVC_DIAG_IGNORE(x) __pragma(warning(push)) \
__pragma(warning(disable : x))
# define MSVC_DIAG_RESTORE __pragma(warning(pop))
#define MSVC_DIAG_RESTORE_STMT MSVC_DIAG_RESTORE NOOP
/*
-=for apidoc Amns||NOOP
+=for apidoc Amn;||NOOP
Do nothing; typically used as a placeholder to replace something that used to
do something.
-=for apidoc Amns||dNOOP
+=for apidoc Amn;||dNOOP
Declare nothing; typically used as a placeholder to replace something that used
to declare something. Works on compilers that require declarations before any
code.
=cut
*/
-#define NOOP /*EMPTY*/(void)0
+#define NOOP ((void)0)
#define dNOOP struct Perl___notused_struct
#ifndef pTHX
/* Don't bother defining tTHX ; using it outside
- * code guarded by PERL_IMPLICIT_CONTEXT is an error.
+ * code guarded by MULTIPLICITY is an error.
*/
# define pTHX void
# define pTHX_
# define aTHXa(a) NOOP
# define dTHXa(a) dNOOP
# define dTHX dNOOP
-# define pTHX_1 1
+# define pTHX_1 1
# define pTHX_2 2
# define pTHX_3 3
# define pTHX_4 4
This is now a synonym for dNOOP: declare nothing
=for apidoc_section $XS
-=for apidoc Amns||dMY_CXT_SV
+=for apidoc Amn;||dMY_CXT_SV
Now a placeholder that declares nothing
=cut
/*
=for apidoc_section $directives
-=for apidoc AmnUu|void|STMT_START
-=for apidoc_item ||STMT_END
+=for apidoc AmnUu|void|STMT_END
+=for apidoc_item | |STMT_START
-This allows a series of statements in a macro to be used as a single statement,
+These allow a series of statements in a macro to be used as a single statement,
as in
if (x) STMT_START { ... } STMT_END else ...
-Note that you can't return a value out of them, which limits their utility.
-But see C<L</PERL_USE_GCC_BRACE_GROUPS>>.
+Note that you can't return a value out of this construct and cannot use it as
+an operand to the comma operator. These limit its utility.
-=for apidoc AmnuU|bool|PERL_USE_GCC_BRACE_GROUPS
+But, a value could be returned by constructing the API so that a pointer is
+passed and the macro dereferences this to set the return. If the value can be
+any of various types, depending on context, you can handle that situation in
+some situations by adding the type of the return as an extra accompanying
+parameter:
+
+ #define foo(param, type) STMT_START {
+ type * param; *param = do_calc; ...
+ } STMT_END
+
+This could be awkward, so consider instead using a C language C<static inline>
+function.
+
+If you do use this construct, it is easy to forget that it is a macro and not a
+function, and hence fall into traps that might not show up until someone
+someday writes code which contains names that clash with the ones you chose
+here, or calls it with a parameter which is an expression with side effects,
+the consequences of which you didn't think about. See L<perlhacktips/Writing
+safer macros> for how to avoid these.
+
+=for apidoc_section $genconfig
+=for apidoc Amn#||PERL_USE_GCC_BRACE_GROUPS
This C pre-processor value, if defined, indicates that it is permissible to use
-the GCC brace groups extension. This extension, of the form
+the GCC brace groups extension. However, use of this extension is DISCOURAGED.
+Use a C<static inline> function instead.
+
+The extension, of the form
({ statement ... })
-turns the block consisting of I<statements ...> into an expression with a
+turns the block consisting of I<statement ...> into an expression with a
value, unlike plain C language blocks. This can present optimization
-possibilities, B<BUT> you generally need to specify an alternative in case this
-ability doesn't exist or has otherwise been forbidden.
+possibilities, B<BUT>, unless you know for sure that this will never be
+compiled without this extension being available and not forbidden, you need to
+specify an alternative. Thus two code paths have to be maintained, which can
+get out-of-sync. All these issues are solved by using a C<static inline>
+function instead.
+
+Perl can be configured to not use this feature by passing the parameter
+C<-Accflags=-DPERL_GCC_BRACE_GROUPS_FORBIDDEN> to F<Configure>.
+
+=for apidoc Amnh#||PERL_GCC_BRACE_GROUPS_FORBIDDEN
Example usage:
Trying to select a version that gives no warnings...
*/
#if !(defined(STMT_START) && defined(STMT_END))
-# ifdef PERL_USE_GCC_BRACE_GROUPS
-# define STMT_START (void)( /* gcc supports "({ STATEMENTS; })" */
-# define STMT_END )
-# else
# define STMT_START do
# define STMT_END while (0)
-# endif
#endif
#ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */
# define BYTEORDER 0x1234
#endif
+/*
+=for apidoc_section $genconfig
+=for apidoc Amn#||ASCIIish
+
+A preprocessor symbol that is defined iff the system is an ASCII platform; this
+symbol would not be defined on C<L</EBCDIC>> platforms.
+
+=cut
+*/
#if 'A' == 65 && 'I' == 73 && 'J' == 74 && 'Z' == 90
-#define ASCIIish
+# define ASCIIish
#else
-#undef ASCIIish
+# undef ASCIIish
#endif
/*
*/
/* define this once if either system, instead of cluttering up the src */
-#if defined(MSDOS) || defined(WIN32) || defined(NETWARE)
+#if defined(WIN32)
#define DOSISH 1
#endif
#define STANDARD_C
#endif
+/* Don't compile 'code' if PERL_MEM_LOG is defined. This is used for
+ * constructs that don't play well when PERL_MEM_LOG is active, so that they
+ * automatically don't get compiled without having to use extra #ifdef's */
+#ifndef PERL_MEM_LOG
+# define UNLESS_PERL_MEM_LOG(code) code
+#else
+# define UNLESS_PERL_MEM_LOG(code)
+#endif
+
/* By compiling a perl with -DNO_TAINT_SUPPORT or -DSILENT_NO_TAINT_SUPPORT,
* you get a perl without taint support, but doubtlessly with a lesser
* degree of support. Do not do so unless you know exactly what it means
# define TAINT_WARN_get 0
# define TAINT_WARN_set(s) NOOP
#else
+
+/*
+=for apidoc_section $tainting
+=for apidoc Cm|void|TAINT
+
+If we aren't in taint checking mode, do nothing;
+otherwise indicate to L</C<TAINT_set>> and L</C<TAINT_PROPER>> that some
+unspecified element is tainted.
+
+=for apidoc Cm|void|TAINT_NOT
+
+Remove any taintedness previously set by, I<e.g.>, C<TAINT>.
+
+=for apidoc Cm|void|TAINT_IF|bool c
+
+If C<c> evaluates to true, call L</C<TAINT>> to indicate that something is
+tainted; otherwise do nothing.
+
+=for apidoc Cmn|void|TAINT_ENV
+
+Looks at several components of L<C<%ENV>|perlvar/%ENV> for taintedness, and
+calls L</C<taint_proper>> if any are tainted. The components it searches are
+things like C<$PATH>.
+
+=for apidoc Cm|void|TAINT_PROPER|const char * s
+
+If no element is tainted, do nothing;
+otherwise output a message (containing C<s>) that indicates there is a
+tainting violation. If such violations are fatal, it croaks.
+
+=for apidoc Cm|void|TAINT_set|bool s
+
+If C<s> is true, L</C<TAINT_get>> returns true;
+If C<s> is false, L</C<TAINT_get>> returns false;
+
+=for apidoc Cm|bool|TAINT_get
+
+Returns a boolean as to whether some element is tainted or not.
+
+=for apidoc Cm|bool|TAINTING_get
+
+Returns a boolean as to whether taint checking is enabled or not.
+
+=for apidoc Cm|void|TAINTING_set|bool s
+
+Turn taint checking mode off/on
+
+=for apidoc Cm|bool|TAINT_WARN_get
+
+Returns false if tainting violations are fatal;
+Returns true if they're just warnings
+
+=for apidoc Cm|void|TAINT_WARN_set|bool s
+
+C<s> being true indicates L</C<TAINT_WARN_get>> should return that tainting
+violations are just warnings
+
+C<s> being false indicates L</C<TAINT_WARN_get>> should return that tainting
+violations are fatal.
+
+=cut
+*/
/* Set to tainted if we are running under tainting mode */
# define TAINT (PL_tainted = PL_tainting)
# define TAINT_PROPER(s) if (UNLIKELY(PL_tainting)) { \
taint_proper(NULL, s); \
}
-# define TAINT_set(s) (PL_tainted = (s))
+# define TAINT_set(s) (PL_tainted = cBOOL(s))
# define TAINT_get (cBOOL(UNLIKELY(PL_tainted))) /* Is something tainted? */
-# define TAINTING_get (cBOOL(UNLIKELY(PL_tainting))) /* Is taint checking enabled? */
-# define TAINTING_set(s) (PL_tainting = (s))
-# define TAINT_WARN_get (PL_taint_warn) /* FALSE => tainting violations
- are fatal
- TRUE => they're just
- warnings */
-# define TAINT_WARN_set(s) (PL_taint_warn = (s))
+# define TAINTING_get (cBOOL(UNLIKELY(PL_tainting)))
+# define TAINTING_set(s) (PL_tainting = cBOOL(s))
+# define TAINT_WARN_get (PL_taint_warn)
+# define TAINT_WARN_set(s) (PL_taint_warn = cBOOL(s))
#endif
/* flags used internally only within pp_subst and pp_substcont */
# define HAS_SETPGRP /* Well, effectively it does . . . */
#endif
-/* getpgid isn't POSIX, but at least Solaris and Linux have it, and it makes
- our life easier :-) so we'll try it.
-*/
#ifdef HAS_GETPGID
# define BSD_GETPGRP(pid) getpgid((pid))
#elif defined(HAS_GETPGRP) && defined(USE_BSD_GETPGRP)
# endif
#endif
+/* This define exists only for compatibility. It used to mean "my_setenv and
+ * friends should use setenv/putenv, instead of manipulating environ directly",
+ * which is now always the case. It's still defined to prevent XS modules from
+ * using the no longer existing PL_use_safe_putenv variable.
+ */
+#define PERL_USE_SAFE_PUTENV
+
/* HP-UX 10.X CMA (Common Multithreaded Architecture) insists that
pthread.h must be included before all other header files.
*/
#undef METHOD
#endif
-#ifdef PERL_MICRO
-# define NO_LOCALE
-#endif
-
#ifdef I_LOCALE
# include <locale.h>
#endif
-#ifdef I_XLOCALE
+#ifdef NEED_XLOCALE_H
# include <xlocale.h>
#endif
+#include "perl_langinfo.h" /* Needed for _NL_LOCALE_NAME */
+
+/* =========================================================================
+ * The defines from here to the following ===== line are unfortunately
+ * duplicated in makedef.pl, and changes here MUST also be made there */
+
/* If not forbidden, we enable locale handling if either 1) the POSIX 2008
* functions are available, or 2) just the setlocale() function. This logic is
* repeated in t/loc_tools.pl and makedef.pl; The three should be kept in
* sync. */
#if ! defined(NO_LOCALE)
-
# if ! defined(NO_POSIX_2008_LOCALE) \
&& defined(HAS_NEWLOCALE) \
&& defined(HAS_USELOCALE) \
# endif
#endif
+/* end of makedef.pl logic duplication. But there are other groups below.
+ * ========================================================================= */
+
#ifdef USE_LOCALE
# define HAS_SKIP_LOCALE_INIT /* Solely for XS code to test for this
#define */
-# if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \
- && defined(HAS_STRXFRM)
-# define USE_LOCALE_COLLATE
-# endif
-# if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE)
-# define USE_LOCALE_CTYPE
-# endif
-# if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC)
-# define USE_LOCALE_NUMERIC
-# endif
-# if !defined(NO_LOCALE_MESSAGES) && defined(LC_MESSAGES)
-# define USE_LOCALE_MESSAGES
-# endif
-# if !defined(NO_LOCALE_MONETARY) && defined(LC_MONETARY)
-# define USE_LOCALE_MONETARY
-# endif
-# if !defined(NO_LOCALE_TIME) && defined(LC_TIME)
-# define USE_LOCALE_TIME
-# endif
-# if !defined(NO_LOCALE_ADDRESS) && defined(LC_ADDRESS)
-# define USE_LOCALE_ADDRESS
-# endif
-# if !defined(NO_LOCALE_IDENTIFICATION) && defined(LC_IDENTIFICATION)
-# define USE_LOCALE_IDENTIFICATION
-# endif
-# if !defined(NO_LOCALE_MEASUREMENT) && defined(LC_MEASUREMENT)
-# define USE_LOCALE_MEASUREMENT
-# endif
-# if !defined(NO_LOCALE_PAPER) && defined(LC_PAPER)
-# define USE_LOCALE_PAPER
-# endif
-# if !defined(NO_LOCALE_TELEPHONE) && defined(LC_TELEPHONE)
-# define USE_LOCALE_TELEPHONE
-# endif
-# if !defined(NO_LOCALE_SYNTAX) && defined(LC_SYNTAX)
-# define USE_LOCALE_SYNTAX
-# endif
-# if !defined(NO_LOCALE_TOD) && defined(LC_TOD)
-# define USE_LOCALE_TOD
-# endif
+#endif
-/* XXX The next few defines are unfortunately duplicated in makedef.pl, and
- * changes here MUST also be made there */
+/* Even if not using locales, this header should be #included so as to #define
+ * some symbols which avoid #ifdefs to get things to compile. But make sure
+ * the macro it calls does nothing */
+#ifndef USE_LOCALE
+# undef PERL_LOCALE_TABLE_ENTRY
+# define PERL_LOCALE_TABLE_ENTRY(name, call_back)
+# include "locale_table.h"
+#endif
-# if ! defined(HAS_SETLOCALE) && defined(HAS_POSIX_2008_LOCALE)
-# define USE_POSIX_2008_LOCALE
-# ifndef USE_THREAD_SAFE_LOCALE
-# define USE_THREAD_SAFE_LOCALE
-# endif
- /* If compiled with
- * -DUSE_THREAD_SAFE_LOCALE, will do so even
- * on unthreaded builds */
-# elif (defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)) \
- && ( defined(HAS_POSIX_2008_LOCALE) \
- || (defined(WIN32) && defined(_MSC_VER) && _MSC_VER >= 1400)) \
- && ! defined(NO_THREAD_SAFE_LOCALE)
-# ifndef USE_THREAD_SAFE_LOCALE
+/* XXX The Configure probe for categories must be updated when adding new
+ * categories here */
+
+/* Create an enum that allows translation between the arbitrary locale category
+ * integers that a platform has, and our desired values that range from 0..n
+ * which makes array indexing feasible.
+ *
+ * In locale.c, there are a bunch of parallel arrays corresponding to this
+ * enum. The first element of each corresponds with the first enum value here,
+ * and so on. That means this enum must be in identical order with those
+ * arrays. This is guaranteed by using locale_table.h in all instances.
+ * (There are also asserts in locale.c that should fail if this gets
+ * out-of-sync.) So, if the platform doesn't have LC_CTYPE, but does have
+ * LC_NUMERIC, the code below will cause LC_NUMERIC_INDEX_ to be defined to be
+ * 0. That way the foo_INDEX_ values are contiguous non-negative integers,
+ * regardless of how the platform defines the actual locale categories.
+ *
+ * It is possible to tell perl it is not to pay attention to certain categories
+ * that exist on a platform (which means they are always kept in the "C"
+ * locale). For the ones perl is supposed to pay attention to, The hdr file
+ * creates a 'USE_LOCALE_foo' #define. If any are to be ignored by perl, it
+ * #defines HAS_IGNORED_LOCALE_CATEGORIES_ */
+typedef enum {
+
+#ifdef USE_LOCALE
+# undef PERL_LOCALE_TABLE_ENTRY
+# define PERL_LOCALE_TABLE_ENTRY(name, call_back) LC_ ## name ## _INDEX_,
+# include "locale_table.h"
+#endif /* USE_LOCALE */
+
+ LC_ALL_INDEX_ /* Always defined, even if no LC_ALL on system */
+
+} locale_category_index;
+
+#ifdef USE_LOCALE
+
+/* And a count of all the locale categories, mainly for use in array
+ * declarations */
+# define LOCALE_CATEGORIES_COUNT_ (LC_ALL_INDEX_ + 1)
+
+/* As a development aid for platforms that have LC_ALL name=value notation,
+ * setting -Accflags=-DUSE_FAKE_LC_ALL_POSITIONAL_NOTATION, simulates a
+ * platform that instead uses positional notation. By doing this, you can find
+ * many bugs without trying it out on a real such platform. It would be
+ * possible to create the reverse definitions for people who have ready access
+ * to a posiional notation box, but harder to get a name=value box */
+# if defined(USE_FAKE_LC_ALL_POSITIONAL_NOTATION) \
+ && defined(PERL_LC_ALL_USES_NAME_VALUE_PAIRS)
+# undef PERL_LC_ALL_USES_NAME_VALUE_PAIRS
+
+# define PERL_LC_ALL_CATEGORY_POSITIONS_INIT /* Assumes glibc cateories */\
+ { 12, 11, 10, 9, 8, 7, 5, 4, 3, 2, 1, 0 }
+# define PERL_LC_ALL_SEPARATOR "/ = /"
+# endif
+/* =========================================================================
+ * The defines from here to the following ===== line are unfortunately
+ * duplicated in makedef.pl, and changes here MUST also be made there */
+
+# if defined(USE_THREADS) && ! defined(NO_LOCALE_THREADS)
+# define USE_LOCALE_THREADS
+# endif
+
+ /* Use POSIX 2008 locales if available, and no alternative exists
+ * ('setlocale()' is the alternative); or is threaded and not forbidden to
+ * use them */
+# if ( defined(HAS_POSIX_2008_LOCALE) \
+ && ( ! defined(HAS_SETLOCALE) \
+ || ( defined(USE_LOCALE_THREADS) \
+ && ! defined(NO_POSIX_2008_LOCALE))) \
+ && ! defined(NO_THREAD_SAFE_LOCALE))
+# define USE_POSIX_2008_LOCALE
+# endif
+
+ /* On threaded builds, use thread-safe locales if they are available and not
+ * forbidden. Availability is when we are using POSIX 2008 locales, or
+ * Windows for any vintage recent enough to have _MSC_VER defined, or are
+ * using UCRT (principally MINGW in this latter case) */
+# if defined(USE_LOCALE_THREADS) && ! defined(NO_THREAD_SAFE_LOCALE)
+# if defined(USE_POSIX_2008_LOCALE) \
+ || (defined(WIN32) && (defined(_MSC_VER) || (defined(_UCRT))))
# define USE_THREAD_SAFE_LOCALE
# endif
-# ifdef HAS_POSIX_2008_LOCALE
-# define USE_POSIX_2008_LOCALE
+# endif
+
+# ifdef USE_POSIX_2008_LOCALE
+ /* XXX experimentally use this undocumented GCC feature. (Below also
+ * checks for its availability before actually using it.) */
+# ifndef USE_NL_LOCALE_NAME
+# define USE_NL_LOCALE_NAME
+# endif
+# if defined(HAS_QUERYLOCALE) \
+ /* Use querylocale if has it, or has the glibc internal \
+ * undocumented equivalent. */ \
+ || ( defined(_NL_LOCALE_NAME) \
+ /* And is asked for */ \
+ && defined(USE_NL_LOCALE_NAME) \
+ /* nl_langinfo_l almost certainly will exist on systems that \
+ * have _NL_LOCALE_NAME, so there is nothing lost by \
+ * requiring it instead of also allowing plain nl_langinfo(). \
+ * And experience indicates that its glibc implementation is \
+ * thread-safe, eliminating code complications */ \
+ && defined(HAS_NL_LANGINFO_L) \
+ /* On systems that accept any locale name, the real \
+ * underlying locale is often returned by this internal \
+ * langinfo item, so we can't use it */ \
+ && ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME))
+# define USE_QUERYLOCALE
# endif
# endif
-#endif
-/* Microsoft documentation reads in the change log for VS 2015:
- * "The localeconv function declared in locale.h now works correctly when
- * per-thread locale is enabled. In previous versions of the library, this
- * function would return the lconv data for the global locale, not the
- * thread's locale."
- */
-#if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE) && _MSC_VER < 1900
-# define TS_W32_BROKEN_LOCALECONV
+ /* POSIX 2008 has no means of finding out the current locale without a
+ * querylocale; so must keep track of it ourselves */
+# if (defined(USE_POSIX_2008_LOCALE) && ! defined(USE_QUERYLOCALE))
+# define USE_PL_CURLOCALES
+# endif
+
+# if defined(WIN32)
+
+ /* We need to be able to map the current value of what the tTHX context
+ * thinks LC_ALL is so as to inform the Windows libc when switching
+ * contexts. */
+# if defined(USE_THREAD_SAFE_LOCALE)
+# define USE_PL_CUR_LC_ALL
+# endif
+
+ /* Assume MingW without UCRT has the broken localeconv() that Microsoft
+ * fixed in VS 2015 */
+# if ! defined(_MSC_VER) && ! defined(_UCRT)
+# define TS_W32_BROKEN_LOCALECONV
+# endif
+# endif
+
+ /* POSIX 2008 and Windows with thread-safe locales keep locale information
+ * in libc data. Therefore we must inform their libc's when the context
+ * switches */
+# if defined(MULTIPLICITY) && ( defined(USE_POSIX_2008_LOCALE) \
+ || ( defined(WIN32) \
+ && defined(USE_THREAD_SAFE_LOCALE)))
+# define USE_PERL_SWITCH_LOCALE_CONTEXT
+# endif
+#endif /* End of USE_LOCALE */
+
+/* end of makedef.pl logic duplication
+ * ========================================================================= */
+
+#ifdef PERL_CORE
+
+/* These typedefs are used in locale.c only (and documented there), but defined
+ * here so that embed.fnc can generate the proper prototypes. */
+
+typedef enum { /* Is the locale UTF8? */
+ LOCALE_NOT_UTF8,
+ LOCALE_IS_UTF8,
+ LOCALE_UTF8NESS_UNKNOWN
+} locale_utf8ness_t;
+
+typedef struct {
+ const char *name;
+ size_t offset;
+} lconv_offset_t;
+
+typedef enum {
+ INTERNAL_FORMAT,
+ EXTERNAL_FORMAT_FOR_SET,
+ EXTERNAL_FORMAT_FOR_QUERY
+} calc_LC_ALL_format;
+
+typedef enum {
+ WANT_VOID,
+ WANT_TEMP_PV,
+ WANT_PL_setlocale_buf,
+} calc_LC_ALL_return;
+
+typedef enum {
+ no_override,
+ override_if_ignored,
+ check_that_overridden
+} parse_LC_ALL_STRING_action;
+
+typedef enum {
+ invalid,
+ no_array,
+ only_element_0,
+ full_array
+} parse_LC_ALL_string_return;
+
#endif
#include <setjmp.h>
/* Macros for correct constant construction. These are in C99 <stdint.h>
* (so they will not be available in strict C89 mode), but they are nice, so
- * let's define them if necessary.
+ * let's define them if necessary. */
+
+/*
=for apidoc_section $integer
=for apidoc Am|I16|INT16_C|number
=for apidoc_item |I32|INT32_C|number
(((U64)(x) & UINT64_C(0xff00000000000000)) >> 56) ))
# endif
-/* The old value was hard coded at 1008. (4096-16) seems to be a bit faster,
- at least on FreeBSD. YMMV, so experiment. */
-#ifndef PERL_ARENA_SIZE
-#define PERL_ARENA_SIZE 4080
-#endif
-
/* Maximum level of recursion */
#ifndef PERL_SUB_DEPTH_WARN
#define PERL_SUB_DEPTH_WARN 100
#define PERL_MULTICONCAT_IX_PLAIN_LEN 2 /* non-utf8 constant string length */
#define PERL_MULTICONCAT_IX_UTF8_PV 3 /* utf8 constant string */
#define PERL_MULTICONCAT_IX_UTF8_LEN 4 /* utf8 constant string length */
-#define PERL_MULTICONCAT_IX_LENGTHS 5 /* first of nargs+1 const segment lens */
-#define PERL_MULTICONCAT_HEADER_SIZE 5 /* The number of fields of a
+#define PERL_MULTICONCAT_IX_PADTMP0 5 /* up to 3 pad indexes for PADTMPs */
+#define PERL_MULTICONCAT_IX_PADTMP1 6
+#define PERL_MULTICONCAT_IX_PADTMP2 7
+#define PERL_MULTICONCAT_IX_LENGTHS 8 /* first of nargs+1 const segment lens */
+#define PERL_MULTICONCAT_HEADER_SIZE 8 /* The number of fields of a
multiconcat header */
/* We no longer default to creating a new SV for GvSV.
#define PERL_USES_PL_PIDSTATUS
#endif
-#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
+#if !defined(OS2) && !defined(WIN32)
#define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
#endif
#define MEM_SIZE Size_t
+/* av_extend and analogues enforce a minimum number of array elements.
+ * This has been 4 elements (so a minimum key size of 3) for a long
+ * time, but the rationale behind this seems to have been lost to the
+ * mists of time. */
+#ifndef PERL_ARRAY_NEW_MIN_KEY
+#define PERL_ARRAY_NEW_MIN_KEY 3
+#endif
+
+/* Functions like Perl_sv_grow mandate a minimum string size.
+ * This was 10 bytes for a long time, the rationale for which seems lost
+ * to the mists of time. However, this does not correlate to what modern
+ * malloc implementations will actually return, in particular the fact
+ * that chunks are almost certainly some multiple of pointer size. The
+ * default has therefore been revised to a more useful approximation.
+ * Notes: The following is specifically conservative for 64 bit, since
+ * most dlmalloc derivatives seem to serve a 3xPTRSIZE minimum chunk,
+ * so the below perhaps should be:
+ * ((PTRSIZE == 4) ? 12 : 24)
+ * Configure probes for malloc_good_size, malloc_actual_size etc.
+ * could be revised to record the actual minimum chunk size, to which
+ * PERL_STRLEN_NEW_MIN could then be set.
+ */
+#ifndef PERL_STRLEN_NEW_MIN
+#define PERL_STRLEN_NEW_MIN ((PTRSIZE == 4) ? 12 : 16)
+#endif
+
/* Round all values passed to malloc up, by default to a multiple of
sizeof(size_t)
*/
# define saferealloc Perl_realloc
# define safefree Perl_mfree
# define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \
- if (!TAINTING_get && MallocCfg_ptr[MallocCfg_cfg_env_read]) \
- code; \
+ if (!TAINTING_get && MallocCfg_ptr[MallocCfg_cfg_env_read]) \
+ code; \
} STMT_END
# define CHECK_MALLOC_TOO_LATE_FOR(ch) \
- CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch))
+ CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch))
# define panic_write2(s) write(2, s, strlen(s))
# define CHECK_MALLOC_TAINT(newval) \
- CHECK_MALLOC_TOO_LATE_FOR_( \
- if (newval) { \
- PERL_UNUSED_RESULT(panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n"));\
- exit(1); })
-# define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \
- if (doing_taint(argc,argv,env)) { \
- MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \
- }} STMT_END;
+ CHECK_MALLOC_TOO_LATE_FOR_( \
+ if (newval) { \
+ PERL_UNUSED_RESULT(panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n"));\
+ exit(1); })
+# define MALLOC_CHECK_TAINT(argc,argv,env) \
+ STMT_START { \
+ if (doing_taint(argc,argv,env)) { \
+ MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \
+ } \
+ } STMT_END;
#else /* MYMALLOC */
# define safemalloc safesysmalloc
# define safecalloc safesyscalloc
# endif
# endif
# ifdef I_NETDB
-# ifdef NETWARE
-# include<stdio.h>
-# endif
# include <netdb.h>
# endif
# ifndef ENOTSOCK
# undef SETERRNO /* SOCKS might have defined this */
#endif
+#if defined(VMS) || defined(WIN32) || defined(OS2)
+# define HAS_EXTENDED_OS_ERRNO
+# define get_extended_os_errno() Perl_get_extended_os_errno()
+# else
+# define get_extended_os_errno() errno
+# endif
#ifdef VMS
# define SETERRNO(errcode,vmserrcode) \
- STMT_START { \
- set_errno(errcode); \
- set_vaxc_errno(vmserrcode); \
- } STMT_END
+ STMT_START { \
+ set_errno(errcode); \
+ set_vaxc_errno(vmserrcode); \
+ } STMT_END
# define dSAVEDERRNO int saved_errno; unsigned saved_vms_errno
# define dSAVE_ERRNO int saved_errno = errno; unsigned saved_vms_errno = vaxc$errno
# define SAVE_ERRNO ( saved_errno = errno, saved_vms_errno = vaxc$errno )
if (!*svp) { \
*svp = newSVpvs(""); \
} else if (SvREADONLY(*svp)) { \
- SvREFCNT_dec_NN(*svp); \
- *svp = newSVpvs(""); \
+ SvREFCNT_dec_NN(*svp); \
+ *svp = newSVpvs(""); \
} else { \
- SV *const errsv = *svp; \
+ SV *const errsv = *svp; \
SvPVCLEAR(errsv); \
- SvPOK_only(errsv); \
- if (SvMAGICAL(errsv)) { \
- mg_free(errsv); \
- } \
+ SvPOK_only(errsv); \
+ if (SvMAGICAL(errsv)) { \
+ mg_free(errsv); \
+ } \
} \
} STMT_END
*svp = newSVpvs(""); \
} else if (SvREADONLY(*svp)) { \
SV *dupsv = newSVsv(*svp); \
- SvREFCNT_dec_NN(*svp); \
- *svp = dupsv; \
+ SvREFCNT_dec_NN(*svp); \
+ *svp = dupsv; \
} else { \
- SV *const errsv = *svp; \
- if (SvMAGICAL(errsv)) { \
- mg_free(errsv); \
- } \
+ SV *const errsv = *svp; \
+ if (SvMAGICAL(errsv)) { \
+ mg_free(errsv); \
+ } \
} \
} STMT_END
(SvREFCNT_dec(GvSV(PL_defgv)), GvSV(PL_defgv) = SvREFCNT_inc(sv))
# define SAVE_DEFSV \
( \
- save_gp(PL_defgv, 0), \
- GvINTRO_off(PL_defgv), \
- SAVEGENERICSV(GvSV(PL_defgv)), \
- GvSV(PL_defgv) = NULL \
+ save_gp(PL_defgv, 0), \
+ GvINTRO_off(PL_defgv), \
+ SAVEGENERICSV(GvSV(PL_defgv)), \
+ GvSV(PL_defgv) = NULL \
)
#else
# define DEFSV GvSVn(PL_defgv)
*/
#ifndef errno
- extern int errno; /* ANSI allows errno to be an lvalue expr.
- * For example in multithreaded environments
- * something like this might happen:
- * extern int *_errno(void);
- * #define errno (*_errno()) */
+ extern int errno; /* ANSI allows errno to be an lvalue expr.
+ * For example in multithreaded environments
+ * something like this might happen:
+ * extern int *_errno(void);
+ * #define errno (*_errno()) */
#endif
#define UNKNOWN_ERRNO_MSG "(unknown)"
#define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len > (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END
-#ifdef USE_QUADMATH
+#if defined(USE_LOCALE_NUMERIC) || defined(USE_QUADMATH)
# define my_snprintf Perl_my_snprintf
# define PERL_MY_SNPRINTF_GUARDED
#elif defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
/* There is no quadmath_vsnprintf, and therefore my_vsnprintf()
* dies if called under USE_QUADMATH. */
-#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
+#if ! defined(USE_LOCALE_NUMERIC) \
+ && defined(HAS_VSNPRINTF) \
+ && defined(HAS_C99_VARIADIC_MACROS) \
+ && ! (defined(DEBUGGING) && ! defined(PERL_USE_GCC_BRACE_GROUPS)) \
+ && ! defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
-# define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; })
+# define my_vsnprintf(buffer, max, ...) \
+ ({ int len = vsnprintf(buffer, max, __VA_ARGS__); \
+ PERL_SNPRINTF_CHECK(len, max, vsnprintf); \
+ len; })
# define PERL_MY_VSNPRINTF_GUARDED
# else
# define my_vsnprintf(buffer, max, ...) vsnprintf(buffer, max, __VA_ARGS__)
#endif
#ifndef PTR2ul
-# define PTR2ul(p) INT2PTR(unsigned long,p)
+# define PTR2ul(p) INT2PTR(unsigned long,p)
#endif
/*
-=for apidoc_section Casting
+=for apidoc_section $casting
=for apidoc Cyh|type|NUM2PTR|type|int value
You probably want to be using L<C</INT2PTR>> instead.
# endif
#endif
-typedef NVTYPE NV;
+/* On MS Windows,with 64-bit mingw-w64 compilers, we
+ need to attend to a __float128 alignment issue if
+ USE_QUADMATH is defined. Otherwise we simply:
+ typedef NVTYPE NV
+ 32-bit mingw.org compilers might also require
+ aligned(32) - at least that's what I found with my
+ Math::Foat128 module. But this is as yet untested
+ here, so no allowance is being made for mingw.org
+ compilers at this stage. -- sisyphus January 2021
+*/
+#if (defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)) && defined(__MINGW64__)
+ /* 64-bit build, mingw-w64 compiler only */
+ typedef NVTYPE NV __attribute__ ((aligned(8)));
+#else
+ typedef NVTYPE NV;
+#endif
#ifdef I_IEEEFP
# include <ieeefp.h>
# define Perl_cos cosl
# define Perl_cosh coshl
# define Perl_exp expl
-/* no Perl_fabs, but there's PERL_ABS */
+# define Perl_fabs fabsl
# define Perl_floor floorl
# define Perl_fmod fmodl
# define Perl_log logl
# define Perl_cos cosq
# define Perl_cosh coshq
# define Perl_exp expq
-/* no Perl_fabs, but there's PERL_ABS */
+# define Perl_fabs fabsq
# define Perl_floor floorq
# define Perl_fmod fmodq
# define Perl_log logq
# define Perl_ldexp(x, y) ldexpq(x,y)
# define Perl_isinf(x) isinfq(x)
# define Perl_isnan(x) isnanq(x)
-# define Perl_isfinite(x) !(isnanq(x) || isinfq(x))
+# define Perl_isfinite(x) (!(isnanq(x) || isinfq(x)))
# define Perl_fp_class(x) ((x) == 0.0Q ? 0 : isinfq(x) ? 3 : isnanq(x) ? 4 : PERL_ABS(x) < FLT128_MIN ? 2 : 1)
# define Perl_fp_class_inf(x) (Perl_fp_class(x) == 3)
# define Perl_fp_class_nan(x) (Perl_fp_class(x) == 4)
# define Perl_cos cos
# define Perl_cosh cosh
# define Perl_exp exp
-/* no Perl_fabs, but there's PERL_ABS */
+# define Perl_fabs fabs
# define Perl_floor floor
# define Perl_fmod fmod
# define Perl_log log
# define FP_QNAN FP_QNAN
# endif
# include <math.h>
-# ifdef I_IEEFP
+# ifdef I_IEEEFP
# include <ieeefp.h>
# endif
# ifdef I_FP
#ifndef Perl_isinf
# if defined(Perl_isfinite) && defined(Perl_isnan)
-# define Perl_isinf(x) !(Perl_isfinite(x)||Perl_isnan(x))
+# define Perl_isinf(x) (!(Perl_isfinite(x)||Perl_isnan(x)))
# endif
#endif
# define Perl_isfinitel(x) isfinitel(x)
# elif defined(HAS_FINITEL)
# define Perl_isfinitel(x) finitel(x)
-# elif defined(HAS_INFL) && defined(HAS_NANL)
-# define Perl_isfinitel(x) !(isinfl(x)||isnanl(x))
+# elif defined(HAS_ISINFL) && defined(HAS_ISNANL)
+# define Perl_isfinitel(x) (!(isinfl(x)||isnanl(x)))
# else
# define Perl_isfinitel(x) ((x) * 0 == 0) /* See Perl_isfinite. */
# endif
#endif
/* The default is to use Perl's own atof() implementation (in numeric.c).
- * Usually that is the one to use but for some platforms (e.g. UNICOS)
- * it is however best to use the native implementation of atof.
+ * This knows about if 'use locale' is in effect or not, and handles the radix
+ * character accordingly. On some platforms (e.g. UNICOS) it is however best
+ * to use the native implementation of atof, as long as you accept that the
+ * current underlying locale will affect the radix character. Perl's version
+ * uses a dot for a radix, execpt within the lexical scope of a Perl C<use
+ * locale> statement.
+ *
* You can experiment with using your native one by -DUSE_PERL_ATOF=0.
* Some good tests to try out with either setting are t/base/num.t,
* t/op/numconvert.t, and t/op/pack.t. Note that if using long doubles
#endif
#ifdef USE_PERL_ATOF
-# define Perl_atof(s) Perl_my_atof(s)
+# define Perl_atof(s) Perl_my_atof(aTHX_ s)
# define Perl_atof2(s, n) Perl_my_atof3(aTHX_ (s), &(n), 0)
#else
# define Perl_atof(s) (NV)atof(s)
#define my_atof2(a,b) my_atof3(a,b,0)
/*
+=for apidoc AmTR|NV|Atof|NN const char * const s
+
+This is a synonym for L</C<my_atof>>.
+
+=cut
+
+*/
+
+#define Atof my_atof
+
+/*
=for apidoc_section $numeric
=for apidoc AmT|NV|Perl_acos|NV x
=for apidoc_item |NV|Perl_asin|NV x
the highest precision one available is used.
=cut
+
*/
/*
/*
=for apidoc_section $integer
-=for apidoc AmnU||PERL_INT_MAX
-=for apidoc_item ||PERL_INT_MIN
-=for apidoc_item ||PERL_LONG_MAX
-=for apidoc_item ||PERL_LONG_MIN
-=for apidoc_item ||PERL_SHORT_MAX
-=for apidoc_item ||PERL_SHORT_MIN
-=for apidoc_item ||PERL_UCHAR_MAX
-=for apidoc_item ||PERL_UCHAR_MIN
-=for apidoc_item ||PERL_UINT_MAX
-=for apidoc_item ||PERL_UINT_MIN
-=for apidoc_item ||PERL_ULONG_MAX
-=for apidoc_item ||PERL_ULONG_MIN
-=for apidoc_item ||PERL_USHORT_MAX
-=for apidoc_item ||PERL_USHORT_MIN
-=for apidoc_item ||PERL_QUAD_MAX
-=for apidoc_item ||PERL_QUAD_MIN
-=for apidoc_item ||PERL_UQUAD_MAX
-=for apidoc_item ||PERL_UQUAD_MIN
+=for apidoc Amn |int|PERL_INT_MAX
+=for apidoc_item |int|PERL_INT_MIN
+=for apidoc_item |long|PERL_LONG_MAX
+=for apidoc_item |long|PERL_LONG_MIN
+=for apidoc_item |IV|PERL_QUAD_MAX
+=for apidoc_item |IV|PERL_QUAD_MIN
+=for apidoc_item |short|PERL_SHORT_MAX
+=for apidoc_item |short|PERL_SHORT_MIN
+=for apidoc_item |U8|PERL_UCHAR_MAX
+=for apidoc_item |U8|PERL_UCHAR_MIN
+=for apidoc_item |unsigned int|PERL_UINT_MAX
+=for apidoc_item |unsigned int|PERL_UINT_MIN
+=for apidoc_item |unsigned long|PERL_ULONG_MAX
+=for apidoc_item |unsigned long|PERL_ULONG_MIN
+=for apidoc_item |UV|PERL_UQUAD_MAX
+=for apidoc_item |UV|PERL_UQUAD_MIN
+=for apidoc_item |unsigned short|PERL_USHORT_MAX
+=for apidoc_item |unsigned short|PERL_USHORT_MIN
These give the largest and smallest number representable in the current
platform in variables of the corresponding types.
typedef struct xpvbm XPVBM;
typedef struct xpvfm XPVFM;
typedef struct xpvio XPVIO;
+typedef struct xobject XPVOBJ;
typedef struct mgvtbl MGVTBL;
typedef union any ANY;
typedef struct ptr_tbl_ent PTR_TBL_ENT_t;
# define USE_ENVIRON_ARRAY
#endif
-#ifdef USE_ITHREADS
- /* On some platforms it would be safe to use a read/write mutex with many
- * readers possible at the same time. On other platforms, notably IBM ones,
- * subsequent getenv calls destroy earlier ones. Those platforms would not
- * be able to handle simultaneous getenv calls */
-# define ENV_LOCK MUTEX_LOCK(&PL_env_mutex)
-# define ENV_UNLOCK MUTEX_UNLOCK(&PL_env_mutex)
-# define ENV_INIT MUTEX_INIT(&PL_env_mutex);
-# define ENV_TERM MUTEX_DESTROY(&PL_env_mutex);
-#else
-# define ENV_LOCK NOOP
-# define ENV_UNLOCK NOOP
-# define ENV_INIT NOOP
-# define ENV_TERM NOOP
-#endif
-
-/* Some critical sections need to lock both the locale and the environment.
- * XXX khw intends to change this to lock both mutexes, but that brings up
- * issues of potential deadlock, so should be done at the beginning of a
- * development cycle. So for now, it just locks the environment. Note that
- * many modern platforms are locale-thread-safe anyway, so locking the locale
- * mutex is a no-op anyway */
-#define ENV_LOCALE_LOCK ENV_LOCK
-#define ENV_LOCALE_UNLOCK ENV_UNLOCK
-
-/* And some critical sections care only that no one else is writing either the
- * locale nor the environment. XXX Again this is for the future. This can be
- * simulated with using COND_WAIT in thread.h */
-#define ENV_LOCALE_READ_LOCK ENV_LOCALE_LOCK
-#define ENV_LOCALE_READ_UNLOCK ENV_LOCALE_UNLOCK
-
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
/* having sigaction(2) means that the OS supports both 1-arg and 3-arg
* signal handlers. But the perl core itself only fully supports 1-arg
and then they have the gall to warn that a value computed is not used. Hence
cast to void. */
# define PERL_FPU_INIT (void)fpsetmask(0)
-# elif defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO)
+# elif defined(SIGFPE) && defined(SIG_IGN)
# define PERL_FPU_INIT PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN)
# define PERL_FPU_PRE_EXEC { Sigsave_t xfpe; rsignal_save(SIGFPE, PL_sigfpe_saved, &xfpe);
# define PERL_FPU_POST_EXEC rsignal_restore(SIGFPE, &xfpe); }
/*
=for apidoc_section $embedding
-=for apidoc Am|void|PERL_SYS_INIT|int *argc|char*** argv
-Provides system-specific tune up of the C runtime environment necessary to
-run Perl interpreters. This should be called only once, before creating
-any Perl interpreters.
+=for apidoc Am|void|PERL_SYS_INIT |int *argc|char*** argv
+=for apidoc_item| |PERL_SYS_INIT3|int *argc|char*** argv|char*** env
+
+These provide system-specific tune up of the C runtime environment necessary to
+run Perl interpreters. Only one should be used, and it should be called only
+once, before creating any Perl interpreters.
-=for apidoc Am|void|PERL_SYS_INIT3|int *argc|char*** argv|char*** env
-Provides system-specific tune up of the C runtime environment necessary to
-run Perl interpreters. This should be called only once, before creating
-any Perl interpreters.
+They differ in that C<PERL_SYS_INIT3> also initializes C<env>.
=for apidoc Am|void|PERL_SYS_TERM|
Provides system-specific clean up of the C runtime environment after
* documentation for details. */
#if defined(USE_ITHREADS)
-# ifdef NETWARE
-# include <nw5thread.h>
-# elif defined(WIN32)
+# if defined(WIN32)
# include <win32thread.h>
# elif defined(OS2)
# include "os2thread.h"
# endif
/* Many readers; single writer */
-typedef struct perl_RnW1_mutex {
+typedef struct {
perl_mutex lock;
- perl_cond zero_readers;
- Size_t readers_count;
-} Perl_W1Rn_mutex_t;
+ perl_cond wakeup;
+ SSize_t readers_count;
+} perl_RnW1_mutex_t;
#endif /* USE_ITHREADS */
# include "win32.h"
#endif
-#ifdef NETWARE
-# include "netware.h"
-#endif
-
#define STATUS_UNIX PL_statusvalue
#ifdef VMS
# define STATUS_NATIVE PL_statusvalue_vms
*/
# define STATUS_EXIT \
- (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \
- (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0))
+ (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \
+ (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0))
/* STATUS_NATIVE_CHILD_SET - Calculate UNIX status that matches the child
*/
# define STATUS_NATIVE_CHILD_SET(n) \
- STMT_START { \
- I32 evalue = (I32)n; \
- if (evalue == EVMSERR) { \
- PL_statusvalue_vms = vaxc$errno; \
- PL_statusvalue = evalue; \
- } else { \
- PL_statusvalue_vms = evalue; \
- if (evalue == -1) { \
- PL_statusvalue = -1; \
- PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \
- } else \
- PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \
- set_vaxc_errno(evalue); \
- if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \
- set_errno(EVMSERR); \
- else set_errno(Perl_vms_status_to_unix(evalue, 0)); \
- PL_statusvalue = PL_statusvalue << child_offset_bits; \
- } \
- } STMT_END
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ if (evalue == EVMSERR) { \
+ PL_statusvalue_vms = vaxc$errno; \
+ PL_statusvalue = evalue; \
+ } else { \
+ PL_statusvalue_vms = evalue; \
+ if (evalue == -1) { \
+ PL_statusvalue = -1; \
+ PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \
+ } else \
+ PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \
+ set_vaxc_errno(evalue); \
+ if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \
+ set_errno(EVMSERR); \
+ else set_errno(Perl_vms_status_to_unix(evalue, 0)); \
+ PL_statusvalue = PL_statusvalue << child_offset_bits; \
+ } \
+ } STMT_END
# ifdef VMSISH_STATUS
# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX)
* This is used when Perl is forcing errno to have a specific value.
*/
# define STATUS_UNIX_SET(n) \
- STMT_START { \
- I32 evalue = (I32)n; \
- PL_statusvalue = evalue; \
- if (PL_statusvalue != -1) { \
- if (PL_statusvalue != EVMSERR) { \
- PL_statusvalue &= 0xFFFF; \
- if (MY_POSIX_EXIT) \
- PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\
- else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
- } \
- else { \
- PL_statusvalue_vms = vaxc$errno; \
- } \
- } \
- else PL_statusvalue_vms = SS$_ABORT; \
- set_vaxc_errno(PL_statusvalue_vms); \
- } STMT_END
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (PL_statusvalue != -1) { \
+ if (PL_statusvalue != EVMSERR) { \
+ PL_statusvalue &= 0xFFFF; \
+ if (MY_POSIX_EXIT) \
+ PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\
+ else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
+ } \
+ else { \
+ PL_statusvalue_vms = vaxc$errno; \
+ } \
+ } \
+ else PL_statusvalue_vms = SS$_ABORT; \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } STMT_END
/* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets
* the NATIVE error status based on it.
*/
# define STATUS_UNIX_EXIT_SET(n) \
- STMT_START { \
- I32 evalue = (I32)n; \
- PL_statusvalue = evalue; \
- if (MY_POSIX_EXIT) { \
- if (evalue <= 0xFF00) { \
- if (evalue > 0xFF) \
- evalue = (evalue >> child_offset_bits) & 0xFF; \
- PL_statusvalue_vms = \
- (C_FAC_POSIX | (evalue << 3 ) | \
- ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \
- } else /* forgive them Perl, for they have sinned */ \
- PL_statusvalue_vms = evalue; \
- } else { \
- if (evalue == 0) \
- PL_statusvalue_vms = SS$_NORMAL; \
- else if (evalue <= 0xFF00) \
- PL_statusvalue_vms = SS$_ABORT; \
- else { /* forgive them Perl, for they have sinned */ \
- if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \
- else PL_statusvalue_vms = vaxc$errno; \
- /* And obviously used a VMS status value instead of UNIX */ \
- PL_statusvalue = EVMSERR; \
- } \
- set_vaxc_errno(PL_statusvalue_vms); \
- } \
- } STMT_END
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (MY_POSIX_EXIT) { \
+ if (evalue <= 0xFF00) { \
+ if (evalue > 0xFF) \
+ evalue = ((U8) (evalue >> child_offset_bits)); \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | \
+ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \
+ } else /* forgive them Perl, for they have sinned */ \
+ PL_statusvalue_vms = evalue; \
+ } else { \
+ if (evalue == 0) \
+ PL_statusvalue_vms = SS$_NORMAL; \
+ else if (evalue <= 0xFF00) \
+ PL_statusvalue_vms = SS$_ABORT; \
+ else { /* forgive them Perl, for they have sinned */ \
+ if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \
+ else PL_statusvalue_vms = vaxc$errno; \
+ /* And obviously used a VMS status value instead of UNIX */ \
+ PL_statusvalue = EVMSERR; \
+ } \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } \
+ } STMT_END
/* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code
*/
# define STATUS_EXIT_SET(n) \
- STMT_START { \
- I32 evalue = (I32)n; \
- PL_statusvalue = evalue; \
- if (MY_POSIX_EXIT) \
- if (evalue > 255) PL_statusvalue_vms = evalue; else { \
- PL_statusvalue_vms = \
- (C_FAC_POSIX | (evalue << 3 ) | \
- ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \
- else \
- PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \
- set_vaxc_errno(PL_statusvalue_vms); \
- } STMT_END
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (MY_POSIX_EXIT) \
+ if (evalue > 255) PL_statusvalue_vms = evalue; else { \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | \
+ ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \
+ else \
+ PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } STMT_END
/* This macro forces a success status */
# define STATUS_ALL_SUCCESS \
- (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL)
+ (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL)
/* This macro forces a failure status */
# define STATUS_ALL_FAILURE (PL_statusvalue = 1, \
vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \
- (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT)
+ (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT)
#elif defined(__amigaos4__)
/* A somewhat experimental attempt to simulate posix return code values */
} \
} STMT_END
# define STATUS_UNIX_SET(n) \
- STMT_START { \
- PL_statusvalue = (n); \
- if (PL_statusvalue != -1) \
- PL_statusvalue &= 0xFFFF; \
- } STMT_END
+ STMT_START { \
+ PL_statusvalue = (n); \
+ if (PL_statusvalue != -1) \
+ PL_statusvalue &= 0xFFFF; \
+ } STMT_END
# define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n)
# define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n)
# define STATUS_CURRENT STATUS_UNIX
} STMT_END
# endif
# define STATUS_UNIX_SET(n) \
- STMT_START { \
- PL_statusvalue = (n); \
- if (PL_statusvalue != -1) \
- PL_statusvalue &= 0xFFFF; \
- } STMT_END
+ STMT_START { \
+ PL_statusvalue = (n); \
+ if (PL_statusvalue != -1) \
+ PL_statusvalue &= 0xFFFF; \
+ } STMT_END
# define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n)
# define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n)
# define STATUS_CURRENT STATUS_UNIX
# define PERL_FS_VERSION PERL_VERSION_STRING
#endif
-/* This defines a way to flush all output buffers. This may be a
- * performance issue, so we allow people to disable it. Also, if
- * we are using stdio, there are broken implementations of fflush(NULL)
- * out there, Solaris being the most prominent.
+/*
+
+=for apidoc_section $io
+=for apidoc Amn|void|PERL_FLUSHALL_FOR_CHILD
+
+This defines a way to flush all output buffers. This may be a
+performance issue, so we allow people to disable it. Also, if
+we are using stdio, there are broken implementations of fflush(NULL)
+out there, Solaris being the most prominent.
+
+=cut
*/
+
#ifndef PERL_FLUSHALL_FOR_CHILD
# if defined(USE_PERLIO) || defined(FFLUSH_NULL)
# define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL)
/* the traditional thread-unsafe notion of "current interpreter". */
#ifndef PERL_SET_INTERP
-# define PERL_SET_INTERP(i) (PL_curinterp = (PerlInterpreter*)(i))
+# define PERL_SET_INTERP(i) \
+ STMT_START { PL_curinterp = (PerlInterpreter*)(i); \
+ PERL_SET_NON_tTHX_CONTEXT(i); \
+ } STMT_END
#endif
#ifndef PERL_GET_INTERP
# define PERL_GET_INTERP (PL_curinterp)
#endif
-#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX)
-# ifdef MULTIPLICITY
-# define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT)
-# endif
+#if defined(MULTIPLICITY) && !defined(PERL_GET_THX)
+# define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT)
# define PERL_SET_THX(t) PERL_SET_CONTEXT(t)
#endif
#define SVfARG(p) ((void*)(p))
+/* Render an SV as a quoted and escaped string suitable for an error message.
+ * Only shows the first PERL_QUOTEDPREFIX_LEN characters, and adds ellipses if the
+ * string is too long.
+ */
+#ifndef PERL_QUOTEDPREFIX_LEN
+# define PERL_QUOTEDPREFIX_LEN 256
+#endif
+#ifndef SVf_QUOTEDPREFIX
+# define SVf_QUOTEDPREFIX "5p"
+#endif
+
+/* like %s but runs through the quoted prefix logic */
+#ifndef PVf_QUOTEDPREFIX
+# define PVf_QUOTEDPREFIX "1p"
+#endif
+
#ifndef HEKf
# define HEKf "2p"
#endif
+#ifndef HEKf_QUOTEDPREFIX
+# define HEKf_QUOTEDPREFIX "7p"
+#endif
+
/* Not ideal, but we cannot easily include a number in an already-numeric
* format sequence. */
#ifndef HEKf256
# define HEKf256 "3p"
#endif
+#ifndef HEKf256_QUOTEDPREFIX
+# define HEKf256_QUOTEDPREFIX "8p"
+#endif
+
#define HEKfARG(p) ((void*)(p))
/* Documented in perlguts
*
- * %4p is a custom format
+ * %4p and %9p are custom formats for handling UTF8 parameters.
+ * They only occur when prefixed by specific other formats.
*/
#ifndef UTF8f
# define UTF8f "d%" UVuf "%4p"
#endif
+#ifndef UTF8f_QUOTEDPREFIX
+# define UTF8f_QUOTEDPREFIX "d%" UVuf "%9p"
+#endif
#define UTF8fARG(u,l,p) (int)cBOOL(u), (UV)(l), (void*)(p)
#define PNf UTF8f
#define PNfARG(pn) (int)1, (UV)PadnameLEN(pn), (void *)PadnamePV(pn)
+#define HvNAMEf "6p"
+#define HvNAMEf_QUOTEDPREFIX "10p"
+
+#define HvNAMEfARG(hv) ((void*)(hv))
+
#ifdef PERL_CORE
/* not used; but needed for backward compatibility with XS code? - RMB
+=for apidoc_section $io_formats
=for apidoc AmnD|const char *|UVf
Obsolete form of C<UVuf>, which you should convert to instead use
# define __has_builtin(x) 0 /* not a clang style compiler */
#endif
+#ifdef PERL_STACK_OFFSET_SSIZET
+ typedef SSize_t Stack_off_t;
+# define Stack_off_t_MAX SSize_t_MAX
+#else
+ typedef I32 Stack_off_t;
+# define Stack_off_t_MAX I32_MAX
+#endif
+#define PERL_STACK_OFFSET_DEFINED
+
/*
=for apidoc Am||ASSUME|bool expr
C<ASSUME> is like C<assert()>, but it has a benefit in a release build. It is a
=cut
*/
-#ifdef DEBUGGING
-# define ASSUME(x) assert(x)
-# if __has_builtin(__builtin_unreachable)
+#if __has_builtin(__builtin_unreachable)
# define HAS_BUILTIN_UNREACHABLE
-# elif (defined(__GNUC__) && ( __GNUC__ > 4 \
- || __GNUC__ == 4 && __GNUC_MINOR__ >= 5))
+#elif PERL_GCC_VERSION_GE(4,5,0)
# define HAS_BUILTIN_UNREACHABLE
-# endif
#endif
-#if defined(__sun) || (defined(__hpux) && !defined(__GNUC__))
-# ifndef ASSUME
-# define ASSUME(x) /* ASSUME() generates warnings on Solaris */
+#ifdef DEBUGGING
+# define ASSUME(x) assert(x)
+#elif __has_builtin(__builtin_assume)
+# if defined(__clang__) || defined(__clang)
+# define ASSUME(x) CLANG_DIAG_IGNORE(-Wassume) \
+ __builtin_assume (x) \
+ CLANG_DIAG_RESTORE
+# else
+# define ASSUME(x) __builtin_assume(x)
# endif
-# define NOT_REACHED
+#elif defined(_MSC_VER)
+# define ASSUME(x) __assume(x)
+#elif defined(__ARMCC_VERSION) /* untested */
+# define ASSUME(x) __promise(x)
#elif defined(HAS_BUILTIN_UNREACHABLE)
-# ifndef ASSUME
+ /* Compilers can take the hint from something being unreachable */
# define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable())
-# endif
+#else
+ /* Not DEBUGGING, so assert() is a no-op, but a random compiler might
+ * define assert() to its own special optimization token so pass it through
+ * to C lib as a last resort */
+# define ASSUME(x) assert(x)
+#endif
+
+#ifdef HAS_BUILTIN_UNREACHABLE
# define NOT_REACHED \
STMT_START { \
ASSUME(!"UNREACHABLE"); __builtin_unreachable(); \
} STMT_END
+# undef HAS_BUILTIN_UNREACHABLE /* Don't leak out this internal symbol */
+#elif ! defined(__GNUC__) && (defined(__sun) || defined(__hpux))
+ /* These just complain that NOT_REACHED isn't reached */
+# define NOT_REACHED
#else
-# if defined(_MSC_VER)
-# define ASSUME(x) __assume(x)
-# elif defined(__ARMCC_VERSION) /* untested */
-# define ASSUME(x) __promise(x)
-# else
- /* a random compiler might define assert to its own special optimization
- * token so pass it through to C lib as a last resort */
-# define ASSUME(x) assert(x)
-# endif
-# define NOT_REACHED ASSUME(!"UNREACHABLE")
+# define NOT_REACHED ASSUME(!"UNREACHABLE")
#endif
-#undef HAS_BUILTIN_UNREACHABLE
/* Some unistd.h's give a prototype for pause() even though
HAS_PAUSE ends up undefined. This causes the #define
#ifndef IOCPARM_LEN
# ifdef IOCPARM_MASK
- /* on BSDish systems we're safe */
+ /* on BSDish systems we're safe */
# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
# elif defined(_IOC_SIZE) && defined(__GLIBC__)
- /* on Linux systems we're safe; except when we're not [perl #38223] */
+ /* on Linux systems we're safe; except when we're not [perl #38223] */
# define IOCPARM_LEN(x) (_IOC_SIZE(x) < 256 ? 256 : _IOC_SIZE(x))
# else
- /* otherwise guess at what's safe */
+ /* otherwise guess at what's safe */
# define IOCPARM_LEN(x) 256
# endif
#endif
UNION_ANY_DEFINITION;
#else
union any {
- void* any_ptr;
+ void* any_ptr;
SV* any_sv;
SV** any_svp;
GV* any_gv;
OP* any_op;
char* any_pv;
char** any_pvp;
- I32 any_i32;
- U32 any_u32;
- IV any_iv;
- UV any_uv;
- long any_long;
- bool any_bool;
- void (*any_dptr) (void*);
- void (*any_dxptr) (pTHX_ void*);
+ I32 any_i32;
+ U32 any_u32;
+ IV any_iv;
+ UV any_uv;
+ long any_long;
+ bool any_bool;
+ Size_t any_size;
+ SSize_t any_ssize;
+ STRLEN any_strlen;
+ void (*any_dptr) (void*);
+ void (*any_dxptr) (pTHX_ void*);
};
#endif
#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
#define FILTER_DATA(idx) \
- (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL)
+ (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL)
#define FILTER_ISREADER(idx) \
- (PL_parser && PL_parser->rsfp_filters \
- && idx >= AvFILLp(PL_parser->rsfp_filters))
+ (PL_parser && PL_parser->rsfp_filters \
+ && idx >= AvFILLp(PL_parser->rsfp_filters))
#define PERL_FILTER_EXISTS(i) \
- (PL_parser && PL_parser->rsfp_filters \
- && (Size_t) (i) < av_count(PL_parser->rsfp_filters))
+ (PL_parser && PL_parser->rsfp_filters \
+ && (Size_t) (i) < av_count(PL_parser->rsfp_filters))
#if defined(_AIX) && !defined(_AIX43)
#if defined(USE_REENTRANT) || defined(_REENTRANT) || defined(_THREAD_SAFE)
#define FAKE_BIT_BUCKET
#endif
-/* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0.
+/* [perl #22371] Algorithmic Complexity Attack on Perl 5.6.1, 5.8.0.
* Note that the USE_HASH_SEED and similar defines are *NOT* defined by
* Configure, despite their names being similar to other defines like
* USE_ITHREADS. Configure in fact knows nothing about the randomised
/* macros to define bit-fields in structs. */
#ifndef PERL_BITFIELD8
+# ifdef HAS_NON_INT_BITFIELDS
# define PERL_BITFIELD8 U8
+# else
+# define PERL_BITFIELD8 unsigned
+# endif
#endif
#ifndef PERL_BITFIELD16
+# ifdef HAS_NON_INT_BITFIELDS
# define PERL_BITFIELD16 U16
+# else
+# define PERL_BITFIELD16 unsigned
+# endif
#endif
#ifndef PERL_BITFIELD32
+# ifdef HAS_NON_INT_BITFIELDS
# define PERL_BITFIELD32 U32
+# else
+# define PERL_BITFIELD32 unsigned
+# endif
#endif
#include "sv.h"
typedef struct magic_state MGS; /* struct magic_state defined in mg.c */
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) \
- || defined(PERL_EXT_RE_BUILD)
+#if defined(PERL_IN_REGEX_ENGINE) || defined(PERL_EXT_RE_BUILD)
/* These have to be predeclared, as they are used in proto.h which is #included
* before their definitions in regcomp.h. */
typedef struct regnode_ssc regnode_ssc;
typedef struct RExC_state_t RExC_state_t;
struct _reg_trie_data;
+typedef struct scan_data_t scan_data_t;
#endif
PERL_STATIC_INLINE U32
my_swap32(const U32 x) {
- return ((x & 0xFF) << 24) | ((x >> 24) & 0xFF)
+ return ((x & 0xFF) << 24) | ((x >> 24) & 0xFF)
| ((x & 0x0000FF00) << 8) | ((x & 0x00FF0000) >> 8);
}
the error message. Please check the value of the macro BYTEORDER, as defined
in config.h. The values of BYTEORDER we expect are
- big endian little endian
+ big endian little endian
32 bit 0x4321 0x1234
64 bit 0x87654321 0x12345678
# define htovs(x) vtohs(x)
#elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
# define vtohl(x) ((((x)&0xFF)<<24) \
- +(((x)>>24)&0xFF) \
- +(((x)&0x0000FF00)<<8) \
- +(((x)&0x00FF0000)>>8) )
+ +(((x)>>24)&0xFF) \
+ +(((x)&0x0000FF00)<<8) \
+ +(((x)&0x00FF0000)>>8) )
# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF))
# define htovl(x) vtohl(x)
# define htovs(x) vtohs(x)
#define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX)
/* Used with UV/IV arguments: */
- /* XXXX: need to speed it up */
+ /* XXXX: need to speed it up */
#define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv))
#define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv))
#ifndef Perl_error_log
# define Perl_error_log (PL_stderrgv \
- && isGV(PL_stderrgv) \
- && GvIOp(PL_stderrgv) \
- && IoOFP(GvIOp(PL_stderrgv)) \
- ? IoOFP(GvIOp(PL_stderrgv)) \
- : PerlIO_stderr())
+ && isGV(PL_stderrgv) \
+ && GvIOp(PL_stderrgv) \
+ && IoOFP(GvIOp(PL_stderrgv)) \
+ ? IoOFP(GvIOp(PL_stderrgv)) \
+ : PerlIO_stderr())
#endif
#define DEBUG_u_FLAG 0x00000800 /* 2048 */
/* U is reserved for Unofficial, exploratory hacking */
#define DEBUG_U_FLAG 0x00001000 /* 4096 */
-/* spare 8192 */
+#define DEBUG_h_FLAG 0x00002000 /* 8192 */
#define DEBUG_X_FLAG 0x00004000 /* 16384 */
#define DEBUG_D_FLAG 0x00008000 /* 32768 */
#define DEBUG_S_FLAG 0x00010000 /* 65536 */
#define DEBUG_DB_RECURSE_FLAG 0x40000000
#define DEBUG_TOP_FLAG 0x80000000 /* -D was given --> PL_debug |= FLAG */
+/* Both flags have to be set */
+# define DEBUG_BOTH_FLAGS_TEST_(flag1, flag2) \
+ UNLIKELY((PL_debug & ((flag1)|(flag2))) \
+ == ((flag1)|(flag2)))
+
# define DEBUG_p_TEST_ UNLIKELY(PL_debug & DEBUG_p_FLAG)
# define DEBUG_s_TEST_ UNLIKELY(PL_debug & DEBUG_s_FLAG)
# define DEBUG_l_TEST_ UNLIKELY(PL_debug & DEBUG_l_FLAG)
# define DEBUG_x_TEST_ UNLIKELY(PL_debug & DEBUG_x_FLAG)
# define DEBUG_u_TEST_ UNLIKELY(PL_debug & DEBUG_u_FLAG)
# define DEBUG_U_TEST_ UNLIKELY(PL_debug & DEBUG_U_FLAG)
+# define DEBUG_h_TEST_ UNLIKELY(PL_debug & DEBUG_h_FLAG)
# define DEBUG_X_TEST_ UNLIKELY(PL_debug & DEBUG_X_FLAG)
# define DEBUG_D_TEST_ UNLIKELY(PL_debug & DEBUG_D_FLAG)
# define DEBUG_S_TEST_ UNLIKELY(PL_debug & DEBUG_S_FLAG)
# define DEBUG_q_TEST_ UNLIKELY(PL_debug & DEBUG_q_FLAG)
# define DEBUG_M_TEST_ UNLIKELY(PL_debug & DEBUG_M_FLAG)
# define DEBUG_B_TEST_ UNLIKELY(PL_debug & DEBUG_B_FLAG)
-# define DEBUG_L_TEST_ UNLIKELY(PL_debug & DEBUG_L_FLAG)
+
+/* Locale initialization comes earlier than PL_debug gets set,
+ * DEBUG_LOCALE_INITIALIZATION_, if defined, will be set early enough */
+# ifndef DEBUG_LOCALE_INITIALIZATION_
+# define DEBUG_LOCALE_INITIALIZATION_ 0
+# endif
+# define DEBUG_L_TEST_ \
+ ( UNLIKELY(DEBUG_LOCALE_INITIALIZATION_) \
+ || UNLIKELY(PL_debug & DEBUG_L_FLAG))
+# define DEBUG_Lv_TEST_ \
+ ( UNLIKELY(DEBUG_LOCALE_INITIALIZATION_) \
+ || UNLIKELY(DEBUG_BOTH_FLAGS_TEST_(DEBUG_L_FLAG, DEBUG_v_FLAG)))
# define DEBUG_i_TEST_ UNLIKELY(PL_debug & DEBUG_i_FLAG)
# define DEBUG_y_TEST_ UNLIKELY(PL_debug & DEBUG_y_FLAG)
-# define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
-# define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_)
-# define DEBUG_Pv_TEST_ (DEBUG_P_TEST_ && DEBUG_v_TEST_)
-# define DEBUG_Lv_TEST_ (DEBUG_L_TEST_ && DEBUG_v_TEST_)
-# define DEBUG_yv_TEST_ (DEBUG_y_TEST_ && DEBUG_v_TEST_)
+# define DEBUG_Xv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_X_FLAG, DEBUG_v_FLAG)
+# define DEBUG_Uv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_U_FLAG, DEBUG_v_FLAG)
+# define DEBUG_Pv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_P_FLAG, DEBUG_v_FLAG)
+# define DEBUG_yv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_y_FLAG, DEBUG_v_FLAG)
#ifdef DEBUGGING
# define DEBUG_x_TEST DEBUG_x_TEST_
# define DEBUG_u_TEST DEBUG_u_TEST_
# define DEBUG_U_TEST DEBUG_U_TEST_
+# define DEBUG_h_TEST DEBUG_h_TEST_
# define DEBUG_X_TEST DEBUG_X_TEST_
# define DEBUG_D_TEST DEBUG_D_TEST_
# define DEBUG_S_TEST DEBUG_S_TEST_
} \
} STMT_END
+/* These allow you to customize your debugging output for specialized,
+ * generally temporary ad-hoc purposes. For example, if you need 'errno'
+ * preserved, you can add definitions to these macros (either in this file for
+ * the whole program, or before the #include "perl.h" in a particular .c file
+ * you're trying to debug) and recompile:
+ *
+ * #define DEBUG_PRE_STMTS dSAVE_ERRNO;
+ * #define DEBUG_POST_STMTS RESTORE_ERRNO;
+ *
+ * Other potential things include displaying timestamps, location information,
+ * which thread, etc. Here's an example with both errno and location info:
+ *
+ * #define DEBUG_PRE_STMTS dSAVE_ERRNO; \
+ * PerlIO_printf(Perl_debug_log, "%s:%d: ", __FILE__, __LINE__);
+ * #define DEBUG_POST RESTORE_ERRNO;
+ *
+ * All DEBUG statements in the compiled scope will have these extra statements
+ * compiled in; they will be executed only for the DEBUG statements whose flags
+ * are turned on.
+ */
+#ifndef DEBUG_PRE_STMTS
+# define DEBUG_PRE_STMTS
+#endif
+#ifndef DEBUG_POST_STMTS
+# define DEBUG_POST_STMTS
+#endif
+
# define DEBUG__(t, a) \
STMT_START { \
- if (t) STMT_START {a;} STMT_END; \
+ if (t) { \
+ DEBUG_PRE_STMTS a; DEBUG_POST_STMTS \
+ } \
} STMT_END
# define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a)
/* For re_comp.c, re_exec.c, assume -Dr has been specified */
# ifdef PERL_EXT_RE_BUILD
-# define DEBUG_r(a) STMT_START {a;} STMT_END
+# define DEBUG_r(a) STMT_START { \
+ DEBUG_PRE_STMTS a; DEBUG_POST_STMTS \
+ } STMT_END;
# else
# define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a)
# endif /* PERL_EXT_RE_BUILD */
# define DEBUG_x_TEST (0)
# define DEBUG_u_TEST (0)
# define DEBUG_U_TEST (0)
+# define DEBUG_h_TEST (0)
# define DEBUG_X_TEST (0)
# define DEBUG_D_TEST (0)
# define DEBUG_S_TEST (0)
#define DEBUG_SCOPE(where) \
DEBUG_l( \
Perl_deb(aTHX_ "%s scope %ld (savestack=%ld) at %s:%d\n", \
- where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \
- __FILE__, __LINE__));
+ where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \
+ __FILE__, __LINE__));
/* Keep the old croak based assert for those who want it, and as a fallback if
the platform is so heretically non-ANSI that it can't assert. */
#define Perl_assert(what) PERL_DEB2( \
- ((what) ? ((void) 0) : \
- (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \
- "\", line %d", STRINGIFY(what), __LINE__), \
+ ((what) ? ((void) 0) : \
+ (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \
+ "\", line %d", STRINGIFY(what), __LINE__), \
(void) 0)), ((void)0))
/* assert() gets defined if DEBUGGING.
#if defined(USE_PERLIO)
EXTERN_C void PerlIO_teardown(void);
-# ifdef USE_ITHREADS
+# ifdef USE_THREADS
# define PERLIO_INIT MUTEX_INIT(&PL_perlio_mutex)
# define PERLIO_TERM \
- STMT_START { \
- PerlIO_teardown(); \
- MUTEX_DESTROY(&PL_perlio_mutex);\
- } STMT_END
+ STMT_START { \
+ PerlIO_teardown(); \
+ MUTEX_DESTROY(&PL_perlio_mutex);\
+ } STMT_END
# else
# define PERLIO_INIT
# define PERLIO_TERM PerlIO_teardown()
#ifdef MYMALLOC
# ifdef MUTEX_INIT_CALLS_MALLOC
# define MALLOC_INIT \
- STMT_START { \
- PL_malloc_mutex = NULL; \
- MUTEX_INIT(&PL_malloc_mutex); \
- } STMT_END
+ STMT_START { \
+ PL_malloc_mutex = NULL; \
+ MUTEX_INIT(&PL_malloc_mutex); \
+ } STMT_END
# define MALLOC_TERM \
- STMT_START { \
- perl_mutex tmp = PL_malloc_mutex; \
- PL_malloc_mutex = NULL; \
- MUTEX_DESTROY(&tmp); \
- } STMT_END
+ STMT_START { \
+ perl_mutex tmp = PL_malloc_mutex; \
+ PL_malloc_mutex = NULL; \
+ MUTEX_DESTROY(&tmp); \
+ } STMT_END
# else
# define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex)
# define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex)
# define MALLOC_TERM
#endif
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
struct perl_memory_debug_header;
struct perl_memory_debug_header {
# define PERL_MEMORY_DEBUG_HEADER_SIZE \
(sizeof(struct perl_memory_debug_header) + \
- (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
- %MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
+ (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
+ %MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
#else
# define PERL_MEMORY_DEBUG_HEADER_SIZE 0
#ifdef PERL_TRACK_MEMPOOL
# ifdef PERL_DEBUG_READONLY_COW
# define INIT_TRACK_MEMPOOL(header, interp) \
- STMT_START { \
- (header).interpreter = (interp); \
- (header).prev = (header).next = &(header); \
- (header).readonly = 0; \
- } STMT_END
+ STMT_START { \
+ (header).interpreter = (interp); \
+ (header).prev = (header).next = &(header); \
+ (header).readonly = 0; \
+ } STMT_END
# else
# define INIT_TRACK_MEMPOOL(header, interp) \
- STMT_START { \
- (header).interpreter = (interp); \
- (header).prev = (header).next = &(header); \
- } STMT_END
+ STMT_START { \
+ (header).interpreter = (interp); \
+ (header).prev = (header).next = &(header); \
+ } STMT_END
# endif
# else
# define INIT_TRACK_MEMPOOL(header, interp)
# if defined(HAS_MALLOC_SIZE) && !defined(PERL_DEBUG_READONLY_COW)
# ifdef PERL_TRACK_MEMPOOL
# define Perl_safesysmalloc_size(where) \
- (malloc_size(((char *)(where)) - PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE)
+ (malloc_size(((char *)(where)) - PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE)
# else
# define Perl_safesysmalloc_size(where) malloc_size(where)
# endif
# ifdef HAS_MALLOC_GOOD_SIZE
# ifdef PERL_TRACK_MEMPOOL
# define Perl_malloc_good_size(how_much) \
- (malloc_good_size((how_much) + PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE)
+ (malloc_good_size((how_much) + PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE)
# else
# define Perl_malloc_good_size(how_much) malloc_good_size(how_much)
# endif
#undef PERL_PATCHLEVEL_H_IMPLICIT
#define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \
- STRINGIFY(PERL_VERSION) "." \
- STRINGIFY(PERL_SUBVERSION)
+ STRINGIFY(PERL_VERSION) "." \
+ STRINGIFY(PERL_SUBVERSION)
#define PERL_API_VERSION_STRING STRINGIFY(PERL_API_REVISION) "." \
- STRINGIFY(PERL_API_VERSION) "." \
- STRINGIFY(PERL_API_SUBVERSION)
+ STRINGIFY(PERL_API_VERSION) "." \
+ STRINGIFY(PERL_API_SUBVERSION)
START_EXTERN_C
INIT("Modification of non-creatable hash value attempted, subscript \"%" SVf "\"");
EXTCONST char PL_no_modify[]
INIT("Modification of a read-only value attempted");
-EXTCONST char PL_no_mem[sizeof("Out of memory!\n")]
- INIT("Out of memory!\n");
EXTCONST char PL_no_security[]
INIT("Insecure dependency in %s%s");
EXTCONST char PL_no_sock_func[]
EXTCONST char PL_hexdigit[]
INIT("0123456789abcdef0123456789ABCDEF");
-EXTCONST STRLEN PL_WARN_ALL
+EXT char PL_WARN_ALL
INIT(0);
-EXTCONST STRLEN PL_WARN_NONE
+EXT char PL_WARN_NONE
INIT(0);
/* This is constant on most architectures, a global on OS/2 */
#ifdef DOINIT
EXTCONST char PL_uudmap[256] =
-# ifdef PERL_MICRO
-# include "uuudmap.h"
-# else
-# include "uudmap.h"
-# endif
+# include "uudmap.h"
;
EXTCONST char PL_bitcount[256] =
-# ifdef PERL_MICRO
-# include "ubitcount.h"
-#else
-# include "bitcount.h"
-# endif
+# include "bitcount.h"
;
EXTCONST char* const PL_sig_name[] = { SIG_NAME };
EXTCONST int PL_sig_num[] = { SIG_NUM };
* ebcdic_tables.h */
EXTCONST unsigned char PL_fold[] = {
- 0, 1, 2, 3, 4, 5, 6, 7,
- 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23,
- 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55,
- 56, 57, 58, 59, 60, 61, 62, 63,
- 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
- 'x', 'y', 'z', 91, 92, 93, 94, 95,
- 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
- 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
- 128, 129, 130, 131, 132, 133, 134, 135,
- 136, 137, 138, 139, 140, 141, 142, 143,
- 144, 145, 146, 147, 148, 149, 150, 151,
- 152, 153, 154, 155, 156, 157, 158, 159,
- 160, 161, 162, 163, 164, 165, 166, 167,
- 168, 169, 170, 171, 172, 173, 174, 175,
- 176, 177, 178, 179, 180, 181, 182, 183,
- 184, 185, 186, 187, 188, 189, 190, 191,
- 192, 193, 194, 195, 196, 197, 198, 199,
- 200, 201, 202, 203, 204, 205, 206, 207,
- 208, 209, 210, 211, 212, 213, 214, 215,
- 216, 217, 218, 219, 220, 221, 222, 223,
- 224, 225, 226, 227, 228, 229, 230, 231,
- 232, 233, 234, 235, 236, 237, 238, 239,
- 240, 241, 242, 243, 244, 245, 246, 247,
- 248, 249, 250, 251, 252, 253, 254, 255
-};
-
-EXT unsigned char PL_fold_locale[] = { /* Unfortunately not EXTCONST. */
- 0, 1, 2, 3, 4, 5, 6, 7,
- 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23,
- 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55,
- 56, 57, 58, 59, 60, 61, 62, 63,
- 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
- 'x', 'y', 'z', 91, 92, 93, 94, 95,
- 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
- 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
- 128, 129, 130, 131, 132, 133, 134, 135,
- 136, 137, 138, 139, 140, 141, 142, 143,
- 144, 145, 146, 147, 148, 149, 150, 151,
- 152, 153, 154, 155, 156, 157, 158, 159,
- 160, 161, 162, 163, 164, 165, 166, 167,
- 168, 169, 170, 171, 172, 173, 174, 175,
- 176, 177, 178, 179, 180, 181, 182, 183,
- 184, 185, 186, 187, 188, 189, 190, 191,
- 192, 193, 194, 195, 196, 197, 198, 199,
- 200, 201, 202, 203, 204, 205, 206, 207,
- 208, 209, 210, 211, 212, 213, 214, 215,
- 216, 217, 218, 219, 220, 221, 222, 223,
- 224, 225, 226, 227, 228, 229, 230, 231,
- 232, 233, 234, 235, 236, 237, 238, 239,
- 240, 241, 242, 243, 244, 245, 246, 247,
- 248, 249, 250, 251, 252, 253, 254, 255
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
};
EXTCONST unsigned char PL_fold_latin1[] = {
* not one, so can't be represented in this table.
*
* All have to be specially handled */
- 0, 1, 2, 3, 4, 5, 6, 7,
- 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23,
- 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55,
- 56, 57, 58, 59, 60, 61, 62, 63,
- 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
- 'x', 'y', 'z', 91, 92, 93, 94, 95,
- 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
- 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
- 128, 129, 130, 131, 132, 133, 134, 135,
- 136, 137, 138, 139, 140, 141, 142, 143,
- 144, 145, 146, 147, 148, 149, 150, 151,
- 152, 153, 154, 155, 156, 157, 158, 159,
- 160, 161, 162, 163, 164, 165, 166, 167,
- 168, 169, 170, 171, 172, 173, 174, 175,
- 176, 177, 178, 179, 180, 181 /*micro */, 182, 183,
- 184, 185, 186, 187, 188, 189, 190, 191,
- 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32,
- 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32,
- 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215,
- 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223 /* ss */,
- 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32,
- 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32,
- 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247,
- 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32,
- 255 /* y with diaeresis */
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181 /*micro */, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32,
+ 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32,
+ 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215,
+ 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223 /* ss */,
+ 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32,
+ 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32,
+ 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247,
+ 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32,
+ 255 /* y with diaeresis */
};
/* If these tables are accessed through ebcdic, the access will be converted to
* latin1 first */
EXTCONST unsigned char PL_latin1_lc[] = { /* lowercasing */
- 0, 1, 2, 3, 4, 5, 6, 7,
- 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23,
- 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55,
- 56, 57, 58, 59, 60, 61, 62, 63,
- 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
- 'x', 'y', 'z', 91, 92, 93, 94, 95,
- 96, 97, 98, 99, 100, 101, 102, 103,
- 104, 105, 106, 107, 108, 109, 110, 111,
- 112, 113, 114, 115, 116, 117, 118, 119,
- 120, 121, 122, 123, 124, 125, 126, 127,
- 128, 129, 130, 131, 132, 133, 134, 135,
- 136, 137, 138, 139, 140, 141, 142, 143,
- 144, 145, 146, 147, 148, 149, 150, 151,
- 152, 153, 154, 155, 156, 157, 158, 159,
- 160, 161, 162, 163, 164, 165, 166, 167,
- 168, 169, 170, 171, 172, 173, 174, 175,
- 176, 177, 178, 179, 180, 181, 182, 183,
- 184, 185, 186, 187, 188, 189, 190, 191,
- 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32,
- 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32,
- 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215,
- 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223,
- 224, 225, 226, 227, 228, 229, 230, 231,
- 232, 233, 234, 235, 236, 237, 238, 239,
- 240, 241, 242, 243, 244, 245, 246, 247,
- 248, 249, 250, 251, 252, 253, 254, 255
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 97, 98, 99, 100, 101, 102, 103,
+ 104, 105, 106, 107, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32,
+ 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32,
+ 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215,
+ 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
};
/* upper and title case of latin1 characters, modified so that the three tricky
* ones are mapped to 255 (which is one of the three) */
EXTCONST unsigned char PL_mod_latin1_uc[] = {
- 0, 1, 2, 3, 4, 5, 6, 7,
- 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23,
- 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55,
- 56, 57, 58, 59, 60, 61, 62, 63,
- 64, 65, 66, 67, 68, 69, 70, 71,
- 72, 73, 74, 75, 76, 77, 78, 79,
- 80, 81, 82, 83, 84, 85, 86, 87,
- 88, 89, 90, 91, 92, 93, 94, 95,
- 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
- 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
- 128, 129, 130, 131, 132, 133, 134, 135,
- 136, 137, 138, 139, 140, 141, 142, 143,
- 144, 145, 146, 147, 148, 149, 150, 151,
- 152, 153, 154, 155, 156, 157, 158, 159,
- 160, 161, 162, 163, 164, 165, 166, 167,
- 168, 169, 170, 171, 172, 173, 174, 175,
- 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183,
- 184, 185, 186, 187, 188, 189, 190, 191,
- 192, 193, 194, 195, 196, 197, 198, 199,
- 200, 201, 202, 203, 204, 205, 206, 207,
- 208, 209, 210, 211, 212, 213, 214, 215,
- 216, 217, 218, 219, 220, 221, 222,
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 65, 66, 67, 68, 69, 70, 71,
+ 72, 73, 74, 75, 76, 77, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87,
+ 88, 89, 90, 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222,
# if UNICODE_MAJOR_VERSION > 2 \
|| (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
&& UNICODE_DOT_DOT_VERSION >= 8)
- 255 /*sharp s*/,
+ 255 /*sharp s*/,
# else /* uc(sharp s) is 'sharp s' itself in early unicode */
- 223,
+ 223,
# endif
- 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32,
- 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32,
- 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247,
- 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255
+ 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32,
+ 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32,
+ 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247,
+ 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255
};
# endif /* !EBCDIC, but still in DOINIT */
#else /* ! DOINIT */
EXTCONST unsigned char PL_fold_latin1[];
EXTCONST unsigned char PL_mod_latin1_uc[];
EXTCONST unsigned char PL_latin1_lc[];
-EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */
# endif
#endif
* which has DEBUGGING enabled always */
#ifdef DOINIT
EXTCONST char* const PL_block_type[] = {
- "NULL",
- "WHEN",
- "BLOCK",
- "GIVEN",
- "LOOP_ARY",
- "LOOP_LAZYSV",
- "LOOP_LAZYIV",
- "LOOP_LIST",
- "LOOP_PLAIN",
- "SUB",
- "FORMAT",
- "EVAL",
- "SUBST"
+ "NULL",
+ "WHEN",
+ "BLOCK",
+ "GIVEN",
+ "LOOP_ARY",
+ "LOOP_LAZYSV",
+ "LOOP_LAZYIV",
+ "LOOP_LIST",
+ "LOOP_PLAIN",
+ "SUB",
+ "FORMAT",
+ "EVAL",
+ "SUBST",
+ "DEFER"
};
#else
EXTCONST char* PL_block_type[];
#ifdef DOINIT
EXTCONST char PL_bincompat_options[] =
# ifdef DEBUG_LEAKING_SCALARS
- " DEBUG_LEAKING_SCALARS"
+ " DEBUG_LEAKING_SCALARS"
# endif
# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
- " DEBUG_LEAKING_SCALARS_FORK_DUMP"
+ " DEBUG_LEAKING_SCALARS_FORK_DUMP"
# endif
# ifdef HAS_TIMES
- " HAS_TIMES"
+ " HAS_TIMES"
# endif
# ifdef HAVE_INTERP_INTERN
- " HAVE_INTERP_INTERN"
+ " HAVE_INTERP_INTERN"
# endif
# ifdef MULTIPLICITY
- " MULTIPLICITY"
+ " MULTIPLICITY"
# endif
# ifdef MYMALLOC
- " MYMALLOC"
+ " MYMALLOC"
+# endif
+# ifdef NO_HASH_SEED
+ " NO_HASH_SEED"
# endif
# ifdef PERLIO_LAYERS
- " PERLIO_LAYERS"
+ " PERLIO_LAYERS"
# endif
# ifdef PERL_DEBUG_READONLY_COW
- " PERL_DEBUG_READONLY_COW"
+ " PERL_DEBUG_READONLY_COW"
# endif
# ifdef PERL_DEBUG_READONLY_OPS
- " PERL_DEBUG_READONLY_OPS"
+ " PERL_DEBUG_READONLY_OPS"
# endif
-# ifdef PERL_IMPLICIT_CONTEXT
- " PERL_IMPLICIT_CONTEXT"
+# ifdef PERL_HASH_FUNC_DEFINE
+/* note that this is different from the others, PERL_HASH_FUNC_DEFINE
+ * is a string which says which define was defined. */
+ " " PERL_HASH_FUNC_DEFINE
# endif
-# ifdef PERL_IMPLICIT_SYS
- " PERL_IMPLICIT_SYS"
+# ifdef PERL_HASH_USE_SBOX32
+ " PERL_HASH_USE_SBOX32"
+# else
+ " PERL_HASH_NO_SBOX32"
# endif
-# ifdef PERL_MICRO
- " PERL_MICRO"
+# ifdef PERL_IMPLICIT_SYS
+ " PERL_IMPLICIT_SYS"
# endif
# ifdef PERL_POISON
- " PERL_POISON"
+ " PERL_POISON"
# endif
# ifdef PERL_SAWAMPERSAND
- " PERL_SAWAMPERSAND"
+ " PERL_SAWAMPERSAND"
# endif
# ifdef PERL_TRACK_MEMPOOL
- " PERL_TRACK_MEMPOOL"
+ " PERL_TRACK_MEMPOOL"
# endif
# ifdef PERL_USES_PL_PIDSTATUS
- " PERL_USES_PL_PIDSTATUS"
+ " PERL_USES_PL_PIDSTATUS"
# endif
# ifdef USE_64_BIT_ALL
- " USE_64_BIT_ALL"
+ " USE_64_BIT_ALL"
# endif
# ifdef USE_64_BIT_INT
- " USE_64_BIT_INT"
+ " USE_64_BIT_INT"
# endif
# ifdef USE_IEEE
- " USE_IEEE"
+ " USE_IEEE"
# endif
# ifdef USE_ITHREADS
- " USE_ITHREADS"
+ " USE_ITHREADS"
# endif
# ifdef USE_LARGE_FILES
- " USE_LARGE_FILES"
+ " USE_LARGE_FILES"
# endif
# ifdef USE_LOCALE_COLLATE
- " USE_LOCALE_COLLATE"
+ " USE_LOCALE_COLLATE"
# endif
# ifdef USE_LOCALE_NUMERIC
- " USE_LOCALE_NUMERIC"
+ " USE_LOCALE_NUMERIC"
# endif
# ifdef USE_LOCALE_TIME
- " USE_LOCALE_TIME"
+ " USE_LOCALE_TIME"
# endif
# ifdef USE_LONG_DOUBLE
- " USE_LONG_DOUBLE"
+ " USE_LONG_DOUBLE"
# endif
# ifdef USE_PERLIO
- " USE_PERLIO"
+ " USE_PERLIO"
# endif
# ifdef USE_QUADMATH
- " USE_QUADMATH"
+ " USE_QUADMATH"
# endif
# ifdef USE_REENTRANT_API
- " USE_REENTRANT_API"
+ " USE_REENTRANT_API"
# endif
# ifdef USE_SOCKS
- " USE_SOCKS"
+ " USE_SOCKS"
# endif
# ifdef VMS_DO_SOCKETS
- " VMS_DO_SOCKETS"
+ " VMS_DO_SOCKETS"
# endif
# ifdef VMS_SHORTEN_LONG_SYMBOLS
- " VMS_SHORTEN_LONG_SYMBOLS"
+ " VMS_SHORTEN_LONG_SYMBOLS"
# endif
# ifdef VMS_WE_ARE_CASE_SENSITIVE
- " VMS_SYMBOL_CASE_AS_IS"
+ " VMS_SYMBOL_CASE_AS_IS"
# endif
- "";
+ ""; /* keep this on a line by itself, WITH the empty string */
#else
EXTCONST char PL_bincompat_options[];
#endif
EXTCONST char *const PL_phase_names[];
#endif
+/*
+=for apidoc_section $utility
+
+=for apidoc phase_name
+
+Returns the given phase's name as a NUL-terminated string.
+
+For example, to print a stack trace that includes the current
+interpreter phase you might do:
+
+ const char* phase_name = phase_name(PL_phase);
+ mess("This is weird. (Perl phase: %s)", phase_name);
+
+=cut
+*/
+
+#define phase_name(phase) (PL_phase_names[phase])
+
#ifndef PERL_CORE
/* Do not use this macro. It only exists for extensions that rely on PL_dirty
* instead of using the newer PL_phase, which provides everything PL_dirty
#define KEY_sigvar 0xFFFF /* fake keyword representing a signature var */
/* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer
- special and there is no need for HINT_PRIVATE_MASK for COPs
- However, bitops store HINT_INTEGER in their op_private.
+ special and there is no need for HINT_PRIVATE_MASK for COPs.
NOTE: The typical module using these has the bit value hard-coded, so don't
blindly change the values of these.
#define HINT_FEATURE_MASK 0x3c000000 /* 4 bits for feature bundles */
- /* Note: Used for HINT_M_VMSISH_*,
- currently defined by vms/vmsish.h:
- 0x40000000
- 0x80000000
- */
-
-/* The following are stored in $^H{sort}, not in PL_hints */
-#define HINT_SORT_STABLE 0x00000100 /* sort styles */
-#define HINT_SORT_UNSTABLE 0x00000200
+ /* Note: Used for HINT_M_VMSISH_*,
+ currently defined by vms/vmsish.h:
+ 0x40000000
+ 0x80000000
+ */
#define HINT_ALL_STRICT HINT_STRICT_REFS \
| HINT_STRICT_SUBS \
#ifndef PERL_SAWAMPERSAND
# define PL_sawampersand \
- (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT)
+ (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT)
#endif
/* Used for debugvar magic */
#define PERL_DEBUG_PAD(i) &(PL_debug_pad.pad[i])
#define PERL_DEBUG_PAD_ZERO(i) (SvPVX(PERL_DEBUG_PAD(i))[0] = 0, \
- (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \
- PERL_DEBUG_PAD(i))
+ (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \
+ PERL_DEBUG_PAD(i))
/* Enable variables which are pointers to functions */
typedef void (*peep_t)(pTHX_ OP* o);
typedef regexp* (*regcomp_t) (pTHX_ char* exp, char* xend, PMOP* pm);
typedef I32 (*regexec_t) (pTHX_ regexp* prog, char* stringarg,
- char* strend, char* strbeg, I32 minend,
- SV* screamer, void* data, U32 flags);
+ char* strend, char* strbeg, I32 minend,
+ SV* screamer, void* data, U32 flags);
typedef char* (*re_intuit_start_t) (pTHX_ regexp *prog, SV *sv,
- char *strpos, char *strend,
- U32 flags,
- re_scream_pos_data *d);
+ char *strpos, char *strend,
+ U32 flags,
+ re_scream_pos_data *d);
typedef SV* (*re_intuit_string_t) (pTHX_ regexp *prog);
typedef void (*regfree_t) (pTHX_ struct regexp* r);
typedef regexp* (*regdupe_t) (pTHX_ const regexp* r, CLONE_PARAMS *param);
-typedef I32 (*re_fold_t)(const char *, char const *, I32);
+typedef I32 (*re_fold_t)(pTHX_ const char *, char const *, I32);
typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*);
typedef void (*DESTRUCTORFUNC_t) (pTHX_ void*);
typedef void (*ATEXIT_t) (pTHX_ void*);
typedef void (*XSUBADDR_t) (pTHX_ CV *);
+enum Perl_custom_infix_precedence {
+ /* These numbers are spaced out to give room to insert new values as
+ * required. They form part of the ABI contract with XS::Parse::Infix so
+ * they should not be changed within a stable release cycle, but they can
+ * be freely altered during a development cycle because no ABI guarantees
+ * are made at that time */
+ INFIX_PREC_LOW = 10, /* non-associative */
+ INFIX_PREC_LOGICAL_OR_LOW = 30, /* left-associative, as `or` */
+ INFIX_PREC_LOGICAL_AND_LOW = 40, /* left-associative, as `and` */
+ INFIX_PREC_ASSIGN = 50, /* right-associative, as `=` */
+ INFIX_PREC_LOGICAL_OR = 70, /* left-associative, as `||` */
+ INFIX_PREC_LOGICAL_AND = 80, /* left-associative, as `&&` */
+ INFIX_PREC_REL = 90, /* non-associative, just below `==` */
+ INFIX_PREC_ADD = 110, /* left-associative, as `+` */
+ INFIX_PREC_MUL = 130, /* left-associative, as `*` */
+ INFIX_PREC_POW = 150, /* right-associative, as `**` */
+ INFIX_PREC_HIGH = 170, /* non-associative */
+ /* Try to keep within the range of a U8 in case we need to split the field
+ * and add flags */
+};
+struct Perl_custom_infix;
+struct Perl_custom_infix {
+ enum Perl_custom_infix_precedence prec;
+ void (*parse)(pTHX_ SV **opdata, struct Perl_custom_infix *); /* optional */
+ OP *(*build_op)(pTHX_ SV **opdata, OP *lhs, OP *rhs, struct Perl_custom_infix *);
+};
+
typedef OP* (*Perl_ppaddr_t)(pTHX);
typedef OP* (*Perl_check_t) (pTHX_ OP*);
typedef void(*Perl_ophook_t)(pTHX_ OP*);
typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**);
+typedef STRLEN (*Perl_infix_plugin_t)(pTHX_ char*, STRLEN, struct Perl_custom_infix **);
typedef void(*Perl_cpeep_t)(pTHX_ OP *, OP *);
typedef void(*globhook_t)(pTHX);
#ifdef DOINIT
EXTCONST U8 PL_magic_data[256] =
-# ifdef PERL_MICRO
-# include "umg_data.h"
-# else
-# include "mg_data.h"
-# endif
+# include "mg_data.h"
;
#else
EXTCONST U8 PL_magic_data[256];
#endif
#ifdef DOINIT
- /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO */
+ /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO OBJ */
EXTCONST bool
-PL_valid_types_IVX[] = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
+PL_valid_types_IVX[] = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0 };
EXTCONST bool
-PL_valid_types_NVX[] = { 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
+PL_valid_types_NVX[] = { 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0 };
EXTCONST bool
-PL_valid_types_PVX[] = { 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1 };
+PL_valid_types_PVX[] = { 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0 };
EXTCONST bool
-PL_valid_types_RV[] = { 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1 };
+PL_valid_types_RV[] = { 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1, 0 };
EXTCONST bool
-PL_valid_types_IV_set[] = { 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1 };
+PL_valid_types_IV_set[] = { 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0 };
EXTCONST bool
-PL_valid_types_NV_set[] = { 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 };
+PL_valid_types_NV_set[] = { 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0 };
+
+EXTCONST U8
+PL_deBruijn_bitpos_tab32[] = {
+ /* https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn */
+ 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
+ 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
+};
+
+EXTCONST U8
+PL_deBruijn_bitpos_tab64[] = {
+ /* https://stackoverflow.com/questions/11376288/fast-computing-of-log2-for-64-bit-integers */
+ 63, 0, 58, 1, 59, 47, 53, 2, 60, 39, 48, 27, 54, 33, 42, 3,
+ 61, 51, 37, 40, 49, 18, 28, 20, 55, 30, 34, 11, 43, 14, 22, 4,
+ 62, 57, 46, 52, 38, 26, 32, 41, 50, 36, 17, 19, 29, 10, 13, 21,
+ 56, 45, 25, 31, 35, 16, 9, 12, 44, 24, 15, 8, 23, 7, 6, 5
+};
#else
EXTCONST bool PL_valid_types_RV[];
EXTCONST bool PL_valid_types_IV_set[];
EXTCONST bool PL_valid_types_NV_set[];
+EXTCONST U8 PL_deBruijn_bitpos_tab32[];
+EXTCONST U8 PL_deBruijn_bitpos_tab64[];
#endif
+/* The constants for using PL_deBruijn_bitpos_tab */
+#define PERL_deBruijnMagic32_ 0x077CB531
+#define PERL_deBruijnShift32_ 27
+#define PERL_deBruijnMagic64_ 0x07EDD5E59A4E28C2
+#define PERL_deBruijnShift64_ 58
+
/* In C99 we could use designated (named field) union initializers.
* In C89 we need to initialize the member declared first.
* In C++ we need extern C initializers.
# define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i)
#endif
+#ifdef USE_PERL_SWITCH_LOCALE_CONTEXT
+# define PERL_SET_LOCALE_CONTEXT(i) \
+ STMT_START { \
+ if (LIKELY(! PL_veto_switch_non_tTHX_context)) \
+ Perl_switch_locale_context(i); \
+ } STMT_END
+
+ /* In some Configurations there may be per-thread information that is
+ * carried in a library instead of perl's tTHX structure. This macro is to
+ * be used to handle those when tTHX is changed. Only locale handling is
+ * currently known to be affected. */
+# define PERL_SET_NON_tTHX_CONTEXT(i) \
+ STMT_START { if (i) PERL_SET_LOCALE_CONTEXT(i); } STMT_END
+#else
+# define PERL_SET_LOCALE_CONTEXT(i) NOOP
+# define PERL_SET_NON_tTHX_CONTEXT(i) NOOP
+#endif
+
#ifndef PERL_GET_CONTEXT
# define PERL_GET_CONTEXT PERL_GET_INTERP
#endif
/* This is a version of the above table customized for Perl that doesn't
* exclude surrogates and accepts start bytes up through FD (FE on 64-bit
* machines). The classes have been renumbered so that the patterns are more
- * evident in the table. The class numbers for start bytes are constrained so
- * that they can be used as a shift count for masking off the leading one bits.
+ * evident in the table. The class numbers are structured so the values are:
+ *
+ * a) UTF-8 invariant code points
+ * 0
+ * b) Start bytes that always lead to either overlongs or some class of code
+ * point that needs outside intervention for handling (such as to raise a
+ * warning)
+ * 1
+ * c) Start bytes that never lead to one of the above
+ * number of bytes in complete sequence
+ * d) Rest of start bytes (they can be resolved through this algorithm) and
+ * continuation bytes
+ * arbitrary class number chosen to not conflict with the above
+ * classes, and to index into the remaining table
+ *
* It would make the code simpler if start byte FF could also be handled, but
- * doing so would mean adding nodes for each of continuation bytes 6-12
- * remaining, and two more nodes for overlong detection (a total of 9), and
- * there is room only for 4 more nodes unless we make the array U16 instead of
- * U8.
+ * doing so would mean adding two more classes (one from splitting 80 from 81,
+ * and one for FF), and nodes for each of 6 new continuation bytes. The
+ * current table has 436 entries; the new one would require 140 more = 576 (2
+ * additional classes for each of the 10 existing nodes, and 20 for each of 6
+ * new nodes. The array would have to be made U16 instead of U8, not worth it
+ * for this rarely encountered case
*
* The classes are
- * 00-7F 0
+ * 00-7F 0 Always legal, single byte sequence
* 80-81 7 Not legal immediately after start bytes E0 F0 F8 FC
* FE
* 82-83 8 Not legal immediately after start bytes E0 F0 F8 FC
* 84-87 9 Not legal immediately after start bytes E0 F0 F8
* 88-8F 10 Not legal immediately after start bytes E0 F0
* 90-9F 11 Not legal immediately after start byte E0
- * A0-BF 12
- * C0,C1 1
- * C2-DF 2
- * E0 13
- * E1-EF 3
- * F0 14
- * F1-F7 4
- * F8 15
- * F9-FB 5
- * FC 16
- * FD 6
- * FE 17 (or 1 on 32-bit machines, since it overflows)
- * FF 1
+ * A0-BF 12 Always legal continuation byte
+ * C0,C1 1 Not legal: overlong
+ * C2-DF 2 Legal start byte for two byte sequences
+ * E0 13 Some sequences are overlong; others legal
+ * E1-EF 3 Legal start byte for three byte sequences
+ * F0 14 Some sequences are overlong; others legal
+ * F1-F7 4 Legal start byte for four byte sequences
+ * F8 15 Some sequences are overlong; others legal
+ * F9-FB 5 Legal start byte for five byte sequences
+ * FC 16 Some sequences are overlong; others legal
+ * FD 6 Legal start byte for six byte sequences
+ * FE 17 Some sequences are overlong; others legal
+ * (is 1 on 32-bit machines, since it overflows)
+ * FF 1 Need to handle specially
*/
EXTCONST U8 PL_extended_utf8_dfa_tab[] = {
* N10 Start byte is FE. Continuation bytes 80-81 are illegal (overlong);
* the other continuations transition to N5
* 1 Reject. All transitions not mentioned above (except the single
- * byte ones (as they are always legal) are to this state.
+ * byte ones (as they are always legal)) are to this state.
*/
# if defined(PERL_CORE)
# endif
#endif /* end of isn't EBCDIC */
-#ifndef PERL_NO_INLINE_FUNCTIONS
-/* Static inline funcs that depend on includes and declarations above.
- Some of these reference functions in the perl object files, and some
- compilers aren't smart enough to eliminate unused static inline
- functions, so including this file in source code can cause link errors
- even if the source code uses none of the functions. Hence including these
- can be suppressed by setting PERL_NO_INLINE_FUNCTIONS. Doing this will
- (obviously) result in unworkable XS code, but allows simple probing code
- to continue to work, because it permits tests to include the perl headers
- for definitions without creating a link dependency on the perl library
- (which may not exist yet).
-*/
-
-# include "inline.h"
-#endif
-
#include "overload.h"
END_EXTERN_C
#endif /* _FASTMATH */
#define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \
- PERLDBf_NOOPT | PERLDBf_INTER | \
- PERLDBf_SUBLINE| PERLDBf_SINGLE| \
- PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \
- PERLDBf_SAVESRC)
- /* No _NONAME, _GOTO */
+ PERLDBf_NOOPT | PERLDBf_INTER | \
+ PERLDBf_SUBLINE| PERLDBf_SINGLE| \
+ PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \
+ PERLDBf_SAVESRC)
+ /* No _NONAME, _GOTO */
#define PERLDBf_SUB 0x01 /* Debug sub enter/exit */
#define PERLDBf_LINE 0x02 /* Keep line # */
#define PERLDBf_NOOPT 0x04 /* Switch off optimizations */
#define PERLDBf_INTER 0x08 /* Preserve more data for
- later inspections */
+ later inspections */
#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */
#define PERLDBf_SINGLE 0x20 /* Start with single-step on */
#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */
#define PERLDB_LINE_OR_SAVESRC (PL_perldb & (PERLDBf_LINE | PERLDBf_SAVESRC))
-#ifdef USE_ITHREADS
+#ifdef USE_THREADS
# define KEYWORD_PLUGIN_MUTEX_INIT MUTEX_INIT(&PL_keyword_plugin_mutex)
# define KEYWORD_PLUGIN_MUTEX_LOCK MUTEX_LOCK(&PL_keyword_plugin_mutex)
# define KEYWORD_PLUGIN_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_keyword_plugin_mutex)
* instead it makes sense to minimize space used and do all the work in
* the rarely called function */
# ifdef USE_LOCALE_CTYPE
-# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE \
+# define CHECK_AND_WARN_PROBLEMATIC_LOCALE_ \
STMT_START { \
if (UNLIKELY(PL_warn_locale)) { \
- Perl__warn_problematic_locale(); \
+ Perl_warn_problematic_locale(); \
} \
} STMT_END
# else
-# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE
+# define CHECK_AND_WARN_PROBLEMATIC_LOCALE_
# endif
* argument; the 2nd, is a pointer to the first byte of the UTF-8 encoded
* string, and an end position which it won't try to read past */
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(cp) \
- STMT_START { \
- if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
+ STMT_START { \
+ if (! IN_UTF8_CTYPE_LOCALE && ckWARN(WARN_LOCALE)) { \
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
"Wide character (U+%" UVXf ") in %s",\
(UV) cp, OP_DESC(PL_op)); \
} STMT_END
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
- STMT_START { /* Check if to warn before doing the conversion work */\
- if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
+ STMT_START { /* Check if to warn before doing the conversion work */\
+ if (! IN_UTF8_CTYPE_LOCALE && ckWARN(WARN_LOCALE)) { \
UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
"Wide character (U+%" UVXf ") in %s", \
# define IN_LC_COMPILETIME(category) 0
# define IN_LC_RUNTIME(category) 0
# define IN_LC(category) 0
-# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE
+# define CHECK_AND_WARN_PROBLEMATIC_LOCALE_
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send)
# define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(c)
#endif
+#define locale_panic_via_(m, f, l) Perl_locale_panic((m), __LINE__, f, l)
+#define locale_panic_(m) locale_panic_via_((m), __FILE__, __LINE__)
-/* Locale/thread synchronization macros. These aren't needed if using
- * thread-safe locale operations, except if something is broken */
-#if defined(USE_LOCALE) \
- && defined(USE_ITHREADS) \
- && (! defined(USE_THREAD_SAFE_LOCALE) || defined(TS_W32_BROKEN_LOCALECONV))
-
-/* We have a locale object holding the 'C' locale for Posix 2008 */
-# ifndef USE_POSIX_2008_LOCALE
-# define _LOCALE_TERM_POSIX_2008 NOOP
-# else
-# define _LOCALE_TERM_POSIX_2008 \
- STMT_START { \
- if (PL_C_locale_obj) { \
- /* Make sure we aren't using the locale \
- * space we are about to free */ \
- uselocale(LC_GLOBAL_LOCALE); \
- freelocale(PL_C_locale_obj); \
- PL_C_locale_obj = (locale_t) NULL; \
- } \
- } STMT_END
-# endif
-
-/* This is used as a generic lock for locale operations. For example this is
- * used when calling nl_langinfo() so that another thread won't zap the
- * contents of its buffer before it gets saved; and it's called when changing
- * the locale of LC_MESSAGES. On some systems the latter can cause the
- * nl_langinfo buffer to be zapped under a race condition.
- *
- * If combined with LC_NUMERIC_LOCK, calls to this and its corresponding unlock
- * should be contained entirely within the locked portion of LC_NUMERIC. This
- * mutex should be used only in very short sections of code, while
- * LC_NUMERIC_LOCK may span more operations. By always following this
- * convention, deadlock should be impossible. But if necessary, the two
- * mutexes could be combined.
- *
- * Actually, the two macros just below with the '_V' suffixes are used in just
- * a few places where there is a broken localeconv(), but otherwise things are
- * thread safe, and hence don't need locking. Just below LOCALE_LOCK and
- * LOCALE_UNLOCK are defined in terms of these for use everywhere else */
-# define LOCALE_LOCK_V \
- STMT_START { \
- DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: locking locale\n", __FILE__, __LINE__)); \
- MUTEX_LOCK(&PL_locale_mutex); \
- } STMT_END
-# define LOCALE_UNLOCK_V \
- STMT_START { \
- DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: unlocking locale\n", __FILE__, __LINE__)); \
- MUTEX_UNLOCK(&PL_locale_mutex); \
- } STMT_END
-
-/* On windows, we just need the mutex for LOCALE_LOCK */
-# ifdef TS_W32_BROKEN_LOCALECONV
-# define LOCALE_LOCK NOOP
-# define LOCALE_UNLOCK NOOP
-# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex);
-# define LOCALE_TERM MUTEX_DESTROY(&PL_locale_mutex)
-# define LC_NUMERIC_LOCK(cond)
-# define LC_NUMERIC_UNLOCK
-# else
-# define LOCALE_LOCK LOCALE_LOCK_V
-# define LOCALE_UNLOCK LOCALE_UNLOCK_V
-
- /* We also need to lock LC_NUMERIC for non-windows (hence Posix 2008)
- * systems */
-# define LOCALE_INIT STMT_START { \
- MUTEX_INIT(&PL_locale_mutex); \
- MUTEX_INIT(&PL_lc_numeric_mutex); \
- } STMT_END
+/* Locale/thread synchronization macros. */
+#if ! defined(USE_LOCALE_THREADS)
+# define LOCALE_LOCK_(cond) NOOP
+# define LOCALE_UNLOCK_ NOOP
+# define LOCALE_INIT
+# define LOCALE_TERM
-# define LOCALE_TERM STMT_START { \
- MUTEX_DESTROY(&PL_locale_mutex); \
- MUTEX_DESTROY(&PL_lc_numeric_mutex); \
- _LOCALE_TERM_POSIX_2008; \
- } STMT_END
+#else /* Below: Threaded, and locales are supported */
- /* This mutex is used to create critical sections where we want the
- * LC_NUMERIC locale to be locked into either the C (standard) locale, or
- * the underlying locale, so that other threads interrupting this one don't
- * change it to the wrong state before we've had a chance to complete our
- * operation. It can stay locked over an entire printf operation, for
- * example. And so is made distinct from the LOCALE_LOCK mutex.
+ /* A locale mutex is required on all such threaded builds.
*
- * This simulates kind of a general semaphore. The current thread will
- * lock the mutex if the per-thread variable is zero, and then increments
- * that variable. Each corresponding UNLOCK decrements the variable until
- * it is 0, at which point it actually unlocks the mutex. Since the
- * variable is per-thread, there is no race with other threads.
+ * This mutex simulates a general (or recursive) semaphore. The current
+ * thread will lock the mutex if the per-thread variable is zero, and then
+ * increments that variable. Each corresponding UNLOCK decrements the
+ * variable until it is 0, at which point it actually unlocks the mutex.
+ * Since the variable is per-thread, initialized to 0, there is no race
+ * with other threads.
*
- * The single argument is a condition to test for, and if true, to panic,
- * as this would be an attempt to complement the LC_NUMERIC state, and
- * we're not supposed to because it's locked.
+ * The single argument is a condition to test for, and if true, to panic.
+ * Call it with the constant 0 to suppress the check.
*
* Clang improperly gives warnings for this, if not silenced:
* https://clang.llvm.org/docs/ThreadSafetyAnalysis.html#conditional-locks
- * */
-# define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \
- CLANG_DIAG_IGNORE(-Wthread-safety) \
+ */
+# define LOCALE_LOCK_(cond_to_panic_if_already_locked) \
STMT_START { \
- if (PL_lc_numeric_mutex_depth <= 0) { \
- MUTEX_LOCK(&PL_lc_numeric_mutex); \
- PL_lc_numeric_mutex_depth = 1; \
- DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: locking lc_numeric; depth=1\n", \
+ CLANG_DIAG_IGNORE(-Wthread-safety) \
+ if (LIKELY(PL_locale_mutex_depth <= 0)) { \
+ UNLESS_PERL_MEM_LOG(DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: locking locale; lock depth=1\n", \
__FILE__, __LINE__)); \
+ ) \
+ MUTEX_LOCK(&PL_locale_mutex); \
+ PL_locale_mutex_depth = 1; \
+ UNLESS_PERL_MEM_LOG(DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: locale locked; lock depth=1\n", \
+ __FILE__, __LINE__)); \
+ ) \
} \
else { \
- PL_lc_numeric_mutex_depth++; \
- DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: avoided lc_numeric_lock; new depth=%d\n", \
- __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \
+ PL_locale_mutex_depth++; \
+ UNLESS_PERL_MEM_LOG(DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: avoided locking locale; new lock" \
+ " depth=%d, but will panic if '%s' is true\n", \
+ __FILE__, __LINE__, PL_locale_mutex_depth, \
+ STRINGIFY(cond_to_panic_if_already_locked))); \
+ ) \
if (cond_to_panic_if_already_locked) { \
- Perl_croak_nocontext("panic: %s: %d: Trying to change" \
- " LC_NUMERIC incompatibly", \
- __FILE__, __LINE__); \
+ locale_panic_("Trying to lock locale incompatibly: " \
+ STRINGIFY(cond_to_panic_if_already_locked)); \
} \
} \
+ CLANG_DIAG_RESTORE \
} STMT_END
-# define LC_NUMERIC_UNLOCK \
+# define LOCALE_UNLOCK_ \
STMT_START { \
- if (PL_lc_numeric_mutex_depth <= 1) { \
- MUTEX_UNLOCK(&PL_lc_numeric_mutex); \
- PL_lc_numeric_mutex_depth = 0; \
- DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: unlocking lc_numeric; depth=0\n", \
+ if (LIKELY(PL_locale_mutex_depth == 1)) { \
+ UNLESS_PERL_MEM_LOG(DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: unlocking locale; new lock depth=0\n", \
__FILE__, __LINE__)); \
+ ) \
+ PL_locale_mutex_depth = 0; \
+ MUTEX_UNLOCK(&PL_locale_mutex); \
+ } \
+ else if (PL_locale_mutex_depth <= 0) { \
+ Perl_croak_nocontext("panic: %s: %d: attempting to unlock" \
+ " already unlocked locale; depth was" \
+ " %d\n", __FILE__, __LINE__, \
+ PL_locale_mutex_depth); \
} \
else { \
- PL_lc_numeric_mutex_depth--; \
- DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: avoided lc_numeric_unlock; new depth=%d\n",\
- __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \
+ PL_locale_mutex_depth--; \
+ UNLESS_PERL_MEM_LOG(DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: avoided unlocking locale; new lock depth=%d\n",\
+ __FILE__, __LINE__, PL_locale_mutex_depth)); \
+ ) \
} \
- } STMT_END \
- CLANG_DIAG_RESTORE
+ } STMT_END
-# endif /* End of needs locking LC_NUMERIC */
-#else /* Below is no locale sync needed */
-# define LOCALE_INIT
-# define LOCALE_LOCK
-# define LOCALE_LOCK_V
-# define LOCALE_UNLOCK
-# define LOCALE_UNLOCK_V
-# define LC_NUMERIC_LOCK(cond)
-# define LC_NUMERIC_UNLOCK
-# define LOCALE_TERM
+# if defined(USE_THREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
+
+ /* By definition, a thread-unsafe locale means we need a critical
+ * section. */
+# define LOCALE_LOCK LOCALE_LOCK_(0)
+# define LOCALE_UNLOCK LOCALE_UNLOCK_
+# ifdef USE_LOCALE_NUMERIC
+# define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \
+ LOCALE_LOCK_(cond_to_panic_if_already_locked)
+# define LC_NUMERIC_UNLOCK LOCALE_UNLOCK_
+# endif
+# endif
+
+# ifdef WIN32_USE_FAKE_OLD_MINGW_LOCALES
+ /* This function is coerced by this Configure option into cleaning up
+ * memory that is static to locale.c. So we call it at termination. Doing
+ * it this way is kludgy but confines having to deal with this
+ * Configuration to a bare minimum number of places. */
+# define LOCALE_TERM_POSIX_2008_ Perl_thread_locale_term(NULL)
+# elif ! defined(USE_POSIX_2008_LOCALE)
+# define LOCALE_TERM_POSIX_2008_ NOOP
+# else
+ /* We have a locale object holding the 'C' locale for Posix 2008 */
+# define LOCALE_TERM_POSIX_2008_ \
+ STMT_START { \
+ if (PL_C_locale_obj) { \
+ /* Make sure we aren't using the locale \
+ * space we are about to free */ \
+ uselocale(LC_GLOBAL_LOCALE); \
+ freelocale(PL_C_locale_obj); \
+ PL_C_locale_obj = (locale_t) NULL; \
+ } \
+ } STMT_END
+# endif
+
+# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex)
+# define LOCALE_TERM STMT_START { \
+ LOCALE_TERM_POSIX_2008_; \
+ MUTEX_DESTROY(&PL_locale_mutex); \
+ } STMT_END
+#endif
+
+/* There are some locale-related functions which may need locking only because
+ * they share some common memory across threads, and hence there is the
+ * potential for a race in accessing that space. Most are because their return
+ * points to a global static buffer, but some just use some common space
+ * internally. All functions accessing a given space need to have a critical
+ * section to prevent any other thread from accessing it at the same time.
+ * Ideally, there would be a separate mutex for each such space, so that
+ * another thread isn't unnecessarily blocked. But, most of them need to be
+ * locked against the locale changing while accessing that space, and it is not
+ * expected that any will be called frequently, and the locked interval should
+ * be short, and modern platforms will have reentrant versions (which don't
+ * lock) for almost all of them, so khw thinks a single mutex should suffice.
+ * Having a single mutex facilitates that, avoiding potential deadlock
+ * situations.
+ *
+ * This will be a no-op iff the perl is unthreaded. 'gw' stands for 'global
+ * write', to indicate the caller wants to be able to access memory that isn't
+ * thread specific, either to write to itself, or to prevent anyone else from
+ * writing. */
+#define gwLOCALE_LOCK LOCALE_LOCK_(0)
+#define gwLOCALE_UNLOCK LOCALE_UNLOCK_
+
+/* setlocale() generally returns in a global static buffer, but not on Windows
+ * when operating in thread-safe mode */
+#if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE)
+# define POSIX_SETLOCALE_LOCK \
+ STMT_START { \
+ if (_configthreadlocale(0) == _DISABLE_PER_THREAD_LOCALE) \
+ gwLOCALE_LOCK; \
+ } STMT_END
+# define POSIX_SETLOCALE_UNLOCK \
+ STMT_START { \
+ if (_configthreadlocale(0) == _DISABLE_PER_THREAD_LOCALE) \
+ gwLOCALE_UNLOCK; \
+ } STMT_END
+#else
+# define POSIX_SETLOCALE_LOCK gwLOCALE_LOCK
+# define POSIX_SETLOCALE_UNLOCK gwLOCALE_UNLOCK
+#endif
+
+/* It handles _wsetlocale() as well */
+#define WSETLOCALE_LOCK POSIX_SETLOCALE_LOCK
+#define WSETLOCALE_UNLOCK POSIX_SETLOCALE_UNLOCK
+
+/* Similar to gwLOCALE_LOCK, there are functions that require both the locale
+ * and environment to be constant during their execution, and don't change
+ * either of those things, but do write to some sort of shared global space.
+ * They require some sort of exclusive lock against similar functions, and a
+ * read lock on both the locale and environment. However, on systems which
+ * have per-thread locales, the locale is constant during the execution of
+ * these functions, and so no locale lock is necssary. For such systems, an
+ * exclusive ENV lock is necessary and sufficient. On systems where the locale
+ * could change out from under us, we use an exclusive LOCALE lock to prevent
+ * that, and a read ENV lock to prevent other threads that have nothing to do
+ * with locales here from changing the environment. */
+#ifdef LOCALE_LOCK
+# define gwENVr_LOCALEr_LOCK \
+ STMT_START { LOCALE_LOCK; ENV_READ_LOCK; } STMT_END
+# define gwENVr_LOCALEr_UNLOCK \
+ STMT_START { ENV_READ_UNLOCK; LOCALE_UNLOCK; } STMT_END
+#else
+# define gwENVr_LOCALEr_LOCK ENV_LOCK
+# define gwENVr_LOCALEr_UNLOCK ENV_UNLOCK
+#endif
+
+/* Now that we have defined gwENVr_LOCALEr_LOCK, we can finish defining
+ * LOCALE_LOCK, which we kept undefined until here on a thread-safe system
+ * so that we could use that fact to calculate what gwENVr_LOCALEr_LOCK should
+ * be */
+#ifndef LOCALE_LOCK
+# define LOCALE_LOCK NOOP
+# define LOCALE_UNLOCK NOOP
+#endif
+
+ /* On systems that don't have per-thread locales, even though we don't
+ * think we are changing the locale ourselves, behind the scenes it does
+ * get changed to whatever the thread's should be, so it has to be an
+ * exclusive lock. By defining it here with this name, we can, for the
+ * most part, hide this detail from the rest of the code */
+/* Currently, the read lock is an exclusive lock */
+#define LOCALE_READ_LOCK LOCALE_LOCK
+#define LOCALE_READ_UNLOCK LOCALE_UNLOCK
+
+
+#ifndef LC_NUMERIC_LOCK
+# define LC_NUMERIC_LOCK(cond) NOOP
+# define LC_NUMERIC_UNLOCK NOOP
#endif
+ /* These non-reentrant versions use global space */
+# define MBLEN_LOCK_ gwLOCALE_LOCK
+# define MBLEN_UNLOCK_ gwLOCALE_UNLOCK
+
+# define MBTOWC_LOCK_ gwLOCALE_LOCK
+# define MBTOWC_UNLOCK_ gwLOCALE_UNLOCK
+
+# define WCTOMB_LOCK_ gwLOCALE_LOCK
+# define WCTOMB_UNLOCK_ gwLOCALE_UNLOCK
+
+ /* Whereas the reentrant versions don't (assuming they are called with a
+ * per-thread buffer; some have the capability of being called with a NULL
+ * parameter, which defeats the reentrancy) */
+# define MBRLEN_LOCK_ NOOP
+# define MBRLEN_UNLOCK_ NOOP
+# define MBRTOWC_LOCK_ NOOP
+# define MBRTOWC_UNLOCK_ NOOP
+# define WCRTOMB_LOCK_ NOOP
+# define WCRTOMB_UNLOCK_ NOOP
+
+# define LC_COLLATE_LOCK LOCALE_LOCK
+# define LC_COLLATE_UNLOCK LOCALE_UNLOCK
+
+# define STRFTIME_LOCK ENV_LOCK
+# define STRFTIME_UNLOCK ENV_UNLOCK
+
#ifdef USE_LOCALE_NUMERIC
/* These macros are for toggling between the underlying locale (UNDERLYING or
* khw believes the reason for the variables instead of the bits in a single
* word is to avoid having to have masking instructions. */
-# define _NOT_IN_NUMERIC_STANDARD (! PL_numeric_standard)
+# define NOT_IN_NUMERIC_STANDARD_ (! PL_numeric_standard)
/* We can lock the category to stay in the C locale, making requests to the
* contrary be noops, in the dynamic scope by setting PL_numeric_standard to 2.
* */
-# define _NOT_IN_NUMERIC_UNDERLYING \
+# define NOT_IN_NUMERIC_UNDERLYING_ \
(! PL_numeric_underlying && PL_numeric_standard < 2)
# define DECLARATION_FOR_LC_NUMERIC_MANIPULATION \
- void (*_restore_LC_NUMERIC_function)(pTHX) = NULL
+ void (*_restore_LC_NUMERIC_function)(pTHX_ const char * const file, \
+ const line_t line) = NULL
# define STORE_LC_NUMERIC_SET_TO_NEEDED_IN(in) \
STMT_START { \
bool _in_lc_numeric = (in); \
LC_NUMERIC_LOCK( \
- ( ( _in_lc_numeric && _NOT_IN_NUMERIC_UNDERLYING) \
- || (! _in_lc_numeric && _NOT_IN_NUMERIC_STANDARD))); \
+ ( ( _in_lc_numeric && NOT_IN_NUMERIC_UNDERLYING_) \
+ || (! _in_lc_numeric && NOT_IN_NUMERIC_STANDARD_))); \
if (_in_lc_numeric) { \
- if (_NOT_IN_NUMERIC_UNDERLYING) { \
- Perl_set_numeric_underlying(aTHX); \
+ if (NOT_IN_NUMERIC_UNDERLYING_) { \
+ Perl_set_numeric_underlying(aTHX_ __FILE__, __LINE__); \
_restore_LC_NUMERIC_function \
= &Perl_set_numeric_standard; \
} \
} \
else { \
- if (_NOT_IN_NUMERIC_STANDARD) { \
- Perl_set_numeric_standard(aTHX); \
+ if (NOT_IN_NUMERIC_STANDARD_) { \
+ Perl_set_numeric_standard(aTHX_ __FILE__, __LINE__); \
_restore_LC_NUMERIC_function \
= &Perl_set_numeric_underlying; \
} \
# define RESTORE_LC_NUMERIC() \
STMT_START { \
if (_restore_LC_NUMERIC_function) { \
- _restore_LC_NUMERIC_function(aTHX); \
+ _restore_LC_NUMERIC_function(aTHX_ __FILE__, __LINE__); \
} \
LC_NUMERIC_UNLOCK; \
} STMT_END
-/* The next two macros set unconditionally. These should be rarely used, and
- * only after being sure that this is what is needed */
+/* The next two macros should be rarely used, and only after being sure that
+ * this is what is needed */
# define SET_NUMERIC_STANDARD() \
- STMT_START { \
+ STMT_START { \
DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
"%s: %d: lc_numeric standard=%d\n", \
__FILE__, __LINE__, PL_numeric_standard)); \
- Perl_set_numeric_standard(aTHX); \
+ if (UNLIKELY(NOT_IN_NUMERIC_STANDARD_)) { \
+ Perl_set_numeric_standard(aTHX_ __FILE__, __LINE__); \
+ } \
DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
"%s: %d: lc_numeric standard=%d\n", \
__FILE__, __LINE__, PL_numeric_standard)); \
# define SET_NUMERIC_UNDERLYING() \
STMT_START { \
- if (_NOT_IN_NUMERIC_UNDERLYING) { \
- Perl_set_numeric_underlying(aTHX); \
+ /*assert(PL_locale_mutex_depth > 0);*/ \
+ if (NOT_IN_NUMERIC_UNDERLYING_) { \
+ Perl_set_numeric_underlying(aTHX_ __FILE__, __LINE__); \
} \
} STMT_END
* the RESTORE_foo ones called to switch back, but only if need be */
# define STORE_LC_NUMERIC_SET_STANDARD() \
STMT_START { \
- LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_STANDARD); \
- if (_NOT_IN_NUMERIC_STANDARD) { \
+ LC_NUMERIC_LOCK(NOT_IN_NUMERIC_STANDARD_); \
+ if (NOT_IN_NUMERIC_STANDARD_) { \
_restore_LC_NUMERIC_function = &Perl_set_numeric_underlying;\
- Perl_set_numeric_standard(aTHX); \
+ Perl_set_numeric_standard(aTHX_ __FILE__, __LINE__); \
} \
} STMT_END
* locale'. This is principally in the POSIX:: functions */
# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \
STMT_START { \
- LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_UNDERLYING); \
- if (_NOT_IN_NUMERIC_UNDERLYING) { \
- Perl_set_numeric_underlying(aTHX); \
+ LC_NUMERIC_LOCK(NOT_IN_NUMERIC_UNDERLYING_); \
+ if (NOT_IN_NUMERIC_UNDERLYING_) { \
+ Perl_set_numeric_underlying(aTHX_ __FILE__, __LINE__); \
_restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \
} \
} STMT_END
-/* Lock/unlock to the C locale until unlock is called. This needs to be
- * recursively callable. [perl #128207] */
-# define LOCK_LC_NUMERIC_STANDARD() \
+/* Lock/unlock changes to LC_NUMERIC. This needs to be recursively callable.
+ * The highest level caller is responsible for making sure that LC_NUMERIC is
+ * set to a locale with a dot radix character. These deliberately don't check
+ * for the internal state being so, as they can be called from code that is not
+ * party to the internal conventions, namely 'version' (vutil.c).
+ * PL_numeric_standard changing doesn't affect anything about what locale is in
+ * effect, etc. [perl #128207] */
+# define DISABLE_LC_NUMERIC_CHANGES() \
STMT_START { \
DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: lock lc_numeric_standard: new depth=%d\n", \
- __FILE__, __LINE__, PL_numeric_standard + 1)); \
- __ASSERT_(PL_numeric_standard) \
+ "%s: %d: lc_numeric_standard now locked to depth %d\n", \
+ __FILE__, __LINE__, PL_numeric_standard)); \
PL_numeric_standard++; \
} STMT_END
-# define UNLOCK_LC_NUMERIC_STANDARD() \
+# define REENABLE_LC_NUMERIC_CHANGES() \
STMT_START { \
if (PL_numeric_standard > 1) { \
PL_numeric_standard--; \
assert(0); \
} \
DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
- "%s: %d: lc_numeric_standard decrement lock, new depth=%d\n", \
- __FILE__, __LINE__, PL_numeric_standard)); \
+ "%s: %d: ", __FILE__, __LINE__); \
+ if (PL_numeric_standard <= 1) \
+ PerlIO_printf(Perl_debug_log, \
+ "lc_numeric_standard now unlocked\n");\
+ else PerlIO_printf(Perl_debug_log, \
+ "lc_numeric_standard lock decremented to depth %d\n", \
+ PL_numeric_standard););\
+ } STMT_END
+
+/* Essentially synonyms for the above. The LOCK asserts at the top level that
+ * we are in a locale equivalent to C. By including the top level, this can be
+ * recursively called from chains which include DISABLE_LC_NUMERIC_CHANGES().
+ * */
+# define LOCK_LC_NUMERIC_STANDARD() \
+ STMT_START { \
+ assert(PL_numeric_standard > 0 || PL_numeric_standard); \
+ DISABLE_LC_NUMERIC_CHANGES(); \
} STMT_END
+# define UNLOCK_LC_NUMERIC_STANDARD() REENABLE_LC_NUMERIC_CHANGES()
# define WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, block) \
STMT_START { \
STORE_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric); \
block; \
RESTORE_LC_NUMERIC(); \
- } STMT_END;
+ } STMT_END
# define WITH_LC_NUMERIC_SET_TO_NEEDED(block) \
WITH_LC_NUMERIC_SET_TO_NEEDED_IN(IN_LC(LC_NUMERIC), block)
# define RESTORE_LC_NUMERIC()
# define LOCK_LC_NUMERIC_STANDARD()
# define UNLOCK_LC_NUMERIC_STANDARD()
+# define DISABLE_LC_NUMERIC_CHANGES()
+# define REENABLE_LC_NUMERIC_CHANGES()
# define WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, block) \
STMT_START { block; } STMT_END
# define WITH_LC_NUMERIC_SET_TO_NEEDED(block) \
#endif /* !USE_LOCALE_NUMERIC */
-#define Atof my_atof
+#ifdef USE_LOCALE_THREADS
+# define ENV_LOCK PERL_WRITE_LOCK(&PL_env_mutex)
+# define ENV_UNLOCK PERL_WRITE_UNLOCK(&PL_env_mutex)
+# define ENV_READ_LOCK PERL_READ_LOCK(&PL_env_mutex)
+# define ENV_READ_UNLOCK PERL_READ_UNLOCK(&PL_env_mutex)
+# define ENV_INIT PERL_RW_MUTEX_INIT(&PL_env_mutex)
+# define ENV_TERM PERL_RW_MUTEX_DESTROY(&PL_env_mutex)
+
+ /* On platforms where the static buffer contained in getenv() is per-thread
+ * rather than process-wide, another thread executing a getenv() at the same
+ * time won't destroy ours before we have copied the result safely away and
+ * unlocked the mutex. On such platforms (which is most), we can have many
+ * readers of the environment at the same time. */
+# ifdef GETENV_PRESERVES_OTHER_THREAD
+# define GETENV_LOCK ENV_READ_LOCK
+# define GETENV_UNLOCK ENV_READ_UNLOCK
+# else
+ /* If, on the other hand, another thread could zap our getenv() return, we
+ * need to keep them from executing until we are done */
+# define GETENV_LOCK ENV_LOCK
+# define GETENV_UNLOCK ENV_UNLOCK
+# endif
+#else
+# define ENV_LOCK NOOP
+# define ENV_UNLOCK NOOP
+# define ENV_READ_LOCK NOOP
+# define ENV_READ_UNLOCK NOOP
+# define ENV_INIT NOOP
+# define ENV_TERM NOOP
+# define GETENV_LOCK NOOP
+# define GETENV_UNLOCK NOOP
+#endif
+
+/* Some critical sections need to lock both the locale and the environment from
+ * changing, while allowing for any number of readers. To avoid deadlock, this
+ * is always done in the same order. These should always be invoked, like all
+ * locks really, at such a low level that its just a libc call that is wrapped,
+ * so as to prevent recursive calls which could deadlock. */
+#define ENVr_LOCALEr_LOCK \
+ STMT_START { LOCALE_READ_LOCK; ENV_READ_LOCK; } STMT_END
+#define ENVr_LOCALEr_UNLOCK \
+ STMT_START { ENV_READ_UNLOCK; LOCALE_READ_UNLOCK; } STMT_END
+
+/* These time-related functions all requre that the environment and locale
+ * don't change while they are executing (at least in glibc; this appears to be
+ * contrary to the POSIX standard). tzset() writes global variables, so
+ * always needs to have write locking. ctime, localtime, mktime, and strftime
+ * effectively call it, so they too need exclusive access. The rest need to
+ * have exclusive locking as well so that they can copy the contents of the
+ * returned static buffer before releasing the lock. That leaves asctime and
+ * gmtime. There may be reentrant versions of these available on the platform
+ * which don't require write locking.
+ */
+#ifdef PERL_REENTR_USING_ASCTIME_R
+# define ASCTIME_LOCK ENVr_LOCALEr_LOCK
+# define ASCTIME_UNLOCK ENVr_LOCALEr_UNLOCK
+#else
+# define ASCTIME_LOCK gwENVr_LOCALEr_LOCK
+# define ASCTIME_UNLOCK gwENVr_LOCALEr_UNLOCK
+#endif
+
+#define CTIME_LOCK gwENVr_LOCALEr_LOCK
+#define CTIME_UNLOCK gwENVr_LOCALEr_UNLOCK
+
+#ifdef PERL_REENTR_USING_GMTIME_R
+# define GMTIME_LOCK ENVr_LOCALEr_LOCK
+# define GMTIME_UNLOCK ENVr_LOCALEr_UNLOCK
+#else
+# define GMTIME_LOCK gwENVr_LOCALEr_LOCK
+# define GMTIME_UNLOCK gwENVr_LOCALEr_UNLOCK
+#endif
+
+#define LOCALTIME_LOCK gwENVr_LOCALEr_LOCK
+#define LOCALTIME_UNLOCK gwENVr_LOCALEr_UNLOCK
+#define MKTIME_LOCK gwENVr_LOCALEr_LOCK
+#define MKTIME_UNLOCK gwENVr_LOCALEr_UNLOCK
+#define TZSET_LOCK gwENVr_LOCALEr_LOCK
+#define TZSET_UNLOCK gwENVr_LOCALEr_UNLOCK
+
+/* Similiarly, these functions need a constant environment and/or locale. And
+ * some have a buffer that is shared with another thread executing the same or
+ * a related call. A mutex could be created for each class, but for now, share
+ * the ENV mutex with everything, as none probably gets called so much that
+ * performance would suffer by a thread being locked out by another thread that
+ * could have used a different mutex.
+ *
+ * But, create a different macro name just to indicate the ones that don't
+ * actually depend on the environment, but are using its mutex for want of a
+ * better one */
+#define gwLOCALEr_LOCK gwENVr_LOCALEr_LOCK
+#define gwLOCALEr_UNLOCK gwENVr_LOCALEr_UNLOCK
+
+#ifdef PERL_REENTR_USING_GETHOSTBYADDR_R
+# define GETHOSTBYADDR_LOCK ENVr_LOCALEr_LOCK
+# define GETHOSTBYADDR_UNLOCK ENVr_LOCALEr_UNLOCK
+#else
+# define GETHOSTBYADDR_LOCK gwENVr_LOCALEr_LOCK
+# define GETHOSTBYADDR_UNLOCK gwENVr_LOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETHOSTBYNAME_R
+# define GETHOSTBYNAME_LOCK ENVr_LOCALEr_LOCK
+# define GETHOSTBYNAME_UNLOCK ENVr_LOCALEr_UNLOCK
+#else
+# define GETHOSTBYNAME_LOCK gwENVr_LOCALEr_LOCK
+# define GETHOSTBYNAME_UNLOCK gwENVr_LOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETNETBYADDR_R
+# define GETNETBYADDR_LOCK LOCALE_READ_LOCK
+# define GETNETBYADDR_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETNETBYADDR_LOCK gwLOCALEr_LOCK
+# define GETNETBYADDR_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETNETBYNAME_R
+# define GETNETBYNAME_LOCK LOCALE_READ_LOCK
+# define GETNETBYNAME_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETNETBYNAME_LOCK gwLOCALEr_LOCK
+# define GETNETBYNAME_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETPROTOBYNAME_R
+# define GETPROTOBYNAME_LOCK LOCALE_READ_LOCK
+# define GETPROTOBYNAME_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETPROTOBYNAME_LOCK gwLOCALEr_LOCK
+# define GETPROTOBYNAME_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETPROTOBYNUMBER_R
+# define GETPROTOBYNUMBER_LOCK LOCALE_READ_LOCK
+# define GETPROTOBYNUMBER_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETPROTOBYNUMBER_LOCK gwLOCALEr_LOCK
+# define GETPROTOBYNUMBER_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETPROTOENT_R
+# define GETPROTOENT_LOCK LOCALE_READ_LOCK
+# define GETPROTOENT_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETPROTOENT_LOCK gwLOCALEr_LOCK
+# define GETPROTOENT_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETPWNAM_R
+# define GETPWNAM_LOCK LOCALE_READ_LOCK
+# define GETPWNAM_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETPWNAM_LOCK gwLOCALEr_LOCK
+# define GETPWNAM_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETPWUID_R
+# define GETPWUID_LOCK LOCALE_READ_LOCK
+# define GETPWUID_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETPWUID_LOCK gwLOCALEr_LOCK
+# define GETPWUID_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETSERVBYNAME_R
+# define GETSERVBYNAME_LOCK LOCALE_READ_LOCK
+# define GETSERVBYNAME_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETSERVBYNAME_LOCK gwLOCALEr_LOCK
+# define GETSERVBYNAME_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETSERVBYPORT_R
+# define GETSERVBYPORT_LOCK LOCALE_READ_LOCK
+# define GETSERVBYPORT_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETSERVBYPORT_LOCK gwLOCALEr_LOCK
+# define GETSERVBYPORT_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETSERVENT_R
+# define GETSERVENT_LOCK LOCALE_READ_LOCK
+# define GETSERVENT_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETSERVENT_LOCK gwLOCALEr_LOCK
+# define GETSERVENT_UNLOCK gwLOCALEr_UNLOCK
+#endif
+#ifdef PERL_REENTR_USING_GETSPNAM_R
+# define GETSPNAM_LOCK LOCALE_READ_LOCK
+# define GETSPNAM_UNLOCK LOCALE_READ_UNLOCK
+#else
+# define GETSPNAM_LOCK gwLOCALEr_LOCK
+# define GETSPNAM_UNLOCK gwLOCALEr_UNLOCK
+#endif
+
+#define STRFMON_LOCK LC_MONETARY_LOCK
+#define STRFMON_UNLOCK LC_MONETARY_UNLOCK
+
+/* End of locale/env synchronization */
+
+#ifndef PERL_NO_INLINE_FUNCTIONS
+/* Static inline funcs that depend on includes and declarations above.
+ Some of these reference functions in the perl object files, and some
+ compilers aren't smart enough to eliminate unused static inline
+ functions, so including this file in source code can cause link errors
+ even if the source code uses none of the functions. Hence including these
+ can be suppressed by setting PERL_NO_INLINE_FUNCTIONS. Doing this will
+ (obviously) result in unworkable XS code, but allows simple probing code
+ to continue to work, because it permits tests to include the perl headers
+ for definitions without creating a link dependency on the perl library
+ (which may not exist yet).
+*/
+
+START_EXTERN_C
+
+# include "perlstatic.h"
+# include "inline.h"
+# include "sv_inline.h"
+
+END_EXTERN_C
+
+#endif
/*
#endif
#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \
- (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
+ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef __hpux
# define strtoll __strtoll /* secret handshake */
# endif
* (as is done for Atoul(), see below) but for backward compatibility
* we just assume atol(). */
# if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && defined(HAS_ATOLL) && \
- (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
+ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef WIN64
# define atoll _atoi64 /* secret handshake */
# endif
#endif
#if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && \
- (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
+ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef __hpux
# define strtoull __strtoull /* secret handshake */
# endif
#endif
#define grok_bin(s,lp,fp,rp) \
- grok_bin_oct_hex(s, lp, fp, rp, 1, _CC_BINDIGIT, 'b')
+ grok_bin_oct_hex(s, lp, fp, rp, 1, CC_BINDIGIT_, 'b')
#define grok_oct(s,lp,fp,rp) \
(*(fp) |= PERL_SCAN_DISALLOW_PREFIX, \
- grok_bin_oct_hex(s, lp, fp, rp, 3, _CC_OCTDIGIT, '\0'))
+ grok_bin_oct_hex(s, lp, fp, rp, 3, CC_OCTDIGIT_, '\0'))
#define grok_hex(s,lp,fp,rp) \
- grok_bin_oct_hex(s, lp, fp, rp, 4, _CC_XDIGIT, 'x')
+ grok_bin_oct_hex(s, lp, fp, rp, 4, CC_XDIGIT_, 'x')
#ifndef PERL_SCRIPT_MODE
#define PERL_SCRIPT_MODE "r"
* massively.
*/
-#ifndef PERL_MICRO
-# ifndef PERL_ASYNC_CHECK
-# define PERL_ASYNC_CHECK() if (UNLIKELY(PL_sig_pending)) PL_signalhook(aTHX)
-# endif
-#endif
-
#ifndef PERL_ASYNC_CHECK
-# define PERL_ASYNC_CHECK() NOOP
+#define PERL_ASYNC_CHECK() if (UNLIKELY(PL_sig_pending)) PL_signalhook(aTHX)
#endif
/*
# include <sys/sem.h>
# ifndef HAS_UNION_SEMUN /* Provide the union semun. */
union semun {
- int val;
- struct semid_ds *buf;
- unsigned short *array;
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
};
# endif
# ifdef USE_SEMCTL_SEMUN
# ifdef IRIX32_SEMUN_BROKEN_BY_GCC
union gccbug_semun {
- int val;
- struct semid_ds *buf;
- unsigned short *array;
- char __dummy[5];
- };
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
+ char __dummy[5];
+ };
# define semun gccbug_semun
# endif
# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun)
* "DynaLoader::_guts" XS_VERSION
* XXX in the current implementation, this string is ignored.
* 2. Declare a typedef named my_cxt_t that is a structure that contains
- * all the data that needs to be interpreter-local.
+ * all the data that needs to be interpreter-local that perl controls. This
+ * doesn't include things that libc controls, such as the uselocale object
+ * in Configurations that use it.
* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
* 4. Use the MY_CXT_INIT macro such that it is called exactly once
* (typically put in the BOOT: section).
* access MY_CXT.
*/
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
/* START_MY_CXT must appear in all extensions that define a my_cxt_t structure,
* right after the definition (i.e. at file scope). The non-threads
* (We allocate my_cxtp in a Perl SV so that it will be released when
* the interpreter goes away.) */
# define MY_CXT_INIT \
- my_cxt_t *my_cxtp = \
- (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \
- PERL_UNUSED_VAR(my_cxtp)
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \
+ PERL_UNUSED_VAR(my_cxtp)
# define MY_CXT_INIT_INTERP(my_perl) \
- my_cxt_t *my_cxtp = \
- (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \
- PERL_UNUSED_VAR(my_cxtp)
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \
+ PERL_UNUSED_VAR(my_cxtp)
/* This declaration should be used within all functions that use the
* interpreter-local data. */
# define dMY_CXT \
- my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX]
+ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX]
# define dMY_CXT_INTERP(my_perl) \
- my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX]
+ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX]
/* Clones the per-interpreter data. */
# define MY_CXT_CLONE \
- my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
- void * old_my_cxtp = PL_my_cxt_list[MY_CXT_INDEX]; \
- PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp; \
- Copy(old_my_cxtp, my_cxtp, 1, my_cxt_t);
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ void * old_my_cxtp = PL_my_cxt_list[MY_CXT_INDEX]; \
+ PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp; \
+ Copy(old_my_cxtp, my_cxtp, 1, my_cxt_t);
# define aMY_CXT_ aMY_CXT,
# define _aMY_CXT ,aMY_CXT
-#else /* PERL_IMPLICIT_CONTEXT */
+#else /* MULTIPLICITY */
# define START_MY_CXT static my_cxt_t my_cxt;
# define dMY_CXT dNOOP
# define dMY_CXT_INTERP(my_perl) dNOOP
# define aMY_CXT_
# define _aMY_CXT
-#endif /* !defined(PERL_IMPLICIT_CONTEXT) */
+#endif /* !defined(MULTIPLICITY) */
#ifdef I_FCNTL
# include <fcntl.h>
#endif
#define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not
- int). value returned in pointed-
- to UV */
+ int). value returned in pointed-
+ to UV */
#define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */
#define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation or infnan */
#define IS_NUMBER_NEG 0x08 /* leading minus sign */
#define PERL_UNICODE_UTF8CACHEASSERT_FLAG 0x0100
#define PERL_UNICODE_STD_FLAG \
- (PERL_UNICODE_STDIN_FLAG | \
- PERL_UNICODE_STDOUT_FLAG | \
- PERL_UNICODE_STDERR_FLAG)
+ (PERL_UNICODE_STDIN_FLAG | \
+ PERL_UNICODE_STDOUT_FLAG | \
+ PERL_UNICODE_STDERR_FLAG)
#define PERL_UNICODE_INOUT_FLAG \
- (PERL_UNICODE_IN_FLAG | \
- PERL_UNICODE_OUT_FLAG)
+ (PERL_UNICODE_IN_FLAG | \
+ PERL_UNICODE_OUT_FLAG)
#define PERL_UNICODE_DEFAULT_FLAGS \
- (PERL_UNICODE_STD_FLAG | \
- PERL_UNICODE_INOUT_FLAG | \
- PERL_UNICODE_LOCALE_FLAG)
+ (PERL_UNICODE_STD_FLAG | \
+ PERL_UNICODE_INOUT_FLAG | \
+ PERL_UNICODE_LOCALE_FLAG)
#define PERL_UNICODE_ALL_FLAGS 0x01ff
#endif
#define do_open(g, n, l, a, rm, rp, sf) \
- do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0)
+ do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0)
#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
# define do_exec(cmd) do_exec3(cmd,0,0)
#endif
#define PERL_PV_ESCAPE_NONASCII 0x000400
#define PERL_PV_ESCAPE_FIRSTCHAR 0x000800
-#define PERL_PV_ESCAPE_ALL 0x001000
+#define PERL_PV_ESCAPE_ALL 0x001000
#define PERL_PV_ESCAPE_NOBACKSLASH 0x002000
#define PERL_PV_ESCAPE_NOCLEAR 0x004000
#define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
#define PERL_PV_ESCAPE_RE 0x008000
+/* Escape PV with hex, except leave NULs as octal: */
#define PERL_PV_ESCAPE_DWIM 0x010000
+/* Escape PV with all hex, including NUL. */
+#define PERL_PV_ESCAPE_DWIM_ALL_HEX 0x020000
+
+/* Do not escape word characters, alters meaning of other flags */
+#define PERL_PV_ESCAPE_NON_WC 0x040000
+#define PERL_PV_ESCAPE_TRUNC_MIDDLE 0x080000
+
+#define PERL_PV_PRETTY_QUOTEDPREFIX ( \
+ PERL_PV_PRETTY_ELLIPSES | \
+ PERL_PV_PRETTY_QUOTE | \
+ PERL_PV_ESCAPE_NONASCII | \
+ PERL_PV_ESCAPE_NON_WC | \
+ PERL_PV_ESCAPE_TRUNC_MIDDLE | \
+ 0)
+
/* used by pv_display in dump.c*/
#define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
#else
+/* The declarations here need to match the initializations done above,
+ since a mismatch across compilation units causes undefined
+ behavior. It also prevents warnings from LTO builds.
+*/
+# if !defined(USE_QUADMATH) && \
+ (NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLINFBYTES) || \
+ NVSIZE == DOUBLESIZE && defined(DOUBLEINFBYTES))
+INFNAN_U8_NV_DECL PL_inf;
+# else
INFNAN_NV_U8_DECL PL_inf;
+# endif
+
+# if !defined(USE_QUADMATH) && \
+ (NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLNANBYTES) || \
+ NVSIZE == DOUBLESIZE && defined(DOUBLENANBYTES))
+INFNAN_U8_NV_DECL PL_nan;
+# else
INFNAN_NV_U8_DECL PL_nan;
+# endif
#endif
#endif /* DOUBLE_HAS_NAN */
+/* these are used to faciliate the env var PERL_RAND_SEED,
+ * which allows consistent behavior from code that calls
+ * srand() with no arguments, either explicitly or implicitly.
+ */
+#define PERL_SRAND_OVERRIDE_NEXT() PERL_XORSHIFT32_A(PL_srand_override_next);
+
+#define PERL_SRAND_OVERRIDE_NEXT_INIT() STMT_START { \
+ PL_srand_override = PL_srand_override_next; \
+ PERL_SRAND_OVERRIDE_NEXT(); \
+} STMT_END
+
+#define PERL_SRAND_OVERRIDE_GET(into) STMT_START { \
+ into= PL_srand_override; \
+ PERL_SRAND_OVERRIDE_NEXT_INIT(); \
+} STMT_END
+
+#define PERL_SRAND_OVERRIDE_NEXT_CHILD() STMT_START { \
+ PERL_XORSHIFT32_B(PL_srand_override_next); \
+ PERL_SRAND_OVERRIDE_NEXT_INIT(); \
+} STMT_END
+
+#define PERL_SRAND_OVERRIDE_NEXT_PARENT() \
+ PERL_SRAND_OVERRIDE_NEXT()
+
+/* in something like
+ *
+ * perl -le'sub f { eval "BEGIN{ f() }" }'
+ *
+ * Each iteration chews up 8 stacks frames, and we will eventually SEGV
+ * due to C stack overflow.
+ *
+ * This define provides a maximum limit to prevent the SEGV. Such code is
+ * unusual, so it unlikely we need a very large number here.
+ */
+#ifndef PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT
+#define PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT 1000
+#endif
+/* ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} */
+#define PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS "\015AX_NESTED_EVAL_BEGIN_BLOCKS"
+
+/* Defines like this make it easier to do porting/diag.t. They are no-
+ * ops that return their argument which can be used to hint to diag.t
+ * that a string is actually an error message. By putting the category
+ * information into the macro name it considerably simplifies extended
+ * diag.t to support these cases. Feel free to add more.
+ *
+ * While it seems tempting to try to convert all of our diagnostics to
+ * this format, it would miss part of the point of diag.t in that it
+ * detects NEW diagnostics, which would not necessarily use these
+ * macros. The macros instead exist where we know we have an error
+ * message that isnt being picked up by diag.t because it is declared
+ * as a string independently of the function it is fed to, something
+ * diag.t can never handle right without help.
+ */
+#define PERL_DIAG_STR_(x) ("" x "")
+#define PERL_DIAG_WARN_SYNTAX(x) PERL_DIAG_STR_(x)
+#define PERL_DIAG_DIE_SYNTAX(x) PERL_DIAG_STR_(x)
+
+#ifndef PERL_STOP_PARSING_AFTER_N_ERRORS
+#define PERL_STOP_PARSING_AFTER_N_ERRORS 10
+#endif
+
+#define PERL_PARSE_ERROR_COUNT(f) (f)
+
+
+/* Work around
+
+ https://github.com/Perl/perl5/issues/21313
+
+ Where gcc when generating code for 32-bit windows assumes the stack
+ is 16 byte aligned, where the system doesn't guarantee that.
+
+ The code generated by gcc itself does maintain 16 byte alignment,
+ but callbacks from the CRT or Windows APIs don't, so calls to
+ code that is generated to SSE instructions (like the quadmath code
+ by default), crashes when called from a callback.
+
+ Since other code other than quadmath might use SSE instructions,
+ also enable this outside of quadmath builds.
+
+ This change is a little risky: if an XS module uses callbacks
+ and those callbacks may also produce alignment errors, if that
+ becomes a problem we'll need to use the nuclear option: building
+ 32-bit perl with -mstackrealign.
+*/
+#if defined(WIN32) && !defined(WIN64) && defined(__GNUC__)
+# define PERL_STACK_REALIGN __attribute__((force_align_arg_pointer))
+#else
+# define PERL_STACK_REALIGN
+#endif
/*