emul

embed.fnc

@@ -3727,6 +3727,17 @@ p	|void	|dump_sv_child	|NN SV *sv
 CRTip	|unsigned int|variant_byte_number				\
 				|PERL_UINTMAX_T word
 #endif
+#if defined(EMULATE_THREAD_SAFE_LOCALES)
+Cp	|void	|category_lock_i|const unsigned int cat_index		\
+				|NN const char *file			\
+				|const line_t caller_line
+Cp	|void	|category_unlock_i					\
+				|const unsigned int cat_index		\
+				|NN const char *file			\
+				|const line_t caller_line
+Cip	|int	|posix_LC_foo_	|const int c				\
+				|const U8 classnum
+#endif
 #if defined(F_FREESP) && !defined(HAS_CHSIZE) && !defined(HAS_TRUNCATE)
 ARdp	|I32	|my_chsize	|int fd 				\
 				|Off_t length
@@ -4376,6 +4387,13 @@ RS	|char * |my_setlocale_debug_string_i				\
 				|NULLOK const char *retval		\
 				|const line_t line
 #   endif
+#   if   defined(EMULATE_THREAD_SAFE_LOCALES) || \
+       ( defined(USE_POSIX_2008_LOCALE) && !defined(USE_QUERYLOCALE) )
+S	|void	|update_PL_curlocales_i 				\
+				|const unsigned int index		\
+				|NN const char *new_locale		\
+				|const line_t caller_line
+#   endif
 #   if defined(HAS_NL_LANGINFO) || defined(HAS_NL_LANGINFO_L)
 S	|const char *|my_langinfo_i					\
 				|const nl_item item			\
@@ -4443,14 +4461,8 @@ S	|const char *|querylocale_2008_i				\
 				|const unsigned int index		\
 				|const line_t line
 S	|locale_t|use_curlocale_scratch
-#     if !defined(USE_QUERYLOCALE)
-S	|void	|update_PL_curlocales_i 				\
-				|const unsigned int index		\
-				|NN const char *new_locale		\
-				|const line_t caller_line
-#     endif
-#   elif  defined(USE_LOCALE_THREADS) && !defined(USE_THREAD_SAFE_LOCALE) && \
-         !defined(USE_THREAD_SAFE_LOCALE_EMULATION)
+#   elif !defined(EMULATE_THREAD_SAFE_LOCALES) && \
+          defined(USE_LOCALE_THREADS) && !defined(USE_THREAD_SAFE_LOCALE)
 S	|bool	|less_dicey_bool_setlocale_r				\
 				|const int cat				\
 				|NN const char *locale

embed.h

@@ -784,6 +784,11 @@
 # if !defined(EBCDIC)
 #   define variant_byte_number                  Perl_variant_byte_number
 # endif
+# if defined(EMULATE_THREAD_SAFE_LOCALES)
+#   define category_lock_i(a,b,c)               Perl_category_lock_i(aTHX_ a,b,c)
+#   define category_unlock_i(a,b,c)             Perl_category_unlock_i(aTHX_ a,b,c)
+#   define posix_LC_foo_(a,b)                   Perl_posix_LC_foo_(aTHX_ a,b)
+# endif
 # if defined(F_FREESP) && !defined(HAS_CHSIZE) && !defined(HAS_TRUNCATE)
 #   define my_chsize(a,b)                       Perl_my_chsize(aTHX_ a,b)
 # endif
@@ -1280,6 +1285,10 @@
 #       if defined(DEBUGGING)
 #         define my_setlocale_debug_string_i(a,b,c,d) S_my_setlocale_debug_string_i(aTHX_ a,b,c,d)
 #       endif
+#       if   defined(EMULATE_THREAD_SAFE_LOCALES) || \
+           ( defined(USE_POSIX_2008_LOCALE) && !defined(USE_QUERYLOCALE) )
+#         define update_PL_curlocales_i(a,b,c)  S_update_PL_curlocales_i(aTHX_ a,b,c)
+#       endif
 #       if defined(HAS_NL_LANGINFO) || defined(HAS_NL_LANGINFO_L)
 #         define my_langinfo_i(a,b,c,d,e,f)     S_my_langinfo_i(aTHX_ a,b,c,d,e,f)
 #       else
@@ -1311,12 +1320,8 @@
 #         define bool_setlocale_2008_i(a,b,c)   S_bool_setlocale_2008_i(aTHX_ a,b,c)
 #         define querylocale_2008_i(a,b)        S_querylocale_2008_i(aTHX_ a,b)
 #         define use_curlocale_scratch()        S_use_curlocale_scratch(aTHX)
-#         if !defined(USE_QUERYLOCALE)
-#           define update_PL_curlocales_i(a,b,c) S_update_PL_curlocales_i(aTHX_ a,b,c)
-#         endif
-#       elif  defined(USE_LOCALE_THREADS) &&     \
-             !defined(USE_THREAD_SAFE_LOCALE) && \
-             !defined(USE_THREAD_SAFE_LOCALE_EMULATION)
+#       elif !defined(EMULATE_THREAD_SAFE_LOCALES) && \
+              defined(USE_LOCALE_THREADS) && !defined(USE_THREAD_SAFE_LOCALE)
 #         define less_dicey_bool_setlocale_r(a,b) S_less_dicey_bool_setlocale_r(aTHX_ a,b)
 #         define less_dicey_setlocale_r(a,b)    S_less_dicey_setlocale_r(aTHX_ a,b)
 #       endif

handy.h

@@ -1556,9 +1556,17 @@ or casts
 
 #  define HIGHEST_REGCOMP_DOT_H_SYNC_ CC_VERTSPACE_
 
