locale.c: Mitigate unsafe threaded locales

This a new set of macros and functions to do locale changing and
querying for platforms where perl is compiled with threads, but the
platform doesn't have thread-safe locale handling.

All it does is:

1) The return of setlocale() is always safely saved in a per-thread
buffer, and
2) setlocale() is protected by a mutex from other threads which are
using perl's locale functions.

This isn't much, but it might be enough to get some programs to work on
such platforms which rarely change or query the locale.

embed.fnc

@@ -3310,6 +3310,21 @@ S	|const char*|update_PL_curlocales_i|const unsigned int index	\
 				    |NN const char * new_locale		\
 				    |int recalc_LC_ALL
 S	|const char *|find_locale_from_environment|const unsigned int index
+#    else
+#      if   defined(USE_LOCALE_THREADS)					\
+       && ! defined(USE_THREAD_SAFE_LOCALE)				\
+       && ! defined(USE_THREAD_SAFE_LOCALE_EMULATION)
+S	|const char *|less_dicey_setlocale_r				\
+				|const int category			\
+				|NULLOK const char * locale
+S	|bool	|less_dicey_bool_setlocale_r				\
+				|const int cat				\
+				|NN const char * locale
+S	|void	|less_dicey_void_setlocale_i				\
+				|const unsigned cat_index		\
+				|NN const char * locale			\
+				|const line_t line
+#      endif
 #    endif
 #    ifdef WIN32
 S	|char*	|win32_setlocale|int category|NULLOK const char* locale

embed.h

@@ -1526,6 +1526,17 @@
 #  if !(defined(PERL_USE_3ARG_SIGHANDLER))
 #define sighandler		Perl_sighandler
 #  endif
+#  if !(defined(USE_POSIX_2008_LOCALE))
+#    if defined(PERL_IN_LOCALE_C)
+#      if defined(USE_LOCALE)
+#        if defined(USE_LOCALE_THREADS)					       && ! defined(USE_THREAD_SAFE_LOCALE)				       && ! defined(USE_THREAD_SAFE_LOCALE_EMULATION)
+#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)
+#define less_dicey_void_setlocale_i(a,b,c)	S_less_dicey_void_setlocale_i(aTHX_ a,b,c)
+#        endif
+#      endif
+#    endif
+#  endif
 #  if !(defined(USE_QUERYLOCALE))
 #    if defined(PERL_IN_LOCALE_C)
 #      if defined(USE_LOCALE)

locale.c

@@ -77,6 +77,31 @@
  * be in the underlying locale.  There is a bunch of code to accomplish this,
  * and to allow easy switches from one state to the other.
  *
+ * In addition, the setlocale equivalents have versions for the return context,
+ * 'void' and 'bool', besides the full return value.  This can present
+ * opportunities for avoiding work.  We don't have to necessarily create a safe
+ * copy to return if no return is desired.
+ *
+ * There are 3.5 major implementations here; which one chosen depends on what
+ * the platform has available, and Configuration options.
+ *
+ * 1) Raw my_setlocale().  Here the layer adds nothing.  This is used for
+ *    unthreaded perls, and when the API for safe locale threading is identical
+ *    to the unsafe API (Windows, currently).
+ *
+ * 2) A minimal layer that makes my_setlocale() uninterruptible and returns a
+ *    per-thread/per-category value.
+ *
+ * 3a and 3b) A layer that implements POSIX 2008 thread-safe locale handling,
+ *    mapping the setlocale() API to them.  This automatically makes almost all
+ *    code thread-safe without need for changes.  This layer is chosen on
+ *    threaded perls when the platform supports the POSIX 2008 functions, and
+ *    when there is no manual override in Configure.
+ *
+ *    3a) is when the platform has a reliable querylocale() function or
+ *        equivalent that is selected to be used.
+ *    3b) is when we have to emulate that functionality.
+ *
  * z/OS (os390) is an outlier.  Locales really don't work under threads when
  * either the radix character isn't a dot, or attempts are made to change
  * locales after the first thread is created.  The reason is that IBM has made
