diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h | 2614 |
1 files changed, 1699 insertions, 915 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h b/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h index 17a21a1c42..4ef161db95 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/perl.h @@ -11,6 +11,22 @@ #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. @@ -28,14 +44,42 @@ # include "config.h" #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 @@ -50,7 +94,7 @@ #endif /* See L<perlguts/"The Perl API"> for detailed notes on - * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */ + * MULTIPLICITY and PERL_IMPLICIT_SYS */ /* XXX NOTE that from here --> to <-- the same logic is * repeated in makedef.pl, so be certain to update @@ -62,10 +106,18 @@ # 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 */ @@ -77,7 +129,7 @@ /* 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(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(WIN32) # define USE_REENTRANT_API #endif @@ -146,10 +198,7 @@ Now a synonym for C<L</dTHXa>>. =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 @@ -284,6 +333,19 @@ Now a no-op. # 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 @@ -300,40 +362,43 @@ Now a no-op. #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 -> */ +# 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 */ @@ -363,10 +428,18 @@ Now a no-op. #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__ @@ -396,6 +469,9 @@ Now a no-op. #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 @@ -413,7 +489,9 @@ Now a no-op. * 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 @@ -432,7 +510,7 @@ Example usage: =back =cut - */ +*/ #ifndef PERL_UNUSED_DECL # define PERL_UNUSED_DECL __attribute__unused__ @@ -442,25 +520,26 @@ Example usage: * 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 @@ -481,7 +560,7 @@ compilation causes it be used just some times. */ #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 @@ -516,7 +595,7 @@ and use C<L</PERL_UNUSED_VAR>> on that. =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. @@ -529,11 +608,6 @@ __typeof__ and nothing else. # endif #endif -#if defined(_MSC_VER) && _MSC_VER < 1400 -/* 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. * @@ -557,8 +631,7 @@ __typeof__ and nothing else. * */ -#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") \ @@ -587,7 +660,7 @@ __typeof__ and nothing else. #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)) @@ -601,23 +674,23 @@ __typeof__ and nothing else. #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_ @@ -626,7 +699,7 @@ code. # 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 @@ -644,7 +717,7 @@ code. 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 @@ -693,28 +766,60 @@ Now a placeholder that declares nothing /* =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: @@ -733,23 +838,27 @@ 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 /* @@ -761,7 +870,7 @@ Example usage: */ /* 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 @@ -811,6 +920,68 @@ Example usage: # 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) @@ -821,15 +992,12 @@ Example usage: # 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 */ @@ -883,6 +1051,13 @@ Example usage: # 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. */ @@ -918,10 +1093,16 @@ Example usage: # 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 @@ -983,6 +1164,9 @@ Example usage: # if !defined(NO_LOCALE_TELEPHONE) && defined(LC_TELEPHONE) # define USE_LOCALE_TELEPHONE # endif +# if !defined(NO_LOCALE_NAME) && defined(LC_NAME) +# define USE_LOCALE_NAME +# endif # if !defined(NO_LOCALE_SYNTAX) && defined(LC_SYNTAX) # define USE_LOCALE_SYNTAX # endif @@ -990,38 +1174,205 @@ Example usage: # define USE_LOCALE_TOD # endif -/* XXX The next few defines are unfortunately duplicated in makedef.pl, and - * changes here MUST also be made there */ +/* Now create LC_foo_INDEX_ #defines for just those categories on this system */ +# ifdef USE_LOCALE_CTYPE +# define LC_CTYPE_INDEX_ 0 +# define PERL_DUMMY_CTYPE_ LC_CTYPE_INDEX_ +# else +# define PERL_DUMMY_CTYPE_ -1 +# endif +# ifdef USE_LOCALE_NUMERIC +# define LC_NUMERIC_INDEX_ PERL_DUMMY_CTYPE_ + 1 +# define PERL_DUMMY_NUMERIC_ LC_NUMERIC_INDEX_ +# else +# define PERL_DUMMY_NUMERIC_ PERL_DUMMY_CTYPE_ +# endif +# ifdef USE_LOCALE_COLLATE +# define LC_COLLATE_INDEX_ PERL_DUMMY_NUMERIC_ + 1 +# define PERL_DUMMY_COLLATE_ LC_COLLATE_INDEX_ +# else +# define PERL_DUMMY_COLLATE_ PERL_DUMMY_NUMERIC_ +# endif +# ifdef USE_LOCALE_TIME +# define LC_TIME_INDEX_ PERL_DUMMY_COLLATE_ + 1 +# define PERL_DUMMY_TIME_ LC_TIME_INDEX_ +# else +# define PERL_DUMMY_TIME_ PERL_DUMMY_COLLATE_ +# endif +# ifdef USE_LOCALE_MESSAGES +# define LC_MESSAGES_INDEX_ PERL_DUMMY_TIME_ + 1 +# define PERL_DUMMY_MESSAGES_ LC_MESSAGES_INDEX_ +# else +# define PERL_DUMMY_MESSAGES_ PERL_DUMMY_TIME_ +# endif +# ifdef USE_LOCALE_MONETARY +# define LC_MONETARY_INDEX_ PERL_DUMMY_MESSAGES_ + 1 +# define PERL_DUMMY_MONETARY_ LC_MONETARY_INDEX_ +# else +# define PERL_DUMMY_MONETARY_ PERL_DUMMY_MESSAGES_ +# endif +# ifdef USE_LOCALE_ADDRESS +# define LC_ADDRESS_INDEX_ PERL_DUMMY_MONETARY_ + 1 +# define PERL_DUMMY_ADDRESS_ LC_ADDRESS_INDEX_ +# else +# define PERL_DUMMY_ADDRESS_ PERL_DUMMY_MONETARY_ +# endif +# ifdef USE_LOCALE_IDENTIFICATION +# define LC_IDENTIFICATION_INDEX_ PERL_DUMMY_ADDRESS_ + 1 +# define PERL_DUMMY_IDENTIFICATION_ LC_IDENTIFICATION_INDEX_ +# else +# define PERL_DUMMY_IDENTIFICATION_ PERL_DUMMY_ADDRESS_ +# endif +# ifdef USE_LOCALE_MEASUREMENT +# define LC_MEASUREMENT_INDEX_ PERL_DUMMY_IDENTIFICATION_ + 1 +# define PERL_DUMMY_MEASUREMENT_ LC_MEASUREMENT_INDEX_ +# else +# define PERL_DUMMY_MEASUREMENT_ PERL_DUMMY_IDENTIFICATION_ +# endif +# ifdef USE_LOCALE_PAPER +# define LC_PAPER_INDEX_ PERL_DUMMY_MEASUREMENT_ + 1 +# define PERL_DUMMY_PAPER_ LC_PAPER_INDEX_ +# else +# define PERL_DUMMY_PAPER_ PERL_DUMMY_MEASUREMENT_ +# endif +# ifdef USE_LOCALE_TELEPHONE +# define LC_TELEPHONE_INDEX_ PERL_DUMMY_PAPER_ + 1 +# define PERL_DUMMY_TELEPHONE_ LC_TELEPHONE_INDEX_ +# else +# define PERL_DUMMY_TELEPHONE_ PERL_DUMMY_PAPER_ +# endif +# ifdef USE_LOCALE_NAME +# define LC_NAME_INDEX_ PERL_DUMMY_TELEPHONE_ + 1 +# define PERL_DUMMY_NAME_ LC_NAME_INDEX_ +# else +# define PERL_DUMMY_NAME_ PERL_DUMMY_TELEPHONE_ +# endif +# ifdef USE_LOCALE_SYNTAX +# define LC_SYNTAX_INDEX_ PERL_DUMMY_NAME + 1 +# define PERL_DUMMY_SYNTAX_ LC_SYNTAX_INDEX_ +# else +# define PERL_DUMMY_SYNTAX_ PERL_DUMMY_NAME_ +# endif +# ifdef USE_LOCALE_TOD +# define LC_TOD_INDEX_ PERL_DUMMY_SYNTAX_ + 1 +# define PERL_DUMMY_TOD_ LC_TOD_INDEX_ +# else +# define PERL_DUMMY_TOD_ PERL_DUMMY_SYNTAX_ +# endif +# ifdef LC_ALL +# define LC_ALL_INDEX_ PERL_DUMMY_TOD_ + 1 +# 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 +# if defined(USE_ITHREADS) && ! 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))) +# 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 quite a few releases now. */ +# if defined(USE_LOCALE_THREADS) && ! defined(NO_THREAD_SAFE_LOCALE) +# if defined(USE_POSIX_2008_LOCALE) || (defined(WIN32) && defined(_MSC_VER)) # define USE_THREAD_SAFE_LOCALE # endif -# ifdef HAS_POSIX_2008_LOCALE -# define USE_POSIX_2008_LOCALE +# endif + +# include "perl_langinfo.h" /* Needed for _NL_LOCALE_NAME */ + +# ifdef USE_POSIX_2008_LOCALE +# if defined(HAS_QUERYLOCALE) \ + /* Use querylocale if has it, or has the glibc internal \ + * undocumented equivalent. */ \ + || ( defined(_NL_LOCALE_NAME) \ + /* And 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 \ + * item, so we can't use it */ \ + && ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME)) +# define USE_QUERYLOCALE +# endif +# endif + + /* 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 +# define USE_PL_CUR_LC_ALL +# endif + +# if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE) + + /* 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. */ +# define USE_PL_CUR_LC_ALL + + /* 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 _MSC_VER < 1900 +# 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 -/* 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 +/* end of makedef.pl logic duplication + * ========================================================================= */ + +#ifdef PERL_CORE + +/* Both typedefs are used in locale.c only, but defined here so that embed.fnc + * can generate the proper prototypes. */ + +typedef enum { + DONT_RECALC_LC_ALL, + YES_RECALC_LC_ALL, + + /* Used in tight loops through all sub-categories, where LC_ALL won't be + * fully known until all subcategories are handled. */ + RECALCULATE_LC_ALL_ON_FINAL_INTERATION +} recalc_lc_all_t; + + +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; + + #endif #include <setjmp.h> @@ -1080,7 +1431,9 @@ EXTERN_C int usleep(unsigned int); /* 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 @@ -1249,12 +1602,6 @@ Use L</UV> to declare variables of the maximum usable size on this platform. (((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 @@ -1294,12 +1641,38 @@ Use L</UV> to declare variables of the maximum usable size on this platform. #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) */ @@ -1361,21 +1734,23 @@ Use L</UV> to declare variables of the maximum usable size on this platform. # 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 @@ -1475,9 +1850,6 @@ Set the C<l> bytes starting at C<*d> to all zeroes. # endif # endif # ifdef I_NETDB -# ifdef NETWARE -# include<stdio.h> -# endif # include <netdb.h> # endif # ifndef ENOTSOCK @@ -1551,10 +1923,10 @@ was saved by C<dSAVE_ERRNO> or C<RESTORE_ERRNO>. #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 ) @@ -1647,15 +2019,15 @@ any magic. 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 @@ -1666,13 +2038,13 @@ any magic. *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 @@ -1683,10 +2055,10 @@ any magic. (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) @@ -1709,11 +2081,11 @@ Localize C<$_>. See L<perlguts/Localizing changes>. */ #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)" @@ -1945,7 +2317,7 @@ my_snprintf() #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) @@ -1962,9 +2334,16 @@ my_snprintf() /* 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__) @@ -2125,11 +2504,11 @@ typedef UVTYPE UV; #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. @@ -2188,7 +2567,7 @@ You probably want to be using L<C</INT2PTR>> instead. here, so no allowance is being made for mingw.org compilers at this stage. -- sisyphus January 2021 */ -#if defined(USE_QUADMATH) && defined(__MINGW64__) +#if (defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)) && defined(__MINGW64__) /* 64-bit build, mingw-w64 compiler only */ typedef NVTYPE NV __attribute__ ((aligned(8))); #else @@ -2253,7 +2632,7 @@ You probably want to be using L<C</INT2PTR>> instead. # 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 @@ -2332,7 +2711,7 @@ extern long double Perl_my_frexpl(long double x, int *e); # 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 @@ -2349,7 +2728,7 @@ extern long double Perl_my_frexpl(long double x, int *e); # 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) @@ -2378,7 +2757,7 @@ extern long double Perl_my_frexpl(long double x, int *e); # 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 @@ -2676,7 +3055,7 @@ extern long double Perl_my_frexpl(long double x, int *e); #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 @@ -2693,15 +3072,20 @@ extern long double Perl_my_frexpl(long double x, int *e); # elif defined(HAS_FINITEL) # define Perl_isfinitel(x) finitel(x) # elif defined(HAS_ISINFL) && defined(HAS_ISNANL) -# define Perl_isfinitel(x) !(isinfl(x)||isnanl(x)) +# 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 @@ -2718,7 +3102,7 @@ extern long double Perl_my_frexpl(long double x, int *e); #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) @@ -2727,6 +3111,17 @@ extern long double Perl_my_frexpl(long double x, int *e); #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 @@ -2759,6 +3154,7 @@ NV on this platform. If no such function with sufficient precision exists, the highest precision one available is used. =cut + */ /* @@ -2801,24 +3197,24 @@ the highest precision one available is used. /* =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. @@ -2894,6 +3290,7 @@ typedef struct xpvcv XPVCV; 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; @@ -3191,15 +3588,14 @@ typedef struct padname PADNAME; /* =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 -=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. +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. + +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 @@ -3336,9 +3732,7 @@ freeing any remaining Perl interpreters. * 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" @@ -3389,10 +3783,6 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) # include "win32.h" #endif -#ifdef NETWARE -# include "netware.h" -#endif - #define STATUS_UNIX PL_statusvalue #ifdef VMS # define STATUS_NATIVE PL_statusvalue_vms @@ -3417,8 +3807,8 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # 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 @@ -3443,25 +3833,25 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # 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) @@ -3476,23 +3866,23 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) * 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. @@ -3510,32 +3900,32 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # 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 @@ -3556,28 +3946,28 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # 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 */ @@ -3593,11 +3983,11 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) } \ } 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 @@ -3645,11 +4035,11 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) } 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 @@ -3678,11 +4068,19 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) # 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) @@ -3699,17 +4097,18 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) /* 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 @@ -3743,32 +4142,66 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) #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 @@ -3877,42 +4310,48 @@ intrinsic function, see its documents for more details. =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 @@ -3926,13 +4365,13 @@ intrinsic function, see its documents for more details. #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 @@ -3958,7 +4397,7 @@ void init_os_extras(void); UNION_ANY_DEFINITION; #else union any { - void* any_ptr; + void* any_ptr; SV* any_sv; SV** any_svp; GV* any_gv; @@ -3967,14 +4406,17 @@ union any { 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 @@ -3982,13 +4424,13 @@ typedef I32 (*filter_t) (pTHX_ int, SV *, int); #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) @@ -4049,7 +4491,7 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ #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 @@ -4064,13 +4506,25 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ /* 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" @@ -4103,8 +4557,7 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.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. */ @@ -4120,6 +4573,7 @@ typedef struct regnode_charclass_posixl regnode_charclass_posixl; 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 @@ -4173,7 +4627,7 @@ struct ptr_tbl { 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); } @@ -4192,7 +4646,7 @@ my_swap16(const U16 x) { 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 @@ -4216,9 +4670,9 @@ my_swap16(const U16 x) { # 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) @@ -4321,7 +4775,7 @@ equal zero. #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)) @@ -4344,11 +4798,11 @@ Gid_t getegid (void); #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 @@ -4366,7 +4820,7 @@ Gid_t getegid (void); #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 */ @@ -4405,6 +4859,7 @@ Gid_t getegid (void); # 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) @@ -4417,13 +4872,23 @@ Gid_t getegid (void); # 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_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_Lv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_L_FLAG, DEBUG_v_FLAG) # define DEBUG_yv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_y_FLAG, DEBUG_v_FLAG) #ifdef DEBUGGING @@ -4441,6 +4906,7 @@ Gid_t getegid (void); # 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_ @@ -4516,9 +4982,9 @@ Gid_t getegid (void); # define DEBUG__(t, a) \ STMT_START { \ - if (t) STMT_START { \ + if (t) { \ DEBUG_PRE_STMTS a; DEBUG_POST_STMTS \ - } STMT_END; \ + } \ } STMT_END # define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a) @@ -4571,6 +5037,7 @@ Gid_t getegid (void); # 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) @@ -4633,16 +5100,16 @@ Gid_t getegid (void); #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. @@ -4760,10 +5227,10 @@ EXTERN_C void PerlIO_teardown(void); # ifdef USE_ITHREADS # 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() @@ -4776,16 +5243,16 @@ EXTERN_C void PerlIO_teardown(void); #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) @@ -4795,7 +5262,7 @@ EXTERN_C void PerlIO_teardown(void); # define MALLOC_TERM #endif -#if defined(PERL_IMPLICIT_CONTEXT) +#if defined(MULTIPLICITY) struct perl_memory_debug_header; struct perl_memory_debug_header { @@ -4823,8 +5290,8 @@ 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 @@ -4833,17 +5300,17 @@ struct perl_memory_debug_header { #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) @@ -4860,7 +5327,7 @@ struct perl_memory_debug_header { # 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 @@ -4868,7 +5335,7 @@ struct perl_memory_debug_header { # 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 @@ -4898,12 +5365,12 @@ EXTERN_C char **environ; /* environment variables supplied via exec */ #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 @@ -4979,9 +5446,9 @@ Indices outside the range 0..31 result in (bad) undedefined behavior. 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 */ @@ -5051,73 +5518,38 @@ EXTCONST int PL_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[] = { @@ -5129,120 +5561,120 @@ 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 */ @@ -5251,7 +5683,6 @@ EXTCONST unsigned char PL_fold[]; 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 @@ -5260,19 +5691,20 @@ EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */ * 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[]; @@ -5286,102 +5718,112 @@ 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_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_CONTEXT - " PERL_IMPLICIT_CONTEXT" +# ifdef PERL_HASH_USE_SBOX32 + " PERL_HASH_USE_SBOX32" +# else + " PERL_HASH_NO_SBOX32" # endif # ifdef PERL_IMPLICIT_SYS - " PERL_IMPLICIT_SYS" + " PERL_IMPLICIT_SYS" # endif # ifdef PERL_MICRO - " PERL_MICRO" + " PERL_MICRO" # 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 @@ -5418,6 +5860,24 @@ EXTCONST char *const PL_phase_names[] = { 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 @@ -5468,8 +5928,7 @@ typedef enum { #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. @@ -5516,15 +5975,11 @@ typedef enum { #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 \ @@ -5544,7 +5999,7 @@ typedef enum { #ifndef PERL_SAWAMPERSAND # define PL_sawampersand \ - (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT) + (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT) #endif /* Used for debugvar magic */ @@ -5573,23 +6028,23 @@ struct perl_debug_pad { #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*); @@ -5599,10 +6054,38 @@ typedef void (*XSINIT_t) (pTHX); 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); @@ -5815,19 +6298,35 @@ 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 @@ -5837,9 +6336,17 @@ EXTCONST bool PL_valid_types_PVX[]; 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. @@ -5855,6 +6362,24 @@ EXTCONST bool PL_valid_types_NV_set[]; # 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 (UNLIKELY(PL_veto_switch_non_tTHX_context)) \ + Perl_switch_locale_context(); \ + } STMT_END +#else +# define PERL_SET_LOCALE_CONTEXT(i) NOOP +#endif + +/* 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 { PERL_SET_LOCALE_CONTEXT(i); } STMT_END + + #ifndef PERL_GET_CONTEXT # define PERL_GET_CONTEXT PERL_GET_INTERP #endif @@ -5924,35 +6449,51 @@ static U8 utf8d_C9[] = { /* 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[] = { @@ -6002,7 +6543,7 @@ 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) @@ -6352,16 +6893,16 @@ typedef struct am_table_short AMTS; #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 */ @@ -6476,14 +7017,14 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect. * 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(); \ } \ } STMT_END # else -# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE +# define CHECK_AND_WARN_PROBLEMATIC_LOCALE_ # endif @@ -6492,8 +7033,8 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect. * 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)); \ @@ -6501,8 +7042,8 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect. } 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", \ @@ -6528,207 +7069,99 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect. # 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_(m) Perl_locale_panic((m), __FILE__, __LINE__, errno) /* Locale/thread synchronization macros. */ -#if ! ( defined(USE_LOCALE) \ - && defined(USE_ITHREADS) \ - && ( ! defined(USE_THREAD_SAFE_LOCALE) \ - || ( defined(HAS_LOCALECONV) \ - && ( ! defined(HAS_LOCALECONV_L) \ - || defined(TS_W32_BROKEN_LOCALECONV))) \ - || ( defined(HAS_NL_LANGINFO) \ - && ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L)) \ - || (defined(HAS_MBLEN) && ! defined(HAS_MBRLEN)) \ - || (defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC)) \ - || (defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB)))) - -/* The whole expression just above was complemented, so here we have no need - * for thread synchronization, most likely it would be that this isn't a - * threaded build. */ +#if ! defined(USE_LOCALE) || ! defined(USE_LOCALE_THREADS) +# define LOCALE_LOCK_(cond) NOOP +# define LOCALE_UNLOCK_ NOOP # define LOCALE_INIT # define LOCALE_TERM -# define LC_NUMERIC_LOCK(cond) NOOP -# define LC_NUMERIC_UNLOCK NOOP -# define LOCALECONV_LOCK NOOP -# define LOCALECONV_UNLOCK NOOP -# define LOCALE_READ_LOCK NOOP -# define LOCALE_READ_UNLOCK NOOP -# define MBLEN_LOCK NOOP -# define MBLEN_UNLOCK NOOP -# define MBTOWC_LOCK NOOP -# define MBTOWC_UNLOCK NOOP -# define NL_LANGINFO_LOCK NOOP -# define NL_LANGINFO_UNLOCK NOOP -# define SETLOCALE_LOCK NOOP -# define SETLOCALE_UNLOCK NOOP -# define WCTOMB_LOCK NOOP -# define WCTOMB_UNLOCK NOOP -#else - - /* Here, we will need critical sections in locale handling, because one or - * more of the above conditions are true. This could be because the - * platform doesn't have thread-safe locales, or that at least one of the - * locale-dependent functions in the core isn't thread-safe. The latter - * case is generally because they return a pointer to a static buffer, which - * may be per-process instead of per-thread. There are supposedly - * re-entrant, safe versions for all of them Perl currently uses (which the - * #if above checks for), but most platforms don't have all the needed ones - * available, and the Posix standard doesn't require nl_langinfo_l() to be - * fully thread-safe, so a Configure probe was written. localeconv_l() is - * uncommon, and judging by bug reports on the web, some earlier library - * localeconv_l versions were broken, so perhaps a probe is in order for - * that, but it would be a pain to write. - * - * On non-thread-safe systems, some of the above functions are vulnerable to - * races should another thread get control and change the locale in the - * middle of their execution. - * - * We currently use a single mutex for all these cases. This solves both - * the problem of another thread changing the locale, and the buffer being - * overwritten (the code copies the results to a safe place before releasing - * the mutex). Ideally, for locale thread-safe platforms where the only - * issue is another thread clobbering the function's static buffer, there - * would be a separate mutex for each such buffer. Otherwise, things get - * locked that don't need to. But, it is not expected that any of these - * 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. */ -# define LOCALE_LOCK_ \ - 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_ \ - STMT_START { \ - DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ - "%s: %d: unlocking locale\n", __FILE__, __LINE__)); \ - MUTEX_UNLOCK(&PL_locale_mutex); \ - } STMT_END - /* We do define a different macro for each case; then if we want to have - * separate mutexes for some of them, the only changes needed are here. - * Define just the necessary macros. The compiler should then croak if the - * #ifdef's in the code are incorrect */ -# if defined(HAS_LOCALECONV) && ( ! defined(HAS_POSIX_2008_LOCALE) \ - || ! defined(HAS_LOCALECONV_L) \ - || defined(TS_W32_BROKEN_LOCALECONV)) -# define LOCALECONV_LOCK LOCALE_LOCK_ -# define LOCALECONV_UNLOCK LOCALE_UNLOCK_ -# endif -# if defined(HAS_NL_LANGINFO) && ( ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \ - || ! defined(HAS_POSIX_2008_LOCALE)) -# define NL_LANGINFO_LOCK LOCALE_LOCK_ -# define NL_LANGINFO_UNLOCK LOCALE_UNLOCK_ -# endif -# if defined(HAS_MBLEN) && ! defined(HAS_MBRLEN) -# define MBLEN_LOCK LOCALE_LOCK_ -# define MBLEN_UNLOCK LOCALE_UNLOCK_ -# endif -# if defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC) -# define MBTOWC_LOCK LOCALE_LOCK_ -# define MBTOWC_UNLOCK LOCALE_UNLOCK_ -# endif -# if defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB) -# define WCTOMB_LOCK LOCALE_LOCK_ -# define WCTOMB_UNLOCK LOCALE_UNLOCK_ -# endif -# if defined(USE_THREAD_SAFE_LOCALE) - /* On locale thread-safe systems, we don't need these workarounds */ -# define LOCALE_TERM_LC_NUMERIC_ NOOP -# define LOCALE_INIT_LC_NUMERIC_ NOOP -# define LC_NUMERIC_LOCK(cond) NOOP -# define LC_NUMERIC_UNLOCK NOOP -# define LOCALE_INIT_LC_NUMERIC_ NOOP -# define LOCALE_TERM_LC_NUMERIC_ NOOP - - /* There may be instance core where we this is invoked yet should do - * nothing. Rather than have #ifdef's around them, define it here */ -# define SETLOCALE_LOCK NOOP -# define SETLOCALE_UNLOCK NOOP -# else -# define SETLOCALE_LOCK LOCALE_LOCK_ -# define SETLOCALE_UNLOCK LOCALE_UNLOCK_ +#else /* Below: Threaded, and locales are supported */ - /* On platforms without per-thread locales, when another thread can switch - * our locale, we need another mutex 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 - * - * If LC_NUMERIC_LOCK is combined with one of the LOCKs above, calls to - * that and its corresponding unlock should be contained entirely within - * the locked portion of LC_NUMERIC. Those mutexes 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. */ -# 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; \ + CLANG_DIAG_IGNORE(-Wthread-safety) \ + if (LIKELY(PL_locale_mutex_depth <= 0)) { \ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ - "%s: %d: locking lc_numeric; depth=1\n", \ + "%s: %d: locking locale; depth=1\n", \ __FILE__, __LINE__)); \ + MUTEX_LOCK(&PL_locale_mutex); \ + PL_locale_mutex_depth = 1; \ } \ else { \ - PL_lc_numeric_mutex_depth++; \ + PL_locale_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)); \ + "%s: %d: avoided locking locale; new depth=%d\n", \ + __FILE__, __LINE__, PL_locale_mutex_depth)); \ 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; \ + if (LIKELY(PL_locale_mutex_depth == 1)) { \ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ - "%s: %d: unlocking lc_numeric; depth=0\n", \ + "%s: %d: unlocking locale; new depth=0\n", \ __FILE__, __LINE__)); \ + PL_locale_mutex_depth = 0; \ + MUTEX_UNLOCK(&PL_locale_mutex); \ + } \ + else if (PL_locale_mutex_depth <= 0) { \ + DEBUG_L(PerlIO_printf(Perl_debug_log, \ + "%s: %d: ignored attempt to unlock already" \ + " unlocked locale; depth unchanged at %d\n", \ + __FILE__, __LINE__, PL_locale_mutex_depth)); \ } \ else { \ - PL_lc_numeric_mutex_depth--; \ + PL_locale_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)); \ + "%s: %d: avoided unlocking locale; new depth=%d\n", \ + __FILE__, __LINE__, PL_locale_mutex_depth)); \ } \ - } STMT_END \ - CLANG_DIAG_RESTORE + } STMT_END + +# if defined(USE_THREADS) && ! defined(USE_THREAD_SAFE_LOCALE) -# define LOCALE_INIT_LC_NUMERIC_ MUTEX_INIT(&PL_lc_numeric_mutex) -# define LOCALE_TERM_LC_NUMERIC_ MUTEX_DESTROY(&PL_lc_numeric_mutex) + /* By definition, a thread-unsafe locale means we need a critical + * section. */ +# define SETLOCALE_LOCK LOCALE_LOCK_(0) +# define SETLOCALE_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 USE_POSIX_2008_LOCALE +# ifndef 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 { \ @@ -6740,22 +7173,131 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect. PL_C_locale_obj = (locale_t) NULL; \ } \ } STMT_END -# else -# define LOCALE_TERM_POSIX_2008_ NOOP # endif -# define LOCALE_INIT STMT_START { \ - MUTEX_INIT(&PL_locale_mutex); \ - LOCALE_INIT_LC_NUMERIC_; \ - } STMT_END - +# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex) # define LOCALE_TERM STMT_START { \ - MUTEX_DESTROY(&PL_locale_mutex); \ - LOCALE_TERM_LC_NUMERIC_; \ 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 SETLOCALE_LOCK +# define gwENVr_LOCALEr_LOCK \ + STMT_START { SETLOCALE_LOCK; ENV_READ_LOCK; } STMT_END +# define gwENVr_LOCALEr_UNLOCK \ + STMT_START { ENV_READ_UNLOCK; SETLOCALE_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 + * SETLOCALE_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 SETLOCALE_LOCK +# define SETLOCALE_LOCK NOOP +# define SETLOCALE_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 SETLOCALE_LOCK +#define LOCALE_READ_UNLOCK SETLOCALE_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 SETLOCALE_LOCK +# define LC_COLLATE_UNLOCK SETLOCALE_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 @@ -6912,12 +7454,12 @@ cannot have changed since the precalculation. * 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 \ @@ -6927,17 +7469,17 @@ cannot have changed since the precalculation. 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) { \ + if (NOT_IN_NUMERIC_UNDERLYING_) { \ Perl_set_numeric_underlying(aTHX); \ _restore_LC_NUMERIC_function \ = &Perl_set_numeric_standard; \ } \ } \ else { \ - if (_NOT_IN_NUMERIC_STANDARD) { \ + if (NOT_IN_NUMERIC_STANDARD_) { \ Perl_set_numeric_standard(aTHX); \ _restore_LC_NUMERIC_function \ = &Perl_set_numeric_underlying; \ @@ -6956,14 +7498,16 @@ cannot have changed since the precalculation. 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); \ + } \ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ "%s: %d: lc_numeric standard=%d\n", \ __FILE__, __LINE__, PL_numeric_standard)); \ @@ -6971,7 +7515,8 @@ cannot have changed since the precalculation. # define SET_NUMERIC_UNDERLYING() \ STMT_START { \ - if (_NOT_IN_NUMERIC_UNDERLYING) { \ + /*assert(PL_locale_mutex_depth > 0);*/ \ + if (NOT_IN_NUMERIC_UNDERLYING_) { \ Perl_set_numeric_underlying(aTHX); \ } \ } STMT_END @@ -6980,8 +7525,8 @@ cannot have changed since the precalculation. * 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); \ } \ @@ -6991,8 +7536,8 @@ cannot have changed since the precalculation. * 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) { \ + LC_NUMERIC_LOCK(NOT_IN_NUMERIC_UNDERLYING_); \ + if (NOT_IN_NUMERIC_UNDERLYING_) { \ Perl_set_numeric_underlying(aTHX); \ _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ } \ @@ -7058,7 +7603,7 @@ cannot have changed since the precalculation. #endif /* !USE_LOCALE_NUMERIC */ -#ifdef USE_ITHREADS +#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) @@ -7091,6 +7636,162 @@ cannot have changed since the precalculation. # 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 @@ -7106,29 +7807,14 @@ cannot have changed since the precalculation. START_EXTERN_C +# include "perlstatic.h" # include "inline.h" +# include "sv_inline.h" END_EXTERN_C #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 - -#define Atof my_atof - /* =for apidoc_section $numeric @@ -7165,7 +7851,7 @@ C<strtoul>. #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 @@ -7188,7 +7874,7 @@ C<strtoul>. * (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 @@ -7199,7 +7885,7 @@ C<strtoul>. #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 @@ -7225,12 +7911,12 @@ C<strtoul>. #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" @@ -7271,19 +7957,19 @@ C<strtoul>. # 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) @@ -7308,7 +7994,9 @@ C<strtoul>. * "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). @@ -7318,7 +8006,7 @@ C<strtoul>. * 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 @@ -7331,27 +8019,27 @@ C<strtoul>. * (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); @@ -7368,7 +8056,7 @@ C<strtoul>. # 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 @@ -7383,7 +8071,7 @@ C<strtoul>. # define aMY_CXT_ # define _aMY_CXT -#endif /* !defined(PERL_IMPLICIT_CONTEXT) */ +#endif /* !defined(MULTIPLICITY) */ #ifdef I_FCNTL # include <fcntl.h> @@ -7447,8 +8135,8 @@ EXTERN_C int flock(int fd, int op); #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 */ @@ -7540,18 +8228,18 @@ extern void moncontrol(int); #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 @@ -7601,7 +8289,7 @@ so no C<x++>. #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 @@ -7650,14 +8338,30 @@ Allows one ending \0 #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 @@ -7967,8 +8671,25 @@ GCC_DIAG_RESTORE_DECL; #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 @@ -8343,6 +9064,69 @@ END_EXTERN_C #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) /* |