locale.c: Revamp my_strerror() for thread-safeness

This commit is the first step in making locale handling thread-safe.

[perl #127708] was solved for 5.24 by adding a mutex in this function.
That bug was caused by the code changing the locale even if the calling
program is not consciously using locales.

Posix 2008 introduced thread-safe locale functions.  This commit changes
this function to use them if the perl is threaded and the platform has
them available.  This means that the mutex is avoided on modern
platforms.

It restructures the function to return a mortal copy of the error
message.  This is a step towards making the function completely thread
safe.  Right now, as documented, if you do 'use locale', locale handling
isn't thread-safe.

A global C locale object is created and used here if necessary.  It is
destroyed at the end of the program.

Note that some platforms have a strerror_r(), which is automatically
used instead of strerror() if available.  It differs form straight
strerror() by taking a buffer to place the returned string, so the
return does not point to internal static storage.  One could test for
the existence of this and avoid the mortal copy.

7 files changed, 118 insertions, 24 deletions

diff --git a/embedvar.h b/embedvar.h
index ec0b7b182d..cf4912ca58 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -365,6 +365,8 @@
 
 #if defined(PERL_GLOBAL_STRUCT)
 
+#define PL_C_locale_obj		(my_vars->GC_locale_obj)
+#define PL_GC_locale_obj	(my_vars->GC_locale_obj)
 #define PL_appctx		(my_vars->Gappctx)
 #define PL_Gappctx		(my_vars->Gappctx)
 #define PL_check		(my_vars->Gcheck)
diff --git a/locale.c b/locale.c
index fb3e676308..b0bca5e458 100644
--- a/locale.c
+++ b/locale.c
@@ -2464,47 +2464,94 @@ Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
 }
 
 char *