@@ -504,7 +529,8 @@ Perl_locale_panic(const char * msg,
  * the code in this file in spite of the disparate underlying implementations.
  * */
 
-#ifndef USE_POSIX_2008_LOCALE
+#if    (! defined(USE_LOCALE_THREADS) && ! defined(USE_POSIX_2008_LOCALE))    \
+    || (  defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE))
 
 /* For non-threaded perls (which we are not to use the POSIX 2008 API on), or a
  * thread-safe Windows one in which threading is invisible to us, the added
@@ -537,7 +563,88 @@ Perl_locale_panic(const char * msg,
 #  define querylocale_c(cat)        querylocale_r(cat)
 #  define querylocale_i(i)          querylocale_c(categories[i])
 
-#else   /* Below uses POSIX 2008 */
+#elif   defined(USE_LOCALE_THREADS)                 \
+   && ! defined(USE_THREAD_SAFE_LOCALE)
+
+   /* Here, there are threads, and there is no support for thread-safe
+    * operation.  This is a dangerous situation, which perl is documented as
+    * not supporting, but it arises in practice.  We can do a modicum of
+    * automatic mitigation by making sure there is a per-thread return from
+    * setlocale(), and that a mutex protects it from races */
+STATIC const char *
+S_less_dicey_setlocale_r(pTHX_ const int category, const char * locale)
+{
+    const char * retval;
+
+    PERL_ARGS_ASSERT_LESS_DICEY_SETLOCALE_R;
+
+    PORCELAIN_SETLOCALE_LOCK;
+
+    retval = stdized_setlocale(category, locale);
+
+    /* We reuse PL_stdize_locale_buf as it doesn't conflict, but the call may
+     * already have used it, in which case we don't have to do anything further
+     * */
+    if (retval != PL_stdize_locale_buf) {
+        retval = save_to_buffer(retval,
+                                &PL_stdize_locale_buf, &PL_stdize_locale_bufsize);
+    }
+
+    PORCELAIN_SETLOCALE_UNLOCK;
+
+    return retval;
+}
+
+#  define setlocale_r(cat, locale)  less_dicey_setlocale_r(cat, locale)
+#  define setlocale_c(cat, locale)             setlocale_r(cat, locale)
+#  define setlocale_i(i, locale)     setlocale_r(categories[i], locale)
+
+#  define querylocale_r(cat)             setlocale_r(cat, NULL)
+#  define querylocale_c(cat)             querylocale_r(cat)
+#  define querylocale_i(i)               querylocale_r(categories[i])
+
+STATIC void
+S_less_dicey_void_setlocale_i(pTHX_ const unsigned cat_index,
+                                    const char * locale,
+                                    const line_t line)
+{
+    PERL_ARGS_ASSERT_LESS_DICEY_VOID_SETLOCALE_I;
+
+    PORCELAIN_SETLOCALE_LOCK;
+    if (! porcelain_setlocale(categories[cat_index], locale)) {
+        PORCELAIN_SETLOCALE_UNLOCK;
+        setlocale_failure_panic_i(cat_index, NULL, locale, __LINE__, line);
+    }
+    PORCELAIN_SETLOCALE_UNLOCK;
+}
+
+#  define void_setlocale_i(i, locale)                                       \
+                          less_dicey_void_setlocale_i(i, locale, __LINE__)
+#  define void_setlocale_c(cat, locale)                                     \
+                          void_setlocale_i(cat##_INDEX_, locale)
+#  define void_setlocale_r(cat, locale)                                     \
+       void_setlocale_i(get_category_index(cat, locale), locale)
+
+STATIC bool
+S_less_dicey_bool_setlocale_r(pTHX_ const int cat, const char * locale)
+{
+    bool retval;
+
+    PERL_ARGS_ASSERT_LESS_DICEY_BOOL_SETLOCALE_R;
+
+    PORCELAIN_SETLOCALE_LOCK;
+    retval = cBOOL(porcelain_setlocale(cat, locale));
+    PORCELAIN_SETLOCALE_UNLOCK;
+
+    return retval;
+}
+
+#  define bool_setlocale_r(cat, locale)                                 \
+                               less_dicey_bool_setlocale_r(cat, locale)
+#  define bool_setlocale_i(i, locale)                                   \
+                                bool_setlocale_r(categories[i], locale)
+#  define bool_setlocale_c(cat, locale) bool_setlocale_r(cat, locale)
+#else
 
 /* Here, there is a completely different API to get thread-safe locales.  We
  * emulate the setlocale() API with our own function(s).  setlocale categories,

proto.h

@@ -4263,6 +4263,22 @@ PERL_CALLCONV Signal_t	Perl_csighandler(int sig);
 PERL_CALLCONV Signal_t	Perl_sighandler(int sig);
 #define PERL_ARGS_ASSERT_SIGHANDLER
 #endif
+#if !(defined(USE_POSIX_2008_LOCALE))
+#  if defined(PERL_IN_LOCALE_C)
+#    if defined(USE_LOCALE)
+#      if defined(USE_LOCALE_THREADS)					       && ! defined(USE_THREAD_SAFE_LOCALE)				       && ! defined(USE_THREAD_SAFE_LOCALE_EMULATION)
+STATIC bool	S_less_dicey_bool_setlocale_r(pTHX_ const int cat, const char * locale);
+#define PERL_ARGS_ASSERT_LESS_DICEY_BOOL_SETLOCALE_R	\
+	assert(locale)
+STATIC const char *	S_less_dicey_setlocale_r(pTHX_ const int category, const char * locale);
+#define PERL_ARGS_ASSERT_LESS_DICEY_SETLOCALE_R
+STATIC void	S_less_dicey_void_setlocale_i(pTHX_ const unsigned cat_index, const char * locale, const line_t line);
+#define PERL_ARGS_ASSERT_LESS_DICEY_VOID_SETLOCALE_I	\
+	assert(locale)
+#      endif
+#    endif
+#  endif
+#endif
 #if !(defined(USE_QUERYLOCALE))
 #  if defined(PERL_IN_LOCALE_C)
 #    if defined(USE_LOCALE)