-/* The members of the third group below do not need to be coordinated with data
- * structures in regcomp.[ch] and regexec.c. */
-#  define CC_IDFIRST_                  16
+/* These three follow immediately after the final function that has a version
+ * defined by C, like isascii(), so they overlap with anything else.  They are
+ * used in the 'PL_libc_char_fcns' data structure, along with the ones above
+ * XXX
+ * them */
+# define CC_IDFIRST_  16
+# define CC_TOLOWER_  (CC_IDFIRST_ + 1)
+# define CC_TOUPPER_  (CC_TOLOWER_ + 1)
+
+/* The members of the fourth group below do not need to be coordinated with
+ * data structures in regcomp.[ch] and regexec.c. */
 #  define CC_CHARNAME_CONT_            17
 #  define CC_NONLATIN1_FOLD_           18
 #  define CC_NONLATIN1_SIMPLE_FOLD_    19
@@ -2026,7 +2034,7 @@ END_EXTERN_C
 #  define is_posix_XDIGIT(c)        isxdigit((U8) (c))
 #endif
 
-/* Below is the next level up, which currently expands to nothing more
+/* Below is the next level up, which on most platforms expands to nothing more
  * than the previous layer.  These are the macros to use if you really need
  * something whose input domain is a byte, and the locale isn't UTF-8; that is,
  * where you normally would have to use things like bare isalnum().
@@ -2038,7 +2046,13 @@ END_EXTERN_C
  * (Note, proper general operation of the bare libc functions requires you to
  * cast to U8.  These do that for you automatically.) */
 
+/* In this one circumstance, the macro is implemented with a lock; otherwise it
+ * expands to just the layer below */
+#ifdef EMULATE_THREAD_SAFE_LOCALES
+#  define WRAP_U8_LC_(c, classnum, posix)  posix_LC_foo_((c), (classnum))
+#else
 #  define WRAP_U8_LC_(c, classnum, posix)  posix(c)
+#endif
 
 #define isU8_ALPHANUMERIC_LC(c)                                                \
               WRAP_U8_LC_((c), CC_ALPHANUMERIC_, is_posix_ALPHANUMERIC)

inline.h

@@ -300,6 +300,49 @@ S_PerlEnv_putenv(pTHX_ char * str)
 
 #endif
 
+/* ------------------------------- handy.h ------------------------------- */
+
+#ifdef EMULATE_THREAD_SAFE_LOCALES
+
+PERL_STATIC_INLINE int
+Perl_posix_LC_foo_(pTHX_ const int c, const U8 classnum) {
+    int result;
+
+    LC_CTYPE_LOCK;
+
+    /* All calls to this (so far) are with a 'classnum' known at compile time,
+     * so the compiler should constant fold this down to a single assignment */
+    switch (classnum) {
+      case CC_ALPHANUMERIC_:result = (bool) is_posix_ALPHANUMERIC(c); break;
+      case CC_ALPHA_:       result = (bool) is_posix_ALPHA(c);        break;
+      case CC_ASCII_:       result = (bool) is_posix_ASCII(c);        break;
+      case CC_BLANK_:       result = (bool) is_posix_BLANK(c);        break;
+      case CC_CASED_:       result = (bool) is_posix_CASED(c);        break;
+      case CC_CNTRL_:       result = (bool) is_posix_CNTRL(c);        break;
+      case CC_DIGIT_:       result = (bool) is_posix_DIGIT(c);        break;
+      case CC_GRAPH_:       result = (bool) is_posix_GRAPH(c);        break;
+      case CC_LOWER_:       result = (bool) is_posix_LOWER(c);        break;
+      case CC_PRINT_:       result = (bool) is_posix_PRINT(c);        break;
+      case CC_PUNCT_:       result = (bool) is_posix_PUNCT(c);        break;
+      case CC_SPACE_:       result = (bool) is_posix_SPACE(c);        break;
+      case CC_UPPER_:       result = (bool) is_posix_UPPER(c);        break;
+      case CC_WORDCHAR_:    result = (bool) is_posix_WORDCHAR(c);     break;
+      case CC_XDIGIT_:      result = (bool) is_posix_XDIGIT(c);       break;
+      case CC_IDFIRST_:     result = (bool) is_posix_IDFIRST(c);      break;
+      case CC_TOLOWER_:     result =        to_posix_LOWER(c);        break;
+      case CC_TOUPPER_:     result =        to_posix_UPPER(c);        break;
+
+      default:
+        LC_CTYPE_UNLOCK;
+        locale_panic_(Perl_form(aTHX_ "Unknown charclass %d", classnum));
+    }
+
+    LC_CTYPE_UNLOCK;
+    return result;
+}
+
+#endif
+
 /* ------------------------------- mg.h ------------------------------- */
 
 #if defined(PERL_CORE) || defined(PERL_EXT)

intrpvar.h

@@ -757,7 +757,14 @@ PERLVARI(I, cur_locale_obj, locale_t, NULL)
  * is almost always toggled into the C locale, and the locale it nominally is
  * is stored as PL_numeric_name. */
 PERLVARA(I, curlocales, LOCALE_CATEGORIES_COUNT_ + 1, const char *)
+#endif
+#ifdef EMULATE_THREAD_SAFE_LOCALES
+PERLVARA(I, restore_locale, LOCALE_CATEGORIES_COUNT_, const char *)
+PERLVARA(I, restore_locale_depth, LOCALE_CATEGORIES_COUNT_, Size_t)
+#endif
 
+#if defined(USE_LOCALE) && ! defined(USE_THREAD_SAFE_LOCALE)
+PERLVARI(I, perl_controls_locale, bool, true)
 #endif
 #ifdef USE_PL_CUR_LC_ALL
 PERLVARI(I, cur_LC_ALL, const char *, NULL)