-Perl_my_strerror(pTHX_ const int errnum) {
+Perl_my_strerror(pTHX_ const int errnum)
+{
+    /* Returns a mortalized copy of the text of the error message associated
+     * with 'errnum'.  It uses the current locale's text unless the platform
+     * doesn't have the LC_MESSAGES category or we are not being called from
+     * within the scope of 'use locale'.  In the former case, it uses whatever
+     * strerror returns; in the latter case it uses the text from the C locale.
+     *
+     * The function just calls strerror(), but temporarily switches, if needed,
+     * to the C locale */
+
+    char *errstr;
+
+#ifdef USE_LOCALE_MESSAGES  /* If platform doesn't have messages category, we
+                               don't do any switching to the C locale; we just
+                               use whatever strerror() returns */
+    const bool within_locale_scope = IN_LC(LC_MESSAGES);
+
     dVAR;
 
-    /* Uses C locale for the error text unless within scope of 'use locale' for
-     * LC_MESSAGES */
+#  ifdef USE_THREAD_SAFE_LOCALE
+    locale_t save_locale;
+#  else
+    char * save_locale;
+    bool locale_is_C;
 
-#ifdef USE_LOCALE_MESSAGES
-    if (! IN_LC(LC_MESSAGES)) {
-        char * save_locale;
+    /* We have a critical section to prevent another thread from changing the
+     * locale out from under us (or zapping the buffer returned from
+     * setlocale() ) */
+    LOCALE_LOCK;
+
+#  endif
+
+    if (! within_locale_scope) {
 
-        /* We have a critical section to prevent another thread from changing
-         * the locale out from under us (or zapping the buffer returned from
-         * setlocale() ) */
-        LOCALE_LOCK;
+#  ifdef USE_THREAD_SAFE_LOCALE /* Use the thread-safe locale functions */
+
+        save_locale = uselocale(PL_C_locale_obj);
+
+#  else    /* Not thread-safe build */
 
         save_locale = setlocale(LC_MESSAGES, NULL);
-        if (! isNAME_C_OR_POSIX(save_locale)) {
-            char *errstr;
+        locale_is_C = isNAME_C_OR_POSIX(save_locale);
 
-            /* The next setlocale likely will zap this, so create a copy */
-            save_locale = savepv(save_locale);
+        /* Switch to the C locale if not already in it */
+        if (! locale_is_C) {
 
+            /* The setlocale() just below likely will zap 'save_locale', so
+             * create a copy.  */
+            save_locale = savepv(save_locale);
             setlocale(LC_MESSAGES, "C");
+        }
 
-            /* This points to the static space in Strerror, with all its
-             * limitations */
-            errstr = Strerror(errnum);
+#  endif
 
-            setlocale(LC_MESSAGES, save_locale);
-            Safefree(save_locale);
+    }   /* end of ! within_locale_scope */
 
-            LOCALE_UNLOCK;
+#endif
 
-            return errstr;
-        }
+    errstr = Strerror(errnum);
+    if (errstr) {
+        errstr = savepv(errstr);
+        SAVEFREEPV(errstr);
+    }
+
+#ifdef USE_LOCALE_MESSAGES
+
+    if (! within_locale_scope) {
 
-        LOCALE_UNLOCK;
+#  ifdef USE_THREAD_SAFE_LOCALE
+
+        uselocale(save_locale);
     }
+
+#  else
+
+        if (! locale_is_C) {
+            setlocale(LC_MESSAGES, save_locale);
+            Safefree(save_locale);
+        }
+    }
+
+    LOCALE_UNLOCK;
+
+#  endif
 #endif
 
-    return Strerror(errnum);
+    return errstr;
 }
 
 /*
diff --git a/makedef.pl b/makedef.pl
index 956914e7ed..80723ca9ff 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -398,6 +398,14 @@ unless ($define{'USE_ITHREADS'}) {
 			 );
 }
 
+unless (   $define{'USE_ITHREADS'}
+        && $define{'HAS_NEWLOCALE'})
+{
+    ++$skip{$_} foreach qw(
+        PL_C_locale_obj
+    );
+}
+
 unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
     ++$skip{$_} foreach qw(
 		    PL_my_cxt_index
diff --git a/perl.c b/perl.c
index 98bfdcfd52..ec73f15bd5 100644
--- a/perl.c
+++ b/perl.c
@@ -420,6 +420,9 @@ perl_construct(pTHXx)
     PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
     PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
     PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
+#ifdef USE_THREAD_SAFE_LOCALE
+    PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
+#endif
 
     ENTER;
 }
@@ -1124,6 +1127,16 @@ perl_destruct(pTHXx)
     PL_SB_invlist = NULL;
     PL_WB_invlist = NULL;
 
+#ifdef USE_THREAD_SAFE_LOCALE
+    if (PL_C_locale_obj) {
+        /* Make sure we aren't using the locale space we are about to free */
+        uselocale(LC_GLOBAL_LOCALE);
+
+        freelocale(PL_C_locale_obj);
+        PL_C_locale_obj = (locale_t) NULL;
+    }
+#endif
+
     if (!specialWARN(PL_compiling.cop_warnings))
 	PerlMemShared_free(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = NULL;
diff --git a/perl.h b/perl.h
index 2735b524b6..218f94c74d 100644
--- a/perl.h
+++ b/perl.h
@@ -729,6 +729,10 @@
 #   include <locale.h>
 #endif
 
+#ifdef I_XLOCALE
+#   include <xlocale.h>
+#endif
+
 #if !defined(NO_LOCALE) && defined(HAS_SETLOCALE)
 #   define USE_LOCALE
 #   define HAS_SKIP_LOCALE_INIT /* Solely for XS code to test for this
@@ -6053,6 +6057,20 @@ typedef struct am_table_short AMTS;
 
 #   endif   /* PERL_CORE or PERL_IN_XSUB_RE */
 
+#if      defined(USE_ITHREADS)              \
+    &&   defined(HAS_NEWLOCALE)             \
+    &&   defined(LC_ALL_MASK)               \
+    &&   defined(HAS_FREELOCALE)            \
+    &&   defined(HAS_USELOCALE)             \
+    && ! defined(NO_THREAD_SAFE_USELOCALE)
+
+    /* The code is written for simplicity to assume that any platform advanced
+     * enough to have the Posix 2008 locale functions has LC_ALL.  The test
+     * above makes sure that assumption is valid */
+
+#   define USE_THREAD_SAFE_LOCALE
+#endif
+
 #else   /* No locale usage */
 #   define LOCALE_INIT
 #   define LOCALE_TERM
diff --git a/perlapi.h b/perlapi.h
index 7aa445578e..960983d090 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -99,6 +99,8 @@ END_EXTERN_C
 
 #else	/* !PERL_CORE */
 
+#undef  PL_C_locale_obj
+#define PL_C_locale_obj		(*Perl_GC_locale_obj_ptr(NULL))
 #undef  PL_appctx
 #define PL_appctx		(*Perl_Gappctx_ptr(NULL))
 #undef  PL_check
diff --git a/perlvars.h b/perlvars.h
index 5466294963..89e2e1eb52 100644
--- a/perlvars.h
+++ b/perlvars.h
@@ -101,6 +101,10 @@ PERLVARI(G, mmap_page_size, IV, 0)
 PERLVAR(G, hints_mutex, perl_mutex)    /* Mutex for refcounted he refcounting */
 PERLVAR(G, locale_mutex, perl_mutex)   /* Mutex for setlocale() changing */
 
+#   ifdef HAS_NEWLOCALE
+PERLVAR(G, C_locale_obj, locale_t)
+#   endif
+
 #endif
 
 #ifdef DEBUGGING