This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Win32 from version 0.54 to 0.56
[perl5.git] / locale.c
index 5f68a8e..de171fc 100644 (file)
--- a/locale.c
+++ b/locale.c
  * the desired behavior of those functions at the moment.  And, LC_MESSAGES is
  * switched to the C locale for outputting the message unless within the scope
  * of 'use locale'.
+ *
+ * This code now has multi-thread-safe locale handling on systems that support
+ * that.  This is completely transparent to most XS code.  On earlier systems,
+ * it would be possible to emulate thread-safe locales, but this likely would
+ * involve a lot of locale switching, and would require XS code changes.
+ * Macros could be written so that the code wouldn't have to know which type of
+ * system is being used.  It's unlikely that we would ever do that, since most
+ * modern systems support thread-safe locales, but there was code written to
+ * this end, and is retained, #ifdef'd out.
  */
 
 #include "EXTERN.h"
 #ifdef I_WCHAR
 #  include <wchar.h>
 #endif
+#ifdef I_WCTYPE
+#  include <wctype.h>
+#endif
 
 /* If the environment says to, we can output debugging information during
  * initialization.  This is done before option parsing, and before any thread
  * creation, so can be a file-level static */
-#if ! defined(DEBUGGING) || defined(PERL_GLOBAL_STRUCT)
+#if ! defined(DEBUGGING)
 #  define debug_initialization 0
 #  define DEBUG_INITIALIZATION_set(v)
 #else
@@ -130,21 +142,21 @@ S_stdize_locale(pTHX_ char *locs)
     PERL_ARGS_ASSERT_STDIZE_LOCALE;
 
     if (s) {
-       const char * const t = strchr(s, '.');
-       okay = FALSE;
-       if (t) {
-           const char * const u = strchr(t, '\n');
-           if (u && (u[1] == 0)) {
-               const STRLEN len = u - s;
-               Move(s + 1, locs, len, char);
-               locs[len] = 0;
-               okay = TRUE;
-           }
-       }
+        const char * const t = strchr(s, '.');
+        okay = FALSE;
+        if (t) {
+            const char * const u = strchr(t, '\n');
+            if (u && (u[1] == 0)) {
+                const STRLEN len = u - s;
+                Move(s + 1, locs, len, char);
+                locs[len] = 0;
+                okay = TRUE;
+            }
+        }
     }
 
     if (!okay)
-       Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
+        Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
 
     return locs;
 }
@@ -188,6 +200,12 @@ const int categories[] = {
 #    ifdef USE_LOCALE_TELEPHONE
                              LC_TELEPHONE,
 #    endif
+#    ifdef USE_LOCALE_SYNTAX
+                             LC_SYNTAX,
+#    endif
+#    ifdef USE_LOCALE_TOD
+                             LC_TOD,
+#    endif
 #    ifdef LC_ALL
                              LC_ALL,
 #    endif
@@ -198,7 +216,7 @@ const int categories[] = {
 
 /* The top-most real element is LC_ALL */
 
-const char * category_names[] = {
+const char * const category_names[] = {
 
 #    ifdef USE_LOCALE_NUMERIC
                                  "LC_NUMERIC",
@@ -233,6 +251,12 @@ const char * category_names[] = {
 #    ifdef USE_LOCALE_TELEPHONE
                                  "LC_TELEPHONE",
 #    endif
+#    ifdef USE_LOCALE_SYNTAX
+                                 "LC_SYNTAX",
+#    endif
+#    ifdef USE_LOCALE_TOD
+                                 "LC_TOD",
+#    endif
 #    ifdef LC_ALL
                                  "LC_ALL",
 #    endif
@@ -322,7 +346,7 @@ S_category_name(const int category)
 #    define LC_COLLATE_INDEX            _DUMMY_CTYPE + 1
 #    define _DUMMY_COLLATE              LC_COLLATE_INDEX
 #  else
-#    define _DUMMY_COLLATE              _DUMMY_COLLATE
+#    define _DUMMY_COLLATE              _DUMMY_CTYPE
 #  endif
 #  ifdef USE_LOCALE_TIME
 #    define LC_TIME_INDEX               _DUMMY_COLLATE + 1
@@ -372,22 +396,831 @@ S_category_name(const int category)
 #  else
 #    define _DUMMY_TELEPHONE            _DUMMY_PAPER
 #  endif
+#  ifdef USE_LOCALE_SYNTAX
+#    define LC_SYNTAX_INDEX             _DUMMY_TELEPHONE + 1
+#    define _DUMMY_SYNTAX               LC_SYNTAX_INDEX
+#  else
+#    define _DUMMY_SYNTAX               _DUMMY_TELEPHONE
+#  endif
+#  ifdef USE_LOCALE_TOD
+#    define LC_TOD_INDEX                _DUMMY_SYNTAX + 1
+#    define _DUMMY_TOD                  LC_TOD_INDEX
+#  else
+#    define _DUMMY_TOD                  _DUMMY_SYNTAX
+#  endif
 #  ifdef LC_ALL
-#    define LC_ALL_INDEX                _DUMMY_TELEPHONE + 1
+#    define LC_ALL_INDEX                _DUMMY_TOD + 1
+#  endif
+#endif /* ifdef USE_LOCALE */
+
+/* Windows requres a customized base-level setlocale() */
+#ifdef WIN32
+#  define my_setlocale(cat, locale) win32_setlocale(cat, locale)
+#else
+#  define my_setlocale(cat, locale) setlocale(cat, locale)
+#endif
+
+#ifndef USE_POSIX_2008_LOCALE
+
+/* "do_setlocale_c" is intended to be called when the category is a constant
+ * known at compile time; "do_setlocale_r", not known until run time  */
+#  define do_setlocale_c(cat, locale) my_setlocale(cat, locale)
+#  define do_setlocale_r(cat, locale) my_setlocale(cat, locale)
+#  define FIX_GLIBC_LC_MESSAGES_BUG(i)
+
+#else   /* Below uses POSIX 2008 */
+
+/* We emulate setlocale with our own function.  LC_foo is not valid for the
+ * POSIX 2008 functions.  Instead LC_foo_MASK is used, which we use an array
+ * lookup to convert to.  At compile time we have defined LC_foo_INDEX as the
+ * proper offset into the array 'category_masks[]'.  At runtime, we have to
+ * search through the array (as the actual numbers may not be small contiguous
+ * positive integers which would lend themselves to array lookup). */
+#  define do_setlocale_c(cat, locale)                                       \
+                        emulate_setlocale(cat, locale, cat ## _INDEX, TRUE)
+#  define do_setlocale_r(cat, locale) emulate_setlocale(cat, locale, 0, FALSE)
+
+#  if ! defined(__GLIBC__) || ! defined(USE_LOCALE_MESSAGES)
+
+#    define FIX_GLIBC_LC_MESSAGES_BUG(i)
+
+#  else /* Invalidate glibc cache of loaded translations, see [perl #134264] */
+
+#    include <libintl.h>
+#    define FIX_GLIBC_LC_MESSAGES_BUG(i)                                        \
+        STMT_START {                                                        \
+            if ((i) == LC_MESSAGES_INDEX) {                                 \
+                textdomain(textdomain(NULL));                               \
+            }                                                               \
+        } STMT_END
+
+#  endif
+
+/* A third array, parallel to the ones above to map from category to its
+ * equivalent mask */
+const int category_masks[] = {
+#  ifdef USE_LOCALE_NUMERIC
+                                LC_NUMERIC_MASK,
+#  endif
+#  ifdef USE_LOCALE_CTYPE
+                                LC_CTYPE_MASK,
+#  endif
+#  ifdef USE_LOCALE_COLLATE
+                                LC_COLLATE_MASK,
+#  endif
+#  ifdef USE_LOCALE_TIME
+                                LC_TIME_MASK,
+#  endif
+#  ifdef USE_LOCALE_MESSAGES
+                                LC_MESSAGES_MASK,
+#  endif
+#  ifdef USE_LOCALE_MONETARY
+                                LC_MONETARY_MASK,
+#  endif
+#  ifdef USE_LOCALE_ADDRESS
+                                LC_ADDRESS_MASK,
+#  endif
+#  ifdef USE_LOCALE_IDENTIFICATION
+                                LC_IDENTIFICATION_MASK,
+#  endif
+#  ifdef USE_LOCALE_MEASUREMENT
+                                LC_MEASUREMENT_MASK,
+#  endif
+#  ifdef USE_LOCALE_PAPER
+                                LC_PAPER_MASK,
+#  endif
+#  ifdef USE_LOCALE_TELEPHONE
+                                LC_TELEPHONE_MASK,
+#  endif
+#  ifdef USE_LOCALE_SYNTAX
+                                LC_SYNTAX_MASK,
+#  endif
+#  ifdef USE_LOCALE_TOD
+                                LC_TOD_MASK,
+#  endif
+                                /* LC_ALL can't be turned off by a Configure
+                                 * option, and in Posix 2008, should always be
+                                 * here, so compile it in unconditionally.
+                                 * This could catch some glitches at compile
+                                 * time */
+                                LC_ALL_MASK
+                            };
+
+STATIC const char *
+S_emulate_setlocale(const int category,
+                    const char * locale,
+                    unsigned int index,
+                    const bool is_index_valid
+                   )
+{
+    /* This function effectively performs a setlocale() on just the current
+     * thread; thus it is thread-safe.  It does this by using the POSIX 2008
+     * locale functions to emulate the behavior of setlocale().  Similar to
+     * regular setlocale(), the return from this function points to memory that
+     * can be overwritten by other system calls, so needs to be copied
+     * immediately if you need to retain it.  The difference here is that
+     * system calls besides another setlocale() can overwrite it.
+     *
+     * By doing this, most locale-sensitive functions become thread-safe.  The
+     * exceptions are mostly those that return a pointer to static memory.
+     *
+     * This function takes the same parameters, 'category' and 'locale', that
+     * the regular setlocale() function does, but it also takes two additional
+     * ones.  This is because the 2008 functions don't use a category; instead
+     * they use a corresponding mask.  Because this function operates in both
+     * worlds, it may need one or the other or both.  This function can
+     * calculate the mask from the input category, but to avoid this
+     * calculation, if the caller knows at compile time what the mask is, it
+     * can pass it, setting 'is_index_valid' to TRUE; otherwise the mask
+     * parameter is ignored.
+     *
+     * POSIX 2008, for some sick reason, chose not to provide a method to find
+     * the category name of a locale.  Some vendors have created a
+     * querylocale() function to do just that.  This function is a lot simpler
+     * to implement on systems that have this.  Otherwise, we have to keep
+     * track of what the locale has been set to, so that we can return its
+     * name to emulate setlocale().  It's also possible for C code in some
+     * library to change the locale without us knowing it, though as of
+     * September 2017, there are no occurrences in CPAN of uselocale().  Some
+     * libraries do use setlocale(), but that changes the global locale, and
+     * threads using per-thread locales will just ignore those changes.
+     * Another problem is that without querylocale(), we have to guess at what
+     * was meant by setting a locale of "".  We handle this by not actually
+     * ever setting to "" (unless querylocale exists), but to emulate what we
+     * think should happen for "".
+     */
+
+    int mask;
+    locale_t old_obj;
+    locale_t new_obj;
+    dTHX;
+
+#  ifdef DEBUGGING
+
+    if (DEBUG_Lv_TEST || debug_initialization) {
+        PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale input=%d (%s), \"%s\", %d, %d\n", __FILE__, __LINE__, category, category_name(category), locale, index, is_index_valid);
+    }
+
+#  endif
+
+    /* If the input mask might be incorrect, calculate the correct one */
+    if (! is_index_valid) {
+        unsigned int i;
+
+#  ifdef DEBUGGING
+
+        if (DEBUG_Lv_TEST || debug_initialization) {
+            PerlIO_printf(Perl_debug_log, "%s:%d: finding index of category %d (%s)\n", __FILE__, __LINE__, category, category_name(category));
+        }
+
+#  endif
+
+        for (i = 0; i <= LC_ALL_INDEX; i++) {
+            if (category == categories[i]) {
+                index = i;
+                goto found_index;
+            }
+        }
+
+        /* Here, we don't know about this category, so can't handle it.
+         * Fallback to the early POSIX usages */
+        Perl_warner(aTHX_ packWARN(WARN_LOCALE),
+                            "Unknown locale category %d; can't set it to %s\n",
+                                                     category, locale);
+        return NULL;
+
+      found_index: ;
+
+#  ifdef DEBUGGING
+
+        if (DEBUG_Lv_TEST || debug_initialization) {
+            PerlIO_printf(Perl_debug_log, "%s:%d: index is %d for %s\n", __FILE__, __LINE__, index, category_name(category));
+        }
+
+#  endif
+
+    }
+
+    mask = category_masks[index];
+
+#  ifdef DEBUGGING
+
+    if (DEBUG_Lv_TEST || debug_initialization) {
+        PerlIO_printf(Perl_debug_log, "%s:%d: category name is %s; mask is 0x%x\n", __FILE__, __LINE__, category_names[index], mask);
+    }
+
+#  endif
+
+    /* If just querying what the existing locale is ... */
+    if (locale == NULL) {
+        locale_t cur_obj = uselocale((locale_t) 0);
+
+#  ifdef DEBUGGING
+
+        if (DEBUG_Lv_TEST || debug_initialization) {
+            PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale querying %p\n", __FILE__, __LINE__, cur_obj);
+        }
+
+#  endif
+
+        if (cur_obj == LC_GLOBAL_LOCALE) {
+            return my_setlocale(category, NULL);
+        }
+
+#  ifdef HAS_QUERYLOCALE
+
+        return (char *) querylocale(mask, cur_obj);
+
+#  else
+
+        /* If this assert fails, adjust the size of curlocales in intrpvar.h */
+        STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX);
+
+#    if   defined(_NL_LOCALE_NAME)                                          \
+     &&   defined(DEBUGGING)                                                \
+          /* On systems that accept any locale name, the real underlying    \
+           * locale is often returned by this internal function, so we      \
+           * can't use it */                                                \
+     && ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME)
+        {
+            /* Internal glibc for querylocale(), but doesn't handle
+             * empty-string ("") locale properly; who knows what other
+             * glitches.  Check for it now, under debug. */
+
+            char * temp_name = nl_langinfo_l(_NL_LOCALE_NAME(category),
+                                             uselocale((locale_t) 0));
+            /*
+            PerlIO_printf(Perl_debug_log, "%s:%d: temp_name=%s\n", __FILE__, __LINE__, temp_name ? temp_name : "NULL");
+            PerlIO_printf(Perl_debug_log, "%s:%d: index=%d\n", __FILE__, __LINE__, index);
+            PerlIO_printf(Perl_debug_log, "%s:%d: PL_curlocales[index]=%s\n", __FILE__, __LINE__, PL_curlocales[index]);
+            */
+            if (temp_name && PL_curlocales[index] && strNE(temp_name, "")) {
+                if (         strNE(PL_curlocales[index], temp_name)
+                    && ! (   isNAME_C_OR_POSIX(temp_name)
+                          && isNAME_C_OR_POSIX(PL_curlocales[index]))) {
+
+#      ifdef USE_C_BACKTRACE
+
+                    dump_c_backtrace(Perl_debug_log, 20, 1);
+
+#      endif
+
+                    Perl_croak(aTHX_ "panic: Mismatch between what Perl thinks %s is"
+                                     " (%s) and what internal glibc thinks"
+                                     " (%s)\n", category_names[index],
+                                     PL_curlocales[index], temp_name);
+                }
+
+                return temp_name;
+            }
+        }
+
+#    endif
+
+        /* Without querylocale(), we have to use our record-keeping we've
+         *  done. */
+
+        if (category != LC_ALL) {
+
+#    ifdef DEBUGGING
+
+            if (DEBUG_Lv_TEST || debug_initialization) {
+                PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[index]);
+            }
+
+#    endif
+
+            return PL_curlocales[index];
+        }
+        else {  /* For LC_ALL */
+            unsigned int i;
+            Size_t names_len = 0;
+            char * all_string;
+            bool are_all_categories_the_same_locale = TRUE;
+
+            /* If we have a valid LC_ALL value, just return it */
+            if (PL_curlocales[LC_ALL_INDEX]) {
+
+#    ifdef DEBUGGING
+
+                if (DEBUG_Lv_TEST || debug_initialization) {
+                    PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[LC_ALL_INDEX]);
+                }
+
+#    endif
+
+                return PL_curlocales[LC_ALL_INDEX];
+            }
+
+            /* Otherwise, we need to construct a string of name=value pairs.
+             * We use the glibc syntax, like
+             *      LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
+             *  First calculate the needed size.  Along the way, check if all
+             *  the locale names are the same */
+            for (i = 0; i < LC_ALL_INDEX; i++) {
+
+#    ifdef DEBUGGING
+
+                if (DEBUG_Lv_TEST || debug_initialization) {
+                    PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
+                }
+
+#    endif
+
+                names_len += strlen(category_names[i])
+                          + 1                       /* '=' */
+                          + strlen(PL_curlocales[i])
+                          + 1;                      /* ';' */
+
+                if (i > 0 && strNE(PL_curlocales[i], PL_curlocales[i-1])) {
+                    are_all_categories_the_same_locale = FALSE;
+                }
+            }
+
+            /* If they are the same, we don't actually have to construct the
+             * string; we just make the entry in LC_ALL_INDEX valid, and be
+             * that single name */
+            if (are_all_categories_the_same_locale) {
+                PL_curlocales[LC_ALL_INDEX] = savepv(PL_curlocales[0]);
+                return PL_curlocales[LC_ALL_INDEX];
+            }
+
+            names_len++;    /* Trailing '\0' */
+            SAVEFREEPV(Newx(all_string, names_len, char));
+            *all_string = '\0';
+
+            /* Then fill in the string */
+            for (i = 0; i < LC_ALL_INDEX; i++) {
+
+#    ifdef DEBUGGING
+
+                if (DEBUG_Lv_TEST || debug_initialization) {
+                    PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
+                }
+
+#    endif
+
+                my_strlcat(all_string, category_names[i], names_len);
+                my_strlcat(all_string, "=", names_len);
+                my_strlcat(all_string, PL_curlocales[i], names_len);
+                my_strlcat(all_string, ";", names_len);
+            }
+
+#    ifdef DEBUGGING
+
+            if (DEBUG_L_TEST || debug_initialization) {
+                PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, all_string);
+            }
+
+    #endif
+
+            return all_string;
+        }
+
+#    ifdef EINVAL
+
+        SETERRNO(EINVAL, LIB_INVARG);
+
+#    endif
+
+        return NULL;
+
+#  endif
+
+    }   /* End of this being setlocale(LC_foo, NULL) */
+
+    /* Here, we are switching locales. */
+
+#  ifndef HAS_QUERYLOCALE
+
+    if (strEQ(locale, "")) {
+
+        /* For non-querylocale() systems, we do the setting of "" ourselves to
+         * be sure that we really know what's going on.  We follow the Linux
+         * documented behavior (but if that differs from the actual behavior,
+         * this won't work exactly as the OS implements).  We go out and
+         * examine the environment based on our understanding of how the system
+         * works, and use that to figure things out */
+
+        const char * const lc_all = PerlEnv_getenv("LC_ALL");
+
+        /* Use any "LC_ALL" environment variable, as it overrides everything
+         * else. */
+        if (lc_all && strNE(lc_all, "")) {
+            locale = lc_all;
+        }
+        else {
+
+            /* Otherwise, we need to dig deeper.  Unless overridden, the
+             * default is the LANG environment variable; if it doesn't exist,
+             * then "C" */
+
+            const char * default_name;
+
+            default_name = PerlEnv_getenv("LANG");
+
+            if (! default_name || strEQ(default_name, "")) {
+                default_name = "C";
+            }
+
+            if (category != LC_ALL) {
+                const char * const name = PerlEnv_getenv(category_names[index]);
+
+                /* Here we are setting a single category.  Assume will have the
+                 * default name */
+                locale = default_name;
+
+                /* But then look for an overriding environment variable */
+                if (name && strNE(name, "")) {
+                    locale = name;
+                }
+            }
+            else {
+                bool did_override = FALSE;
+                unsigned int i;
+
+                /* Here, we are getting LC_ALL.  Any categories that don't have
+                 * a corresponding environment variable set should be set to
+                 * LANG, or to "C" if there is no LANG.  If no individual
+                 * categories differ from this, we can just set LC_ALL.  This
+                 * is buggy on systems that have extra categories that we don't
+                 * know about.  If there is an environment variable that sets
+                 * that category, we won't know to look for it, and so our use
+                 * of LANG or "C" improperly overrides it.  On the other hand,
+                 * if we don't do what is done here, and there is no
+                 * environment variable, the category's locale should be set to
+                 * LANG or "C".  So there is no good solution.  khw thinks the
+                 * best is to look at systems to see what categories they have,
+                 * and include them, and then to assume that we know the
+                 * complete set */
+
+                for (i = 0; i < LC_ALL_INDEX; i++) {
+                    const char * const env_override
+                                            = PerlEnv_getenv(category_names[i]);
+                    const char * this_locale = (   env_override
+                                                && strNE(env_override, ""))
+                                               ? env_override
+                                               : default_name;
+                    if (! emulate_setlocale(categories[i], this_locale, i, TRUE))
+                    {
+                        return NULL;
+                    }
+
+                    if (strNE(this_locale, default_name)) {
+                        did_override = TRUE;
+                    }
+                }
+
+                /* If all the categories are the same, we can set LC_ALL to
+                 * that */
+                if (! did_override) {
+                    locale = default_name;
+                }
+                else {
+
+                    /* Here, LC_ALL is no longer valid, as some individual
+                     * categories don't match it.  We call ourselves
+                     * recursively, as that will execute the code that
+                     * generates the proper locale string for this situation.
+                     * We don't do the remainder of this function, as that is
+                     * to update our records, and we've just done that for the
+                     * individual categories in the loop above, and doing so
+                     * would cause LC_ALL to be done as well */
+                    return emulate_setlocale(LC_ALL, NULL, LC_ALL_INDEX, TRUE);
+                }
+            }
+        }
+    }   /* End of this being setlocale(LC_foo, "") */
+    else if (strchr(locale, ';')) {
+
+        /* LC_ALL may actually incude a conglomeration of various categories.
+         * Without querylocale, this code uses the glibc (as of this writing)
+         * syntax for representing that, but that is not a stable API, and
+         * other platforms do it differently, so we have to handle all cases
+         * ourselves */
+
+        unsigned int i;
+        const char * s = locale;
+        const char * e = locale + strlen(locale);
+        const char * p = s;
+        const char * category_end;
+        const char * name_start;
+        const char * name_end;
+
+        /* If the string that gives what to set doesn't include all categories,
+         * the omitted ones get set to "C".  To get this behavior, first set
+         * all the individual categories to "C", and override the furnished
+         * ones below */
+        for (i = 0; i < LC_ALL_INDEX; i++) {
+            if (! emulate_setlocale(categories[i], "C", i, TRUE)) {
+                return NULL;
+            }
+        }
+
+        while (s < e) {
+
+            /* Parse through the category */
+            while (isWORDCHAR(*p)) {
+                p++;
+            }
+            category_end = p;
+
+            if (*p++ != '=') {
+                Perl_croak(aTHX_
+                    "panic: %s: %d: Unexpected character in locale name '%02X",
+                    __FILE__, __LINE__, *(p-1));
+            }
+
+            /* Parse through the locale name */
+            name_start = p;
+            while (p < e && *p != ';') {
+                if (! isGRAPH(*p)) {
+                    Perl_croak(aTHX_
+                        "panic: %s: %d: Unexpected character in locale name '%02X",
+                        __FILE__, __LINE__, *(p-1));
+                }
+                p++;
+            }
+            name_end = p;
+
+            /* Space past the semi-colon */
+            if (p < e) {
+                p++;
+            }
+
+            /* Find the index of the category name in our lists */
+            for (i = 0; i < LC_ALL_INDEX; i++) {
+                char * individ_locale;
+
+                /* Keep going if this isn't the index.  The strnNE() avoids a
+                 * Perl_form(), but would fail if ever a category name could be
+                 * a substring of another one, like if there were a
+                 * "LC_TIME_DATE" */
+                if strnNE(s, category_names[i], category_end - s) {
+                    continue;
+                }
+
+                /* If this index is for the single category we're changing, we
+                 * have found the locale to set it to. */
+                if (category == categories[i]) {
+                    locale = Perl_form(aTHX_ "%.*s",
+                                             (int) (name_end - name_start),
+                                             name_start);
+                    goto ready_to_set;
+                }
+
+                assert(category == LC_ALL);
+                individ_locale = Perl_form(aTHX_ "%.*s",
+                                    (int) (name_end - name_start), name_start);
+                if (! emulate_setlocale(categories[i], individ_locale, i, TRUE))
+                {
+                    return NULL;
+                }
+            }
+
+            s = p;
+        }
+
+        /* Here we have set all the individual categories by recursive calls.
+         * These collectively should have fixed up LC_ALL, so can just query
+         * what that now is */
+        assert(category == LC_ALL);
+
+        return do_setlocale_c(LC_ALL, NULL);
+    }   /* End of this being setlocale(LC_ALL,
+           "LC_CTYPE=foo;LC_NUMERIC=bar;...") */
+
+  ready_to_set: ;
+
+    /* Here at the end of having to deal with the absence of querylocale().
+     * Some cases have already been fully handled by recursive calls to this
+     * function.  But at this point, we haven't dealt with those, but are now
+     * prepared to, knowing what the locale name to set this category to is.
+     * This would have come for free if this system had had querylocale() */
+
+#  endif  /* end of ! querylocale */
+
+    assert(PL_C_locale_obj);
+
+    /* Switching locales generally entails freeing the current one's space (at
+     * the C library's discretion).  We need to stop using that locale before
+     * the switch.  So switch to a known locale object that we don't otherwise
+     * mess with.  This returns the locale object in effect at the time of the
+     * switch. */
+    old_obj = uselocale(PL_C_locale_obj);
+
+#  ifdef DEBUGGING
+
+    if (DEBUG_Lv_TEST || debug_initialization) {
+        PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
+    }
+
+#  endif
+
+    if (! old_obj) {
+
+#  ifdef DEBUGGING
+
+        if (DEBUG_L_TEST || debug_initialization) {
+            dSAVE_ERRNO;
+            PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to C failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+            RESTORE_ERRNO;
+        }
+
+#  endif
+
+        return NULL;
+    }
+
+#  ifdef DEBUGGING
+
+    if (DEBUG_Lv_TEST || debug_initialization) {
+        PerlIO_printf(Perl_debug_log,
+                      "%s:%d: emulate_setlocale now using %p\n",
+                      __FILE__, __LINE__, PL_C_locale_obj);
+    }
+
+#  endif
+
+    /* If this call is to switch to the LC_ALL C locale, it already exists, and
+     * in fact, we already have switched to it (in preparation for what
+     * normally is to come).  But since we're already there, continue to use
+     * it instead of trying to create a new locale */
+    if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(locale)) {
+
+#  ifdef DEBUGGING
+
+        if (DEBUG_Lv_TEST || debug_initialization) {
+            PerlIO_printf(Perl_debug_log,
+                          "%s:%d: will stay in C object\n", __FILE__, __LINE__);
+        }
+
+#  endif
+
+        new_obj = PL_C_locale_obj;
+
+        /* We already had switched to the C locale in preparation for freeing
+         * 'old_obj' */
+        if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) {
+            freelocale(old_obj);
+        }
+    }
+    else {
+        /* If we weren't in a thread safe locale, set so that newlocale() below
+         * which uses 'old_obj', uses an empty one.  Same for our reserved C
+         * object.  The latter is defensive coding, so that, even if there is
+         * some bug, we will never end up trying to modify either of these, as
+         * if passed to newlocale(), they can be. */
+        if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
+            old_obj = (locale_t) 0;
+        }
+
+        /* Ready to create a new locale by modification of the exising one */
+        new_obj = newlocale(mask, locale, old_obj);
+
+        if (! new_obj) {
+            dSAVE_ERRNO;
+
+#  ifdef DEBUGGING
+
+            if (DEBUG_L_TEST || debug_initialization) {
+                PerlIO_printf(Perl_debug_log,
+                              "%s:%d: emulate_setlocale creating new object"
+                              " failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+            }
+
+#  endif
+
+            if (! uselocale(old_obj)) {
+
+#  ifdef DEBUGGING
+
+                if (DEBUG_L_TEST || debug_initialization) {
+                    PerlIO_printf(Perl_debug_log,
+                                  "%s:%d: switching back failed: %d\n",
+                                  __FILE__, __LINE__, GET_ERRNO);
+                }
+
+#  endif
+
+            }
+            RESTORE_ERRNO;
+            return NULL;
+        }
+
+#  ifdef DEBUGGING
+
+        if (DEBUG_Lv_TEST || debug_initialization) {
+            PerlIO_printf(Perl_debug_log,
+                          "%s:%d: emulate_setlocale created %p",
+                          __FILE__, __LINE__, new_obj);
+            if (old_obj) {
+                PerlIO_printf(Perl_debug_log,
+                              "; should have freed %p", old_obj);
+            }
+            PerlIO_printf(Perl_debug_log, "\n");
+        }
+
+#  endif
+
+        /* And switch into it */
+        if (! uselocale(new_obj)) {
+            dSAVE_ERRNO;
+
+#  ifdef DEBUGGING
+
+            if (DEBUG_L_TEST || debug_initialization) {
+                PerlIO_printf(Perl_debug_log,
+                              "%s:%d: emulate_setlocale switching to new object"
+                              " failed\n", __FILE__, __LINE__);
+            }
+
+#  endif
+
+            if (! uselocale(old_obj)) {
+
+#  ifdef DEBUGGING
+
+                if (DEBUG_L_TEST || debug_initialization) {
+                    PerlIO_printf(Perl_debug_log,
+                                  "%s:%d: switching back failed: %d\n",
+                                  __FILE__, __LINE__, GET_ERRNO);
+                }
+
+#  endif
+
+            }
+            freelocale(new_obj);
+            RESTORE_ERRNO;
+            return NULL;
+        }
+    }
+
+#  ifdef DEBUGGING
+
+    if (DEBUG_Lv_TEST || debug_initialization) {
+        PerlIO_printf(Perl_debug_log,
+                      "%s:%d: emulate_setlocale now using %p\n",
+                      __FILE__, __LINE__, new_obj);
+    }
+
 #  endif
-#endif /* ifdef USE_LOCALE */
 
-/* Windows requres a customized base-level setlocale() */
-#  ifdef WIN32
-#    define my_setlocale(cat, locale) win32_setlocale(cat, locale)
+    /* We are done, except for updating our records (if the system doesn't keep
+     * them) and in the case of locale "", we don't actually know what the
+     * locale that got switched to is, as it came from the environment.  So
+     * have to find it */
+
+#  ifdef HAS_QUERYLOCALE
+
+    if (strEQ(locale, "")) {
+        locale = querylocale(mask, new_obj);
+    }
+
 #  else
-#    define my_setlocale(cat, locale) setlocale(cat, locale)
+
+    /* Here, 'locale' is the return value */
+
+    /* Without querylocale(), we have to update our records */
+
+    if (category == LC_ALL) {
+        unsigned int i;
+
+        /* For LC_ALL, we change all individual categories to correspond */
+                              /* PL_curlocales is a parallel array, so has same
+                               * length as 'categories' */
+        for (i = 0; i <= LC_ALL_INDEX; i++) {
+            Safefree(PL_curlocales[i]);
+            PL_curlocales[i] = savepv(locale);
+        }
+
+        FIX_GLIBC_LC_MESSAGES_BUG(LC_MESSAGES_INDEX);
+    }
+    else {
+
+        /* For a single category, if it's not the same as the one in LC_ALL, we
+         * nullify LC_ALL */
+
+        if (PL_curlocales[LC_ALL_INDEX] && strNE(PL_curlocales[LC_ALL_INDEX], locale)) {
+            Safefree(PL_curlocales[LC_ALL_INDEX]);
+            PL_curlocales[LC_ALL_INDEX] = NULL;
+        }
+
+        /* Then update the category's record */
+        Safefree(PL_curlocales[index]);
+        PL_curlocales[index] = savepv(locale);
+
+        FIX_GLIBC_LC_MESSAGES_BUG(index);
+    }
+
 #  endif
 
-/* Just placeholders for now.  "_c" is intended to be called when the category
- * is a constant known at compile time; "_r", not known until run time  */
-#  define do_setlocale_c(category, locale) my_setlocale(category, locale)
-#  define do_setlocale_r(category, locale) my_setlocale(category, locale)
+    return locale;
+}
+
+#endif /* USE_POSIX_2008_LOCALE */
+
+#ifdef USE_LOCALE
 
 STATIC void
 S_set_numeric_radix(pTHX_ const bool use_locale)
@@ -399,7 +1232,7 @@ S_set_numeric_radix(pTHX_ const bool use_locale)
                                     || defined(HAS_NL_LANGINFO))
 
     const char * radix = (use_locale)
-                         ? my_nl_langinfo(PERL_RADIXCHAR, FALSE)
+                         ? my_nl_langinfo(RADIXCHAR, FALSE)
                                         /* FALSE => already in dest locale */
                          : ".";
 
@@ -423,6 +1256,10 @@ S_set_numeric_radix(pTHX_ const bool use_locale)
     }
 
 #  endif
+#else
+
+    PERL_UNUSED_ARG(use_locale);
+
 #endif /* USE_LOCALE_NUMERIC and can find the radix char */
 
 }
@@ -472,34 +1309,39 @@ S_new_numeric(pTHX_ const char *newnum)
     char *save_newnum;
 
     if (! newnum) {
-       Safefree(PL_numeric_name);
-       PL_numeric_name = NULL;
-       PL_numeric_standard = TRUE;
-       PL_numeric_underlying = TRUE;
-       PL_numeric_underlying_is_standard = TRUE;
-       return;
+        Safefree(PL_numeric_name);
+        PL_numeric_name = NULL;
+        PL_numeric_standard = TRUE;
+        PL_numeric_underlying = TRUE;
+        PL_numeric_underlying_is_standard = TRUE;
+        return;
     }
 
     save_newnum = stdize_locale(savepv(newnum));
     PL_numeric_underlying = TRUE;
     PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
 
+#ifndef TS_W32_BROKEN_LOCALECONV
+
     /* If its name isn't C nor POSIX, it could still be indistinguishable from
-     * them */
+     * them.  But on broken Windows systems calling my_nl_langinfo() for
+     * THOUSEP can currently (but rarely) cause a race, so avoid doing that,
+     * and just always change the locale if not C nor POSIX on those systems */
     if (! PL_numeric_standard) {
-        PL_numeric_standard = cBOOL(strEQ(".", my_nl_langinfo(PERL_RADIXCHAR,
+        PL_numeric_standard = cBOOL(strEQ(".", my_nl_langinfo(RADIXCHAR,
                                             FALSE /* Don't toggle locale */  ))
-                                 && strEQ("",  my_nl_langinfo(PERL_THOUSEP,
-                                                              FALSE)));
+                                 && strEQ("",  my_nl_langinfo(THOUSEP, FALSE)));
     }
 
+#endif
+
     /* Save the new name if it isn't the same as the previous one, if any */
     if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
-       Safefree(PL_numeric_name);
-       PL_numeric_name = save_newnum;
+        Safefree(PL_numeric_name);
+        PL_numeric_name = save_newnum;
     }
     else {
-       Safefree(save_newnum);
+        Safefree(save_newnum);
     }
 
     PL_numeric_underlying_is_standard = PL_numeric_standard;
@@ -519,7 +1361,12 @@ S_new_numeric(pTHX_ const char *newnum)
     /* Keep LC_NUMERIC in the C locale.  This is for XS modules, so they don't
      * have to worry about the radix being a non-dot.  (Core operations that
      * need the underlying locale change to it temporarily). */
-    set_numeric_standard();
+    if (PL_numeric_standard) {
+        set_numeric_radix(0);
+    }
+    else {
+        set_numeric_standard();
+    }
 
 #endif /* USE_LOCALE_NUMERIC */
 
@@ -537,19 +1384,20 @@ Perl_set_numeric_standard(pTHX)
      * to our records (which could be wrong if some XS code has changed the
      * locale behind our back) */
 
-    do_setlocale_c(LC_NUMERIC, "C");
-    PL_numeric_standard = TRUE;
-    PL_numeric_underlying = PL_numeric_underlying_is_standard;
-    set_numeric_radix(0);
-
 #  ifdef DEBUGGING
 
     if (DEBUG_L_TEST || debug_initialization) {
         PerlIO_printf(Perl_debug_log,
-                          "LC_NUMERIC locale now is standard C\n");
+                          "Setting LC_NUMERIC locale to standard C\n");
     }
 
 #  endif
+
+    do_setlocale_c(LC_NUMERIC, "C");
+    PL_numeric_standard = TRUE;
+    PL_numeric_underlying = PL_numeric_underlying_is_standard;
+    set_numeric_radix(0);
+
 #endif /* USE_LOCALE_NUMERIC */
 
 }
@@ -566,20 +1414,21 @@ Perl_set_numeric_underlying(pTHX)
      * if toggling isn't necessary according to our records (which could be
      * wrong if some XS code has changed the locale behind our back) */
 
-    do_setlocale_c(LC_NUMERIC, PL_numeric_name);
-    PL_numeric_standard = PL_numeric_underlying_is_standard;
-    PL_numeric_underlying = TRUE;
-    set_numeric_radix(! PL_numeric_standard);
-
 #  ifdef DEBUGGING
 
     if (DEBUG_L_TEST || debug_initialization) {
         PerlIO_printf(Perl_debug_log,
-                          "LC_NUMERIC locale now is %s\n",
+                          "Setting LC_NUMERIC locale to %s\n",
                           PL_numeric_name);
     }
 
 #  endif
+
+    do_setlocale_c(LC_NUMERIC, PL_numeric_name);
+    PL_numeric_standard = PL_numeric_underlying_is_standard;
+    PL_numeric_underlying = TRUE;
+    set_numeric_radix(! PL_numeric_standard);
+
 #endif /* USE_LOCALE_NUMERIC */
 
 }
@@ -593,7 +1442,6 @@ S_new_ctype(pTHX_ const char *newctype)
 
 #ifndef USE_LOCALE_CTYPE
 
-    PERL_ARGS_ASSERT_NEW_CTYPE;
     PERL_UNUSED_ARG(newctype);
     PERL_UNUSED_CONTEXT;
 
@@ -610,11 +1458,11 @@ S_new_ctype(pTHX_ const char *newctype)
      * this function should be called directly only from this file and from
      * POSIX::setlocale() */
 
-    dVAR;
-    UV i;
+    unsigned int i;
 
     /* Don't check for problems if we are suppressing the warnings */
     bool check_for_problems = ckWARN_d(WARN_LOCALE) || UNLIKELY(DEBUG_L_TEST);
+    bool maybe_utf8_turkic = FALSE;
 
     PERL_ARGS_ASSERT_NEW_CTYPE;
 
@@ -631,6 +1479,23 @@ S_new_ctype(pTHX_ const char *newctype)
      * handle this specially because of the three problematic code points */
     if (PL_in_utf8_CTYPE_locale) {
         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
+
+        /* UTF-8 locales can have special handling for 'I' and 'i' if they are
+         * Turkic.  Make sure these two are the only anomalies.  (We don't use
+         * towupper and towlower because they aren't in C89.) */
+
+#if defined(HAS_TOWUPPER) && defined (HAS_TOWLOWER)
+
+        if (towupper('i') == 0x130 && towlower('I') == 0x131) {
+
+#else
+
+        if (toupper('i') == 'i' && tolower('I') == 'I') {
+
+#endif
+            check_for_problems = TRUE;
+            maybe_utf8_turkic = TRUE;
+        }
     }
 
     /* We don't populate the other lists if a UTF-8 locale, but do check that
@@ -668,18 +1533,22 @@ S_new_ctype(pTHX_ const char *newctype)
                 && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
             {
                 bool is_bad = FALSE;
-                char name[3] = { '\0' };
+                char name[4] = { '\0' };
 
                 /* Convert the name into a string */
-                if (isPRINT_A(i)) {
+                if (isGRAPH_A(i)) {
                     name[0] = i;
                     name[1] = '\0';
                 }
                 else if (i == '\n') {
-                    my_strlcpy(name, "\n", sizeof(name));
+                    my_strlcpy(name, "\\n", sizeof(name));
+                }
+                else if (i == '\t') {
+                    my_strlcpy(name, "\\t", sizeof(name));
                 }
                 else {
-                    my_strlcpy(name, "\t", sizeof(name));
+                    assert(i == ' ');
+                    my_strlcpy(name, "' '", sizeof(name));
                 }
 
                 /* Check each possibe class */
@@ -743,13 +1612,13 @@ S_new_ctype(pTHX_ const char *newctype)
                                           "isxdigit('%s') unexpectedly is %d\n",
                                           name, cBOOL(isxdigit(i))));
                 }
-                if (UNLIKELY(tolower(i) != (int) toLOWER_A(i)))  {
+                if (UNLIKELY(tolower(i) != (int) toLOWER_A(i))) {
                     is_bad = TRUE;
                     DEBUG_L(PerlIO_printf(Perl_debug_log,
                             "tolower('%s')=0x%x instead of the expected 0x%x\n",
                             name, tolower(i), (int) toLOWER_A(i)));
                 }
-                if (UNLIKELY(toupper(i) != (int) toUPPER_A(i)))  {
+                if (UNLIKELY(toupper(i) != (int) toUPPER_A(i))) {
                     is_bad = TRUE;
                     DEBUG_L(PerlIO_printf(Perl_debug_log,
                             "toupper('%s')=0x%x instead of the expected 0x%x\n",
@@ -772,6 +1641,19 @@ S_new_ctype(pTHX_ const char *newctype)
             }
         }
 
+        if (bad_count == 2 && maybe_utf8_turkic) {
+            bad_count = 0;
+            *bad_chars_list = '\0';
+            PL_fold_locale['I'] = 'I';
+            PL_fold_locale['i'] = 'i';
+            PL_in_utf8_turkic_locale = TRUE;
+            DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s is turkic\n",
+                                                 __FILE__, __LINE__, newctype));
+        }
+        else {
+            PL_in_utf8_turkic_locale = FALSE;
+        }
+
 #  ifdef MB_CUR_MAX
 
         /* We only handle single-byte locales (outside of UTF-8 ones; so if
@@ -797,14 +1679,16 @@ S_new_ctype(pTHX_ const char *newctype)
 
 #  endif
 
-        if (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale)) {
+        /* If we found problems and we want them output, do so */
+        if (   (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale))
+            && (LIKELY(ckWARN_d(WARN_LOCALE)) || UNLIKELY(DEBUG_L_TEST)))
+        {
             if (UNLIKELY(bad_count) && PL_in_utf8_CTYPE_locale) {
                 PL_warn_locale = Perl_newSVpvf(aTHX_
                      "Locale '%s' contains (at least) the following characters"
-                     " which have\nnon-standard meanings: %s\nThe Perl program"
-                     " will use the standard meanings",
+                     " which have\nunexpected meanings: %s\nThe Perl program"
+                     " will use the expected meanings",
                       newctype, bad_chars_list);
-
             }
             else {
                 PL_warn_locale = Perl_newSVpvf(aTHX_
@@ -829,7 +1713,7 @@ S_new_ctype(pTHX_ const char *newctype)
 
             Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
                                     /* parameter FALSE is a don't care here */
-                                    my_nl_langinfo(PERL_CODESET, FALSE));
+                                    my_nl_langinfo(CODESET, FALSE));
 
 #  endif
 
@@ -910,27 +1794,27 @@ S_new_collate(pTHX_ const char *newcoll)
      * an unlikely bug */
 
     if (! newcoll) {
-       if (PL_collation_name) {
-           ++PL_collation_ix;
-           Safefree(PL_collation_name);
-           PL_collation_name = NULL;
-       }
-       PL_collation_standard = TRUE;
+        if (PL_collation_name) {
+            ++PL_collation_ix;
+            Safefree(PL_collation_name);
+            PL_collation_name = NULL;
+        }
+        PL_collation_standard = TRUE;
       is_standard_collation:
-       PL_collxfrm_base = 0;
-       PL_collxfrm_mult = 2;
+        PL_collxfrm_base = 0;
+        PL_collxfrm_mult = 2;
         PL_in_utf8_COLLATE_locale = FALSE;
         PL_strxfrm_NUL_replacement = '\0';
         PL_strxfrm_max_cp = 0;
-       return;
+        return;
     }
 
     /* If this is not the same locale as currently, set the new one up */
     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
-       ++PL_collation_ix;
-       Safefree(PL_collation_name);
-       PL_collation_name = stdize_locale(savepv(newcoll));
-       PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
+        ++PL_collation_ix;
+        Safefree(PL_collation_name);
+        PL_collation_name = stdize_locale(savepv(newcoll));
+        PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
         if (PL_collation_standard) {
             goto is_standard_collation;
         }
@@ -980,7 +1864,7 @@ S_new_collate(pTHX_ const char *newcoll)
          * get it right the first time to avoid wasted expensive string
          * transformations. */
 
-       {
+        {
             /* We use the string below to find how long the tranformation of it
              * is.  Almost all locales are supersets of ASCII, or at least the
              * ASCII letters.  We use all of them, half upper half lower,
@@ -1096,15 +1980,68 @@ S_new_collate(pTHX_ const char *newcoll)
             }
 #  endif
 
-       }
+        }
     }
 
 #endif /* USE_LOCALE_COLLATE */
 
 }
 
+#endif
+
 #ifdef WIN32
 
+#define USE_WSETLOCALE
+
+#ifdef USE_WSETLOCALE
+
+STATIC char *
+S_wrap_wsetlocale(pTHX_ int category, const char *locale) {
+    wchar_t *wlocale;
+    wchar_t *wresult;
+    char *result;
+
+    if (locale) {
+        int req_size =
+            MultiByteToWideChar(CP_UTF8, 0, locale, -1, NULL, 0);
+
+        if (!req_size) {
+            errno = EINVAL;
+            return NULL;
+        }
+
+        Newx(wlocale, req_size, wchar_t);
+        if (!MultiByteToWideChar(CP_UTF8, 0, locale, -1, wlocale, req_size)) {
+            Safefree(wlocale);
+            errno = EINVAL;
+            return NULL;
+        }
+    }
+    else {
+        wlocale = NULL;
+    }
+    wresult = _wsetlocale(category, wlocale);
+    Safefree(wlocale);
+    if (wresult) {
+        int req_size =
+            WideCharToMultiByte(CP_UTF8, 0, wresult, -1, NULL, 0, NULL, NULL);
+        Newx(result, req_size, char);
+        SAVEFREEPV(result); /* is there something better we can do here? */
+        if (!WideCharToMultiByte(CP_UTF8, 0, wresult, -1,
+                                 result, req_size, NULL, NULL)) {
+            errno = EINVAL;
+            return NULL;
+        }
+    }
+    else {
+        result = NULL;
+    }
+
+    return result;
+}
+
+#endif
+
 STATIC char *
 S_win32_setlocale(pTHX_ int category, const char* locale)
 {
@@ -1162,7 +2099,11 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
 
     }
 
+#ifdef USE_WSETLOCALE
+    result = S_wrap_wsetlocale(aTHX_ category, locale);
+#else
     result = setlocale(category, locale);
+#endif
     DEBUG_L(STMT_START {
                 dSAVE_ERRNO;
                 PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
@@ -1183,7 +2124,11 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
     for (i = 0; i < LC_ALL_INDEX; i++) {
         result = PerlEnv_getenv(category_names[i]);
         if (result && strNE(result, "")) {
+#ifdef USE_WSETLOCALE
+            S_wrap_wsetlocale(aTHX_ categories[i], result);
+#else
             setlocale(categories[i], result);
+#endif
             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
                 __FILE__, __LINE__,
                 setlocale_debug_string(categories[i], result, "not captured")));
@@ -1205,25 +2150,33 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
 #endif
 
 /*
-
-=head1 Locale-related functions and macros
-
 =for apidoc Perl_setlocale
 
 This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
 taking the same parameters, and returning the same information, except that it
-returns the correct underlying C<LC_NUMERIC> locale, instead of C<C> always, as
-perl keeps that locale category as C<C>, changing it briefly during the
-operations where the underlying one is required.
-
-The other reason it isn't completely a drop-in replacement is that it is
+returns the correct underlying C<LC_NUMERIC> locale.  Regular C<setlocale> will
+instead return C<C> if the underlying locale has a non-dot decimal point
+character, or a non-empty thousands separator for displaying floating point
+numbers.  This is because perl keeps that locale category such that it has a
+dot and empty separator, changing the locale briefly during the operations
+where the underlying one is required. C<Perl_setlocale> knows about this, and
+compensates; regular C<setlocale> doesn't.
+
+Another reason it isn't completely a drop-in replacement is that it is
 declared to return S<C<const char *>>, whereas the system setlocale omits the
-C<const>.  (If it were being written today, plain setlocale would be declared
-const, since it is illegal to change the information it returns; doing so leads
-to segfaults.)
+C<const> (presumably because its API was specified long ago, and can't be
+updated; it is illegal to change the information C<setlocale> returns; doing
+so leads to segfaults.)
+
+Finally, C<Perl_setlocale> works under all circumstances, whereas plain
+C<setlocale> can be completely ineffective on some platforms under some
+configurations.
 
 C<Perl_setlocale> should not be used to change the locale except on systems
-where the predefined variable C<${^SAFE_LOCALES}> is 1.
+where the predefined variable C<${^SAFE_LOCALES}> is 1.  On some such systems,
+the system C<setlocale()> is ineffective, returning the wrong information, and
+failing to actually change the locale.  C<Perl_setlocale>, however works
+properly in all circumstances.
 
 The return points to a per-thread static buffer, which is overwritten the next
 time C<Perl_setlocale> is called from the same thread.
@@ -1237,18 +2190,28 @@ Perl_setlocale(const int category, const char * locale)
 {
     /* This wraps POSIX::setlocale() */
 
+#ifndef USE_LOCALE
+
+    PERL_UNUSED_ARG(category);
+    PERL_UNUSED_ARG(locale);
+
+    return "C";
+
+#else
+
     const char * retval;
     const char * newlocale;
     dSAVEDERRNO;
-    DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
     dTHX;
+    DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
 
 #ifdef USE_LOCALE_NUMERIC
 
     /* A NULL locale means only query what the current one is.  We have the
      * LC_NUMERIC name saved, because we are normally switched into the C
-     * locale for it.  For an LC_ALL query, switch back to get the correct
-     * results.  All other categories don't require special handling */
+     * (or equivalent) locale for it.  For an LC_ALL query, switch back to get
+     * the correct results.  All other categories don't require special
+     * handling */
     if (locale == NULL) {
         if (category == LC_NUMERIC) {
 
@@ -1269,7 +2232,8 @@ Perl_setlocale(const int category, const char * locale)
 
 #endif
 
-    retval = do_setlocale_r(category, locale);
+    retval = save_to_buffer(do_setlocale_r(category, locale),
+                            &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
     SAVE_ERRNO;
 
 #if defined(USE_LOCALE_NUMERIC) && defined(LC_ALL)
@@ -1290,9 +2254,6 @@ Perl_setlocale(const int category, const char * locale)
         return NULL;
     }
 
-    save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
-    retval = PL_setlocale_buf;
-
     /* If locale == NULL, we are just querying the state */
     if (locale == NULL) {
         return retval;
@@ -1334,20 +2295,23 @@ Perl_setlocale(const int category, const char * locale)
 
 #  ifdef USE_LOCALE_CTYPE
 
-            newlocale = do_setlocale_c(LC_CTYPE, NULL);
+            newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
             new_ctype(newlocale);
+            Safefree(newlocale);
 
 #  endif /* USE_LOCALE_CTYPE */
 #  ifdef USE_LOCALE_COLLATE
 
-            newlocale = do_setlocale_c(LC_COLLATE, NULL);
+            newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
             new_collate(newlocale);
+            Safefree(newlocale);
 
 #  endif
 #  ifdef USE_LOCALE_NUMERIC
 
-            newlocale = do_setlocale_c(LC_NUMERIC, NULL);
+            newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
             new_numeric(newlocale);
+            Safefree(newlocale);
 
 #  endif /* USE_LOCALE_NUMERIC */
 #endif /* LC_ALL */
@@ -1358,6 +2322,8 @@ Perl_setlocale(const int category, const char * locale)
 
     return retval;
 
+#endif
+
 }
 
 PERL_STATIC_INLINE const char *
@@ -1366,10 +2332,16 @@ S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t
     /* Copy the NUL-terminated 'string' to 'buf' + 'offset'.  'buf' has size 'buf_size',
      * growing it if necessary */
 
-    const Size_t string_size = strlen(string) + offset + 1;
+    Size_t string_size;
 
     PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
 
+    if (! string) {
+        return NULL;
+    }
+
+    string_size = strlen(string) + offset + 1;
+
     if (*buf_size == 0) {
         Newx(*buf, string_size, char);
         *buf_size = string_size;
@@ -1387,7 +2359,7 @@ S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t
 
 =for apidoc Perl_langinfo
 
-This is an (almost ª) drop-in replacement for the system C<L<nl_langinfo(3)>>,
+This is an (almost) drop-in replacement for the system C<L<nl_langinfo(3)>>,
 taking the same C<item> parameter values, and returning the same information.
 But it is more thread-safe than regular C<nl_langinfo()>, and hides the quirks
 of Perl's locale handling from your code, and can be used on systems that lack
@@ -1399,94 +2371,66 @@ Expanding on these:
 
 =item *
 
-It delivers the correct results for the C<RADIXCHAR> and C<THOUSESEP> items,
-without you having to write extra code.  The reason for the extra code would be
-because these are from the C<LC_NUMERIC> locale category, which is normally
-kept set to the C locale by Perl, no matter what the underlying locale is
-supposed to be, and so to get the expected results, you have to temporarily
-toggle into the underlying locale, and later toggle back.  (You could use
-plain C<nl_langinfo> and C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this
-but then you wouldn't get the other advantages of C<Perl_langinfo()>; not
-keeping C<LC_NUMERIC> in the C locale would break a lot of CPAN, which is
-expecting the radix (decimal point) character to be a dot.)
+The reason it isn't quite a drop-in replacement is actually an advantage.  The
+only difference is that it returns S<C<const char *>>, whereas plain
+C<nl_langinfo()> returns S<C<char *>>, but you are (only by documentation)
+forbidden to write into the buffer.  By declaring this C<const>, the compiler
+enforces this restriction, so if it is violated, you know at compilation time,
+rather than getting segfaults at runtime.
 
 =item *
 
-Depending on C<item>, it works on systems that don't have C<nl_langinfo>, hence
-makes your code more portable.  Of the fifty-some possible items specified by
-the POSIX 2008 standard,
-L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
-only two are completely unimplemented.  It uses various techniques to recover
-the other items, including calling C<L<localeconv(3)>>, and C<L<strftime(3)>>,
-both of which are specified in C89, so should be always be available.  Later
-C<strftime()> versions have additional capabilities; C<""> is returned for
-those not available on your system.
-
-It is important to note that on such systems, this calls C<localeconv>, and so
-overwrites the static buffer returned from previous explicit calls to that
-function.  Thus, if the program doesn't use or save the information from an
-explicit C<localeconv> call (which good practice suggests should be done
-anyway), use of this function can break it.
-
-The details for those items which may differ from what this emulation returns
-and what a native C<nl_langinfo()> would return are:
-
-=over
-
-=item C<CODESET>
-
-=item C<ERA>
-
-Unimplemented, so returns C<"">.
-
-=item C<YESEXPR>
-
-=item C<YESSTR>
-
-=item C<NOEXPR>
-
-=item C<NOSTR>
-
-Only the values for English are returned.  C<YESSTR> and C<NOSTR> have been
-removed from POSIX 2008, and are retained for backwards compatibility.  Your
-platform's C<nl_langinfo> may not support them.
-
-=item C<D_FMT>
-
-Always evaluates to C<%x>, the locale's appropriate date representation.
-
-=item C<T_FMT>
-
-Always evaluates to C<%X>, the locale's appropriate time representation.
-
-=item C<D_T_FMT>
-
-Always evaluates to C<%c>, the locale's appropriate date and time
-representation.
-
-=item C<CRNCYSTR>
-
-The return may be incorrect for those rare locales where the currency symbol
-replaces the radix character.
-Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
-to work differently.
-
-=item C<ALT_DIGITS>
+It delivers the correct results for the C<RADIXCHAR> and C<THOUSEP> items,
+without you having to write extra code.  The reason for the extra code would be
+because these are from the C<LC_NUMERIC> locale category, which is normally
+kept set by Perl so that the radix is a dot, and the separator is the empty
+string, no matter what the underlying locale is supposed to be, and so to get
+the expected results, you have to temporarily toggle into the underlying
+locale, and later toggle back.  (You could use plain C<nl_langinfo> and
+C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this but then you wouldn't get
+the other advantages of C<Perl_langinfo()>; not keeping C<LC_NUMERIC> in the C
+(or equivalent) locale would break a lot of CPAN, which is expecting the radix
+(decimal point) character to be a dot.)
 
-Currently this gives the same results as Linux does.
-Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
-to work differently.
+=item *
 
-=item C<ERA_D_FMT>
+The system function it replaces can have its static return buffer trashed,
+not only by a subsequent call to that function, but by a C<freelocale>,
+C<setlocale>, or other locale change.  The returned buffer of this function is
+not changed until the next call to it, so the buffer is never in a trashed
+state.
 
-=item C<ERA_T_FMT>
+=item *
 
-=item C<ERA_D_T_FMT>
+Its return buffer is per-thread, so it also is never overwritten by a call to
+this function from another thread;  unlike the function it replaces.
 
-=item C<T_FMT_AMPM>
+=item *
 
-These are derived by using C<strftime()>, and not all versions of that function
-know about them.  C<""> is returned for these on such systems.
+But most importantly, it works on systems that don't have C<nl_langinfo>, such
+as Windows, hence makes your code more portable.  Of the fifty-some possible
+items specified by the POSIX 2008 standard,
+L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
+only one is completely unimplemented, though on non-Windows platforms, another
+significant one is also not implemented).  It uses various techniques to
+recover the other items, including calling C<L<localeconv(3)>>, and
+C<L<strftime(3)>>, both of which are specified in C89, so should be always be
+available.  Later C<strftime()> versions have additional capabilities; C<""> is
+returned for those not available on your system.
+
+It is important to note that when called with an item that is recovered by
+using C<localeconv>, the buffer from any previous explicit call to
+C<localeconv> will be overwritten.  This means you must save that buffer's
+contents if you need to access them after a call to this function.  (But note
+that you might not want to be using C<localeconv()> directly anyway, because of
+issues like the ones listed in the second item of this list (above) for
+C<RADIXCHAR> and C<THOUSEP>.  You can use the methods given in L<perlcall> to
+call L<POSIX/localeconv> and avoid all the issues, but then you have a hash to
+unpack).
+
+The details for those items which may deviate from what this emulation returns
+and what a native C<nl_langinfo()> would return are specified in
+L<I18N::Langinfo>.
 
 =back
 
@@ -1497,29 +2441,8 @@ C<nl_langinfo()>, you must
 
 before the C<perl.h> C<#include>.  You can replace your C<langinfo.h>
 C<#include> with this one.  (Doing it this way keeps out the symbols that plain
-C<langinfo.h> imports into the namespace for code that doesn't need it.)
-
-You also should not use the bare C<langinfo.h> item names, but should preface
-them with C<PERL_>, so use C<PERL_RADIXCHAR> instead of plain C<RADIXCHAR>.
-The C<PERL_I<foo>> versions will also work for this function on systems that do
-have a native C<nl_langinfo>.
-
-=item *
-
-It is thread-friendly, returning its result in a buffer that won't be
-overwritten by another thread, so you don't have to code for that possibility.
-The buffer can be overwritten by the next call to C<nl_langinfo> or
-C<Perl_langinfo> in the same thread.
-
-=item *
-
-ª It returns S<C<const char *>>, whereas plain C<nl_langinfo()> returns S<C<char
-*>>, but you are (only by documentation) forbidden to write into the buffer.
-By declaring this C<const>, the compiler enforces this restriction.  The extra
-C<const> is why this isn't an unequivocal drop-in replacement for
-C<nl_langinfo>.
-
-=back
+C<langinfo.h> would try to import into the namespace for code that doesn't need
+it.)
 
 The original impetus for C<Perl_langinfo()> was so that code that needs to
 find out the current currency symbol, floating point radix character, or digit
@@ -1543,7 +2466,7 @@ Perl_langinfo(const int item)
     return my_nl_langinfo(item, TRUE);
 }
 
-const char *
+STATIC const char *
 #ifdef HAS_NL_LANGINFO
 S_my_nl_langinfo(const nl_item item, bool toggle)
 #else
@@ -1551,17 +2474,22 @@ S_my_nl_langinfo(const int item, bool toggle)
 #endif
 {
     dTHX;
+    const char * retval;
+
+#ifdef USE_LOCALE_NUMERIC
 
     /* We only need to toggle into the underlying LC_NUMERIC locale for these
      * two items, and only if not already there */
-    if (toggle && ((   item != PERL_RADIXCHAR && item != PERL_THOUSEP)
+    if (toggle && ((   item != RADIXCHAR && item != THOUSEP)
                     || PL_numeric_underlying))
-    {
+
+#endif  /* No toggling needed if not using LC_NUMERIC */
+
         toggle = FALSE;
-    }
 
 #if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available.  */
-#if   ! defined(HAS_POSIX_2008_LOCALE)
+#  if   ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L)      \
+     || ! defined(HAS_POSIX_2008_LOCALE)
 
     /* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
      * for those items dependent on it.  This must be copied to a buffer before
@@ -1575,14 +2503,16 @@ S_my_nl_langinfo(const int item, bool toggle)
             STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
         }
 
-        LOCALE_LOCK;    /* Prevent interference from another thread executing
-                           this code section (the only call to nl_langinfo in
-                           the core) */
+        /* Prevent interference from another thread executing this code
+         * section. */
+        NL_LANGINFO_LOCK;
 
-        save_to_buffer(nl_langinfo(item), &PL_langinfo_buf,
-                                          &PL_langinfo_bufsize, 0);
-
-        LOCALE_UNLOCK;
+        /* Copy to a per-thread buffer, which is also one that won't be
+         * destroyed by a subsequent setlocale(), such as the
+         * RESTORE_LC_NUMERIC may do just below. */
+        retval = save_to_buffer(nl_langinfo(item),
+                                &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
+        NL_LANGINFO_UNLOCK;
 
         if (toggle) {
             RESTORE_LC_NUMERIC();
@@ -1600,6 +2530,8 @@ S_my_nl_langinfo(const int item, bool toggle)
             do_free = TRUE;
         }
 
+#    ifdef USE_LOCALE_NUMERIC
+
         if (toggle) {
             if (PL_underlying_numeric_obj) {
                 cur = PL_underlying_numeric_obj;
@@ -1610,8 +2542,13 @@ S_my_nl_langinfo(const int item, bool toggle)
             }
         }
 
-        save_to_buffer(nl_langinfo_l(item, cur),
-                       &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
+#    endif
+
+        /* We have to save it to a buffer, because the freelocale() just below
+         * can invalidate the internal one */
+        retval = save_to_buffer(nl_langinfo_l(item, cur),
+                                &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
+
         if (do_free) {
             freelocale(cur);
         }
@@ -1619,16 +2556,16 @@ S_my_nl_langinfo(const int item, bool toggle)
 
 #  endif
 
-    if (strEQ(PL_langinfo_buf, "")) {
-        if (item == PERL_YESSTR) {
+    if (strEQ(retval, "")) {
+        if (item == YESSTR) {
             return "yes";
         }
-        if (item == PERL_NOSTR) {
+        if (item == NOSTR) {
             return "no";
         }
     }
 
-    return PL_langinfo_buf;
+    return retval;
 
 #else   /* Below, emulate nl_langinfo as best we can */
 
@@ -1637,8 +2574,19 @@ S_my_nl_langinfo(const int item, bool toggle)
 #  ifdef HAS_LOCALECONV
 
         const struct lconv* lc;
+        const char * temp;
         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
 
+#    ifdef TS_W32_BROKEN_LOCALECONV
+
+        const char * save_global;
+        const char * save_thread;
+        int needed_size;
+        char * ptr;
+        char * e;
+        char * item_start;
+
+#    endif
 #  endif
 #  ifdef HAS_STRFTIME
 
@@ -1658,86 +2606,271 @@ S_my_nl_langinfo(const int item, bool toggle)
 
         switch (item) {
             Size_t len;
-            const char * retval;
 
-            /* These 2 are unimplemented */
-            case PERL_CODESET:
-            case PERL_ERA:      /* For use with strftime() %E modifier */
+            /* This is unimplemented */
+            case ERA:      /* For use with strftime() %E modifier */
 
             default:
                 return "";
 
             /* We use only an English set, since we don't know any more */
-            case PERL_YESEXPR:   return "^[+1yY]";
-            case PERL_YESSTR:    return "yes";
-            case PERL_NOEXPR:    return "^[-0nN]";
-            case PERL_NOSTR:     return "no";
+            case YESEXPR:   return "^[+1yY]";
+            case YESSTR:    return "yes";
+            case NOEXPR:    return "^[-0nN]";
+            case NOSTR:     return "no";
+
+            case CODESET:
+
+#  ifndef WIN32
+
+                /* On non-windows, this is unimplemented, in part because of
+                 * inconsistencies between vendors.  The Darwin native
+                 * nl_langinfo() implementation simply looks at everything past
+                 * any dot in the name, but that doesn't work for other
+                 * vendors.  Many Linux locales that don't have UTF-8 in their
+                 * names really are UTF-8, for example; z/OS locales that do
+                 * have UTF-8 in their names, aren't really UTF-8 */
+                return "";
+
+#  else
+
+                {   /* But on Windows, the name does seem to be consistent, so
+                       use that. */
+                    const char * p;
+                    const char * first;
+                    Size_t offset = 0;
+                    const char * name = my_setlocale(LC_CTYPE, NULL);
+
+                    if (isNAME_C_OR_POSIX(name)) {
+                        return "ANSI_X3.4-1968";
+                    }
+
+                    /* Find the dot in the locale name */
+                    first = (const char *) strchr(name, '.');
+                    if (! first) {
+                        first = name;
+                        goto has_nondigit;
+                    }
+
+                    /* Look at everything past the dot */
+                    first++;
+                    p = first;
+
+                    while (*p) {
+                        if (! isDIGIT(*p)) {
+                            goto has_nondigit;
+                        }
+
+                        p++;
+                    }
+
+                    /* Here everything past the dot is a digit.  Treat it as a
+                     * code page */
+                    retval = save_to_buffer("CP", &PL_langinfo_buf,
+                                                &PL_langinfo_bufsize, 0);
+                    offset = STRLENs("CP");
+
+                  has_nondigit:
+
+                    retval = save_to_buffer(first, &PL_langinfo_buf,
+                                            &PL_langinfo_bufsize, offset);
+                }
+
+                break;
 
+#  endif
 #  ifdef HAS_LOCALECONV
 
-            case PERL_CRNCYSTR:
+            case CRNCYSTR:
 
                 /* We don't bother with localeconv_l() because any system that
                  * has it is likely to also have nl_langinfo() */
 
-                LOCALE_LOCK;    /* Prevent interference with other threads
-                                   using localeconv() */
+                LOCALECONV_LOCK;    /* Prevent interference with other threads
+                                       using localeconv() */
+
+#    ifdef TS_W32_BROKEN_LOCALECONV
+
+                /* This is a workaround for a Windows bug prior to VS 15.
+                 * What we do here is, while locked, switch to the global
+                 * locale so localeconv() works; then switch back just before
+                 * the unlock.  This can screw things up if some thread is
+                 * already using the global locale while assuming no other is.
+                 * A different workaround would be to call GetCurrencyFormat on
+                 * a known value, and parse it; patches welcome
+                 *
+                 * We have to use LC_ALL instead of LC_MONETARY because of
+                 * another bug in Windows */
+
+                save_thread = savepv(my_setlocale(LC_ALL, NULL));
+                _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+                save_global= savepv(my_setlocale(LC_ALL, NULL));
+                my_setlocale(LC_ALL, save_thread);
+
+#    endif
 
                 lc = localeconv();
                 if (   ! lc
                     || ! lc->currency_symbol
                     || strEQ("", lc->currency_symbol))
                 {
-                    LOCALE_UNLOCK;
+                    LOCALECONV_UNLOCK;
                     return "";
                 }
 
                 /* Leave the first spot empty to be filled in below */
-                save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
-                               &PL_langinfo_bufsize, 1);
+                retval = save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
+                                        &PL_langinfo_bufsize, 1);
                 if (lc->mon_decimal_point && strEQ(lc->mon_decimal_point, ""))
                 { /*  khw couldn't figure out how the localedef specifications
                       would show that the $ should replace the radix; this is
                       just a guess as to how it might work.*/
-                    *PL_langinfo_buf = '.';
+                    PL_langinfo_buf[0] = '.';
                 }
                 else if (lc->p_cs_precedes) {
-                    *PL_langinfo_buf = '-';
+                    PL_langinfo_buf[0] = '-';
+                }
+                else {
+                    PL_langinfo_buf[0] = '+';
+                }
+
+#    ifdef TS_W32_BROKEN_LOCALECONV
+
+                my_setlocale(LC_ALL, save_global);
+                _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+                my_setlocale(LC_ALL, save_thread);
+                Safefree(save_global);
+                Safefree(save_thread);
+
+#    endif
+
+                LOCALECONV_UNLOCK;
+                break;
+
+#    ifdef TS_W32_BROKEN_LOCALECONV
+
+            case RADIXCHAR:
+
+                /* For this, we output a known simple floating point number to
+                 * a buffer, and parse it, looking for the radix */
+
+                if (toggle) {
+                    STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
+                }
+
+                if (PL_langinfo_bufsize < 10) {
+                    PL_langinfo_bufsize = 10;
+                    Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
+                }
+
+                needed_size = my_snprintf(PL_langinfo_buf, PL_langinfo_bufsize,
+                                          "%.1f", 1.5);
+                if (needed_size >= (int) PL_langinfo_bufsize) {
+                    PL_langinfo_bufsize = needed_size + 1;
+                    Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
+                    needed_size = my_snprintf(PL_langinfo_buf, PL_langinfo_bufsize,
+                                             "%.1f", 1.5);
+                    assert(needed_size < (int) PL_langinfo_bufsize);
+                }
+
+                ptr = PL_langinfo_buf;
+                e = PL_langinfo_buf + PL_langinfo_bufsize;
+
+                /* Find the '1' */
+                while (ptr < e && *ptr != '1') {
+                    ptr++;
+                }
+                ptr++;
+
+                /* Find the '5' */
+                item_start = ptr;
+                while (ptr < e && *ptr != '5') {
+                    ptr++;
+                }
+
+                /* Everything in between is the radix string */
+                if (ptr >= e) {
+                    PL_langinfo_buf[0] = '?';
+                    PL_langinfo_buf[1] = '\0';
                 }
                 else {
-                    *PL_langinfo_buf = '+';
+                    *ptr = '\0';
+                    Move(item_start, PL_langinfo_buf, ptr - PL_langinfo_buf, char);
+                }
+
+                if (toggle) {
+                    RESTORE_LC_NUMERIC();
                 }
 
-                LOCALE_UNLOCK;
+                retval = PL_langinfo_buf;
                 break;
 
-            case PERL_RADIXCHAR:
-            case PERL_THOUSEP:
+#    else
+
+            case RADIXCHAR:     /* No special handling needed */
+
+#    endif
+
+            case THOUSEP:
 
                 if (toggle) {
                     STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
                 }
 
-                LOCALE_LOCK;    /* Prevent interference with other threads
-                                   using localeconv() */
+                LOCALECONV_LOCK;    /* Prevent interference with other threads
+                                       using localeconv() */
+
+#    ifdef TS_W32_BROKEN_LOCALECONV
+
+                /* This should only be for the thousands separator.  A
+                 * different work around would be to use GetNumberFormat on a
+                 * known value and parse the result to find the separator */
+                save_thread = savepv(my_setlocale(LC_ALL, NULL));
+                _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+                save_global = savepv(my_setlocale(LC_ALL, NULL));
+                my_setlocale(LC_ALL, save_thread);
+#      if 0
+                /* This is the start of code that for broken Windows replaces
+                 * the above and below code, and instead calls
+                 * GetNumberFormat() and then would parse that to find the
+                 * thousands separator.  It needs to handle UTF-16 vs -8
+                 * issues. */
+
+                needed_size = GetNumberFormatEx(PL_numeric_name, 0, "1234.5", NULL, PL_langinfo_buf, PL_langinfo_bufsize);
+                DEBUG_L(PerlIO_printf(Perl_debug_log,
+                    "%s: %d: return from GetNumber, count=%d, val=%s\n",
+                    __FILE__, __LINE__, needed_size, PL_langinfo_buf));
+
+#      endif
+#    endif
 
                 lc = localeconv();
                 if (! lc) {
-                    retval = "";
+                    temp = "";
                 }
                 else {
-                    retval = (item == PERL_RADIXCHAR)
+                    temp = (item == RADIXCHAR)
                              ? lc->decimal_point
                              : lc->thousands_sep;
-                    if (! retval) {
-                        retval = "";
+                    if (! temp) {
+                        temp = "";
                     }
                 }
 
-                save_to_buffer(retval, &PL_langinfo_buf,
-                               &PL_langinfo_bufsize, 0);
+                retval = save_to_buffer(temp, &PL_langinfo_buf,
+                                        &PL_langinfo_bufsize, 0);
+
+#    ifdef TS_W32_BROKEN_LOCALECONV
+
+                my_setlocale(LC_ALL, save_global);
+                _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+                my_setlocale(LC_ALL, save_thread);
+                Safefree(save_global);
+                Safefree(save_thread);
 
-                LOCALE_UNLOCK;
+#    endif
+
+                LOCALECONV_UNLOCK;
 
                 if (toggle) {
                     RESTORE_LC_NUMERIC();
@@ -1754,32 +2887,26 @@ S_my_nl_langinfo(const int item, bool toggle)
              * for someone using them as formats (as opposed to trying to parse
              * them to figure out what the locale says).  The other format
              * items are actually tested to verify they work on the platform */
-            case PERL_D_FMT:         return "%x";
-            case PERL_T_FMT:         return "%X";
-            case PERL_D_T_FMT:       return "%c";
+            case D_FMT:         return "%x";
+            case T_FMT:         return "%X";
+            case D_T_FMT:       return "%c";
 
             /* These formats are only available in later strfmtime's */
-            case PERL_ERA_D_FMT: case PERL_ERA_T_FMT: case PERL_ERA_D_T_FMT:
-            case PERL_T_FMT_AMPM:
+            case ERA_D_FMT: case ERA_T_FMT: case ERA_D_T_FMT: case T_FMT_AMPM:
 
             /* The rest can be gotten from most versions of strftime(). */
-            case PERL_ABDAY_1: case PERL_ABDAY_2: case PERL_ABDAY_3:
-            case PERL_ABDAY_4: case PERL_ABDAY_5: case PERL_ABDAY_6:
-            case PERL_ABDAY_7:
-            case PERL_ALT_DIGITS:
-            case PERL_AM_STR: case PERL_PM_STR:
-            case PERL_ABMON_1: case PERL_ABMON_2: case PERL_ABMON_3:
-            case PERL_ABMON_4: case PERL_ABMON_5: case PERL_ABMON_6:
-            case PERL_ABMON_7: case PERL_ABMON_8: case PERL_ABMON_9:
-            case PERL_ABMON_10: case PERL_ABMON_11: case PERL_ABMON_12:
-            case PERL_DAY_1: case PERL_DAY_2: case PERL_DAY_3: case PERL_DAY_4:
-            case PERL_DAY_5: case PERL_DAY_6: case PERL_DAY_7:
-            case PERL_MON_1: case PERL_MON_2: case PERL_MON_3: case PERL_MON_4:
-            case PERL_MON_5: case PERL_MON_6: case PERL_MON_7: case PERL_MON_8:
-            case PERL_MON_9: case PERL_MON_10: case PERL_MON_11:
-            case PERL_MON_12:
-
-                LOCALE_LOCK;
+            case ABDAY_1: case ABDAY_2: case ABDAY_3:
+            case ABDAY_4: case ABDAY_5: case ABDAY_6: case ABDAY_7:
+            case ALT_DIGITS:
+            case AM_STR: case PM_STR:
+            case ABMON_1: case ABMON_2: case ABMON_3: case ABMON_4:
+            case ABMON_5: case ABMON_6: case ABMON_7: case ABMON_8:
+            case ABMON_9: case ABMON_10: case ABMON_11: case ABMON_12:
+            case DAY_1: case DAY_2: case DAY_3: case DAY_4:
+            case DAY_5: case DAY_6: case DAY_7:
+            case MON_1: case MON_2: case MON_3: case MON_4:
+            case MON_5: case MON_6: case MON_7: case MON_8:
+            case MON_9: case MON_10: case MON_11: case MON_12:
 
                 init_tm(&tm);   /* Precaution against core dumps */
                 tm.tm_sec = 30;
@@ -1788,95 +2915,99 @@ S_my_nl_langinfo(const int item, bool toggle)
                 tm.tm_year = 2017 - 1900;
                 tm.tm_wday = 0;
                 tm.tm_mon = 0;
+
+                GCC_DIAG_IGNORE_STMT(-Wimplicit-fallthrough);
+
                 switch (item) {
                     default:
-                        LOCALE_UNLOCK;
                         Perl_croak(aTHX_
                                     "panic: %s: %d: switch case: %d problem",
                                        __FILE__, __LINE__, item);
                         NOT_REACHED; /* NOTREACHED */
 
-                    case PERL_PM_STR: tm.tm_hour = 18;
-                    case PERL_AM_STR:
+                    case PM_STR: tm.tm_hour = 18;
+                    case AM_STR:
                         format = "%p";
                         break;
 
-                    case PERL_ABDAY_7: tm.tm_wday++;
-                    case PERL_ABDAY_6: tm.tm_wday++;
-                    case PERL_ABDAY_5: tm.tm_wday++;
-                    case PERL_ABDAY_4: tm.tm_wday++;
-                    case PERL_ABDAY_3: tm.tm_wday++;
-                    case PERL_ABDAY_2: tm.tm_wday++;
-                    case PERL_ABDAY_1:
+                    case ABDAY_7: tm.tm_wday++;
+                    case ABDAY_6: tm.tm_wday++;
+                    case ABDAY_5: tm.tm_wday++;
+                    case ABDAY_4: tm.tm_wday++;
+                    case ABDAY_3: tm.tm_wday++;
+                    case ABDAY_2: tm.tm_wday++;
+                    case ABDAY_1:
                         format = "%a";
                         break;
 
-                    case PERL_DAY_7: tm.tm_wday++;
-                    case PERL_DAY_6: tm.tm_wday++;
-                    case PERL_DAY_5: tm.tm_wday++;
-                    case PERL_DAY_4: tm.tm_wday++;
-                    case PERL_DAY_3: tm.tm_wday++;
-                    case PERL_DAY_2: tm.tm_wday++;
-                    case PERL_DAY_1:
+                    case DAY_7: tm.tm_wday++;
+                    case DAY_6: tm.tm_wday++;
+                    case DAY_5: tm.tm_wday++;
+                    case DAY_4: tm.tm_wday++;
+                    case DAY_3: tm.tm_wday++;
+                    case DAY_2: tm.tm_wday++;
+                    case DAY_1:
                         format = "%A";
                         break;
 
-                    case PERL_ABMON_12: tm.tm_mon++;
-                    case PERL_ABMON_11: tm.tm_mon++;
-                    case PERL_ABMON_10: tm.tm_mon++;
-                    case PERL_ABMON_9: tm.tm_mon++;
-                    case PERL_ABMON_8: tm.tm_mon++;
-                    case PERL_ABMON_7: tm.tm_mon++;
-                    case PERL_ABMON_6: tm.tm_mon++;
-                    case PERL_ABMON_5: tm.tm_mon++;
-                    case PERL_ABMON_4: tm.tm_mon++;
-                    case PERL_ABMON_3: tm.tm_mon++;
-                    case PERL_ABMON_2: tm.tm_mon++;
-                    case PERL_ABMON_1:
+                    case ABMON_12: tm.tm_mon++;
+                    case ABMON_11: tm.tm_mon++;
+                    case ABMON_10: tm.tm_mon++;
+                    case ABMON_9: tm.tm_mon++;
+                    case ABMON_8: tm.tm_mon++;
+                    case ABMON_7: tm.tm_mon++;
+                    case ABMON_6: tm.tm_mon++;
+                    case ABMON_5: tm.tm_mon++;
+                    case ABMON_4: tm.tm_mon++;
+                    case ABMON_3: tm.tm_mon++;
+                    case ABMON_2: tm.tm_mon++;
+                    case ABMON_1:
                         format = "%b";
                         break;
 
-                    case PERL_MON_12: tm.tm_mon++;
-                    case PERL_MON_11: tm.tm_mon++;
-                    case PERL_MON_10: tm.tm_mon++;
-                    case PERL_MON_9: tm.tm_mon++;
-                    case PERL_MON_8: tm.tm_mon++;
-                    case PERL_MON_7: tm.tm_mon++;
-                    case PERL_MON_6: tm.tm_mon++;
-                    case PERL_MON_5: tm.tm_mon++;
-                    case PERL_MON_4: tm.tm_mon++;
-                    case PERL_MON_3: tm.tm_mon++;
-                    case PERL_MON_2: tm.tm_mon++;
-                    case PERL_MON_1:
+                    case MON_12: tm.tm_mon++;
+                    case MON_11: tm.tm_mon++;
+                    case MON_10: tm.tm_mon++;
+                    case MON_9: tm.tm_mon++;
+                    case MON_8: tm.tm_mon++;
+                    case MON_7: tm.tm_mon++;
+                    case MON_6: tm.tm_mon++;
+                    case MON_5: tm.tm_mon++;
+                    case MON_4: tm.tm_mon++;
+                    case MON_3: tm.tm_mon++;
+                    case MON_2: tm.tm_mon++;
+                    case MON_1:
                         format = "%B";
                         break;
 
-                    case PERL_T_FMT_AMPM:
+                    case T_FMT_AMPM:
                         format = "%r";
                         return_format = TRUE;
                         break;
 
-                    case PERL_ERA_D_FMT:
+                    case ERA_D_FMT:
                         format = "%Ex";
                         return_format = TRUE;
                         break;
 
-                    case PERL_ERA_T_FMT:
+                    case ERA_T_FMT:
                         format = "%EX";
                         return_format = TRUE;
                         break;
 
-                    case PERL_ERA_D_T_FMT:
+                    case ERA_D_T_FMT:
                         format = "%Ec";
                         return_format = TRUE;
                         break;
 
-                    case PERL_ALT_DIGITS:
+                    case ALT_DIGITS:
                         tm.tm_wday = 0;
                         format = "%Ow";        /* Find the alternate digit for 0 */
                         break;
                 }
 
+                GCC_DIAG_RESTORE_STMT;
+
                 /* We can't use my_strftime() because it doesn't look at
                  * tm_wday  */
                 while (0 == strftime(PL_langinfo_buf, PL_langinfo_bufsize,
@@ -1939,7 +3070,7 @@ S_my_nl_langinfo(const int item, bool toggle)
                  * alternate format for wday 0.  If the value is the same as
                  * the normal 0, there isn't an alternate, so clear the buffer.
                  * */
-                if (   item == PERL_ALT_DIGITS
+                if (   item == ALT_DIGITS
                     && strEQ(PL_langinfo_buf, "0"))
                 {
                     *PL_langinfo_buf = '\0';
@@ -1966,7 +3097,7 @@ S_my_nl_langinfo(const int item, bool toggle)
                  * wday was chosen because its range is all a single digit.
                  * Things like tm_sec have two digits as the minimum: '00' */
 
-                LOCALE_UNLOCK;
+                retval = PL_langinfo_buf;
 
                 /* If to return the format, not the value, overwrite the buffer
                  * with it.  But some strftime()s will keep the original format
@@ -1976,8 +3107,8 @@ S_my_nl_langinfo(const int item, bool toggle)
                         *PL_langinfo_buf = '\0';
                     }
                     else {
-                        save_to_buffer(format, &PL_langinfo_buf,
-                                        &PL_langinfo_bufsize, 0);
+                        retval = save_to_buffer(format, &PL_langinfo_buf,
+                                                &PL_langinfo_bufsize, 0);
                     }
                 }
 
@@ -1988,7 +3119,7 @@ S_my_nl_langinfo(const int item, bool toggle)
         }
     }
 
-    return PL_langinfo_buf;
+    return retval;
 
 #endif
 
@@ -2048,6 +3179,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
      * values for our db, instead of trying to change them.
      * */
 
+
     int ok = 1;
 
 #ifndef USE_LOCALE
@@ -2057,7 +3189,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #else  /* USE_LOCALE */
 #  ifdef __GLIBC__
 
-    const char * const language   = savepv(PerlEnv_getenv("LANGUAGE"));
+    const char * const language = PerlEnv_getenv("LANGUAGE");
 
 #  endif
 
@@ -2067,8 +3199,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
                                         : "";
     const char* trial_locales[5];   /* 5 = 1 each for "", LC_ALL, LANG, "", C */
     unsigned int trial_locales_count;
-    const char * const lc_all     = savepv(PerlEnv_getenv("LC_ALL"));
-    const char * const lang       = savepv(PerlEnv_getenv("LANG"));
+    const char * const lc_all     = PerlEnv_getenv("LC_ALL");
+    const char * const lang       = PerlEnv_getenv("LANG");
     bool setlocale_failure = FALSE;
     unsigned int i;
 
@@ -2109,8 +3241,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
     DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
 
 #    define DEBUG_LOCALE_INIT(category, locale, result)                     \
-       STMT_START {                                                        \
-               if (debug_initialization) {                                 \
+        STMT_START {                                                        \
+                if (debug_initialization) {                                 \
                     PerlIO_printf(Perl_debug_log,                           \
                                   "%s:%d: %s\n",                            \
                                   __FILE__, __LINE__,                       \
@@ -2118,67 +3250,159 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
                                                           locale,           \
                                                           result));         \
                 }                                                           \
-       } STMT_END
+        } STMT_END
 
 /* Make sure the parallel arrays are properly set up */
 #    ifdef USE_LOCALE_NUMERIC
     assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
     assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_NUMERIC_INDEX] == LC_NUMERIC_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_CTYPE
     assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
     assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_CTYPE_INDEX] == LC_CTYPE_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_COLLATE
     assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
     assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_COLLATE_INDEX] == LC_COLLATE_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_TIME
     assert(categories[LC_TIME_INDEX] == LC_TIME);
     assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_TIME_INDEX] == LC_TIME_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_MESSAGES
     assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
     assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_MESSAGES_INDEX] == LC_MESSAGES_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_MONETARY
     assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
     assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_MONETARY_INDEX] == LC_MONETARY_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_ADDRESS
     assert(categories[LC_ADDRESS_INDEX] == LC_ADDRESS);
     assert(strEQ(category_names[LC_ADDRESS_INDEX], "LC_ADDRESS"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_ADDRESS_INDEX] == LC_ADDRESS_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_IDENTIFICATION
     assert(categories[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION);
     assert(strEQ(category_names[LC_IDENTIFICATION_INDEX], "LC_IDENTIFICATION"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_MEASUREMENT
     assert(categories[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT);
     assert(strEQ(category_names[LC_MEASUREMENT_INDEX], "LC_MEASUREMENT"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_PAPER
     assert(categories[LC_PAPER_INDEX] == LC_PAPER);
     assert(strEQ(category_names[LC_PAPER_INDEX], "LC_PAPER"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_PAPER_INDEX] == LC_PAPER_MASK);
+#      endif
 #    endif
 #    ifdef USE_LOCALE_TELEPHONE
     assert(categories[LC_TELEPHONE_INDEX] == LC_TELEPHONE);
     assert(strEQ(category_names[LC_TELEPHONE_INDEX], "LC_TELEPHONE"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_TELEPHONE_INDEX] == LC_TELEPHONE_MASK);
+#      endif
+#    endif
+#    ifdef USE_LOCALE_SYNTAX
+    assert(categories[LC_SYNTAX_INDEX] == LC_SYNTAX);
+    assert(strEQ(category_names[LC_SYNTAX_INDEX], "LC_SYNTAX"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_SYNTAX_INDEX] == LC_SYNTAX_MASK);
+#      endif
+#    endif
+#    ifdef USE_LOCALE_TOD
+    assert(categories[LC_TOD_INDEX] == LC_TOD);
+    assert(strEQ(category_names[LC_TOD_INDEX], "LC_TOD"));
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_TOD_INDEX] == LC_TOD_MASK);
+#      endif
 #    endif
 #    ifdef LC_ALL
     assert(categories[LC_ALL_INDEX] == LC_ALL);
     assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
     assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
+#      ifdef USE_POSIX_2008_LOCALE
+    assert(category_masks[LC_ALL_INDEX] == LC_ALL_MASK);
+#      endif
 #    endif
 #  endif    /* DEBUGGING */
 
+    /* Initialize the per-thread mbrFOO() state variables.  See POSIX.xs for
+     * why these particular incantations are used. */
+#ifdef HAS_MBRLEN
+    memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
+#endif
+#ifdef HAS_MBRTOWC
+    memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
+#endif
+#ifdef HAS_WCTOMBR
+    wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
+#endif
+
     /* Initialize the cache of the program's UTF-8ness for the always known
      * locales C and POSIX */
     my_strlcpy(PL_locale_utf8ness, C_and_POSIX_utf8ness,
                sizeof(PL_locale_utf8ness));
 
+#  ifdef USE_THREAD_SAFE_LOCALE
+#    ifdef WIN32
+
+    _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+
+#    endif
+#  endif
+#  ifdef USE_POSIX_2008_LOCALE
+
+    PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
+    if (! PL_C_locale_obj) {
+        Perl_croak_nocontext(
+            "panic: Cannot create POSIX 2008 C locale object; errno=%d", errno);
+    }
+    if (DEBUG_Lv_TEST || debug_initialization) {
+        PerlIO_printf(Perl_debug_log, "%s:%d: created C object %p\n", __FILE__, __LINE__, PL_C_locale_obj);
+    }
+
+#  endif
+
+#  ifdef USE_LOCALE_NUMERIC
+
     PL_numeric_radix_sv = newSVpvs(".");
 
+#  endif
+
+#  if defined(USE_POSIX_2008_LOCALE) && ! defined(HAS_QUERYLOCALE)
+
+    /* Initialize our records.  If we have POSIX 2008, we have LC_ALL */
+    do_setlocale_c(LC_ALL, my_setlocale(LC_ALL, NULL));
+
+#  endif
 #  ifdef LOCALE_ENVIRON_REQUIRED
 
     /*
@@ -2537,11 +3761,12 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 
     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
 
-#  if defined(USE_ITHREADS)
+#  if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
 
         /* This caches whether each category's locale is UTF-8 or not.  This
          * may involve changing the locale.  It is ok to do this at
-         * initialization time before any threads have started, but not later.
+         * initialization time before any threads have started, but not later
+         * unless thread-safe operations are used.
          * Caching means that if the program heeds our dictate not to change
          * locales in threaded applications, this data will remain valid, and
          * it may get queried without having to change locales.  If the
@@ -2570,22 +3795,13 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
        This is an alternative to using the -C command line switch
        (the -C if present will override this). */
     {
-        const char *p = PerlEnv_getenv("PERL_UNICODE");
-        PL_unicode = p ? parse_unicode_opts(&p) : 0;
-        if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
-            PL_utf8cache = -1;
+         const char *p = PerlEnv_getenv("PERL_UNICODE");
+         PL_unicode = p ? parse_unicode_opts(&p) : 0;
+         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
+             PL_utf8cache = -1;
     }
 
 #  endif
-#  ifdef __GLIBC__
-
-    Safefree(language);
-
-#  endif
-
-    Safefree(lc_all);
-    Safefree(lang);
-
 #endif /* USE_LOCALE */
 #ifdef DEBUGGING
 
@@ -2711,6 +3927,7 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
                                  cur_min_x + COLLXFRM_HDR_LEN))
                     {
                         PL_strxfrm_NUL_replacement = j;
+                        Safefree(cur_min_x);
                         cur_min_x = x;
                     }
                     else {
@@ -2866,6 +4083,7 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
                                      cur_max_x + COLLXFRM_HDR_LEN))
                         {
                             PL_strxfrm_max_cp = j;
+                            Safefree(cur_max_x);
                             cur_max_x = x;
                         }
                         else {
@@ -2943,7 +4161,7 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
     if (UNLIKELY(! xbuf)) {
         DEBUG_L(PerlIO_printf(Perl_debug_log,
                       "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
-       goto bad;
+        goto bad;
     }
 
     /* Store the collation id */
@@ -3107,11 +4325,6 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
     return xbuf;
 
   bad:
-    Safefree(xbuf);
-    if (s != input_string) {
-        Safefree(s);
-    }
-    *xlen = 0;
 
 #  ifdef DEBUGGING
 
@@ -3121,6 +4334,12 @@ Perl__mem_collxfrm(pTHX_ const char *input_string,
 
 #  endif
 
+    Safefree(xbuf);
+    if (s != input_string) {
+        Safefree(s);
+    }
+    *xlen = 0;
+
     return NULL;
 }
 
@@ -3151,6 +4370,11 @@ S_print_collxfrm_input_and_return(pTHX_
     PerlIO_printf(Perl_debug_log, "'\n");
 }
 
+#  endif    /* DEBUGGING */
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE
+#  ifdef DEBUGGING
+
 STATIC void
 S_print_bytes_for_locale(pTHX_
                     const char * const s,
@@ -3187,9 +4411,6 @@ S_print_bytes_for_locale(pTHX_
 }
 
 #  endif   /* #ifdef DEBUGGING */
-#endif /* USE_LOCALE_COLLATE */
-
-#ifdef USE_LOCALE
 
 STATIC const char *
 S_switch_category_locale_to_template(pTHX_ const int switch_category, const int template_category, const char * template_locale)
@@ -3233,7 +4454,7 @@ S_switch_category_locale_to_template(pTHX_ const int switch_category, const int
         Safefree(restore_to_locale);
 
         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale unchanged as %s\n",
-                            category_name(switch_category), restore_to_locale));
+                            category_name(switch_category), template_locale));
 
         return NULL;
     }
@@ -3273,6 +4494,9 @@ S_restore_switched_locale(pTHX_ const int category, const char * const original_
     Safefree(original_locale);
 }
 
+/* is_cur_LC_category_utf8 uses a small char buffer to avoid malloc/free */
+#define CUR_LC_BUFFER_SIZE  64
+
 bool
 Perl__is_cur_LC_category_utf8(pTHX_ int category)
 {
@@ -3310,6 +4534,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
                                                the name in the cache */
     char * delimited;           /* The name plus the delimiters used to store
                                    it in the cache */
+    char buffer[CUR_LC_BUFFER_SIZE];        /* small buffer */
     char * name_pos;            /* position of 'delimited' in the cache, or 0
                                    if not there */
 
@@ -3338,9 +4563,15 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
      * utf8ness digit */
     input_name_len_with_overhead = input_name_len + 3;
 
-    /* Allocate and populate space for a copy of the name surrounded by the
-     * delimiters */
-    Newx(delimited, input_name_len_with_overhead, char);
+    if ( input_name_len_with_overhead <= CUR_LC_BUFFER_SIZE ) {
+        /* we can use the buffer, avoid a malloc */
+        delimited = buffer;
+    } else { /* need a malloc */
+        /* Allocate and populate space for a copy of the name surrounded by the
+         * delimiters */
+        Newx(delimited, input_name_len_with_overhead, char);
+    }
+
     delimited[0] = UTF8NESS_SEP[0];
     Copy(save_input_locale, delimited + 1, input_name_len, char);
     delimited[input_name_len+1] = UTF8NESS_PREFIX[0];
@@ -3374,7 +4605,8 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
             utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
         }
 
-        Safefree(delimited);
+        /* free only when not using the buffer */
+        if ( delimited != buffer ) Safefree(delimited);
         Safefree(save_input_locale);
         return is_utf8;
     }
@@ -3383,7 +4615,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
      * calculate it */
 
 #  if        defined(USE_LOCALE_CTYPE)                                  \
-     && (   (defined(HAS_NL_LANGINFO) && defined(CODESET))              \
+     && (    defined(HAS_NL_LANGINFO)                                   \
          || (defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)))
 
     {
@@ -3411,7 +4643,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
             }
 
 #    endif
-#    if defined(HAS_NL_LANGINFO) && defined(CODESET)
+#    if defined(HAS_NL_LANGINFO)
 
         { /* The task is easiest if the platform has this POSIX 2001 function.
              Except on some platforms it can wrongly return "", so have to have
@@ -3421,7 +4653,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
              defective locale definition.  XXX We should probably check for
              these in the Latin1 range and warn (but on glibc, requires
              iswalnum() etc. due to their not handling 80-FF correctly */
-            const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE);
+            const char *codeset = my_nl_langinfo(CODESET, FALSE);
                                           /* FALSE => already in dest locale */
 
             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
@@ -3479,12 +4711,12 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
 
 #      else
 
-            LOCALE_LOCK;
+            MBTOWC_LOCK;
             PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
             SETERRNO(0, 0);
             len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
             SAVE_ERRNO;
-            LOCALE_UNLOCK;
+            MBTOWC_UNLOCK;
 
 #      endif
 
@@ -3497,11 +4729,12 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
                             && wc == (wchar_t) UNICODE_REPLACEMENT);
         }
 
+#    endif
+
         restore_switched_locale(LC_CTYPE, original_ctype_locale);
         goto finish_and_return;
     }
 
-#    endif
 #  else
 
         /* Here, we must have a C89 compiler that doesn't have mbtowc().  Next
@@ -3524,7 +4757,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
                                                              save_input_locale);
             bool only_ascii = FALSE;
             const U8 * currency_string
-                            = (const U8 *) my_nl_langinfo(PERL_CRNCYSTR, FALSE);
+                            = (const U8 *) my_nl_langinfo(CRNCYSTR, FALSE);
                                       /* 2nd param not relevant for this item */
             const U8 * first_variant;
 
@@ -3733,9 +4966,9 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
             is_utf8 = TRUE;
             goto finish_and_return;
         }
-    }
 
 #      endif
+    }
 #    endif
 
     /* Other common encodings are the ISO 8859 series, which aren't UTF-8.  But
@@ -3799,9 +5032,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
         Copy(delimited, utf8ness_cache, input_name_len_with_overhead - 1, char);
         utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
 
-        if ((PL_locale_utf8ness[strlen(PL_locale_utf8ness)-1]
-                                                & (PERL_UINTMAX_T) ~1) != '0')
-        {
+        if ((PL_locale_utf8ness[strlen(PL_locale_utf8ness)-1] & ~1) != '0') {
             Perl_croak(aTHX_
              "panic: %s: %d: Corrupt utf8ness_cache=%s\nlen=%zu,"
              " inserted_name=%s, its_len=%zu\n",
@@ -3831,6 +5062,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
             s++;
             e = strchr(s, UTF8NESS_PREFIX[0]);
             if (! e) {
+                e = PL_locale_utf8ness + strlen(PL_locale_utf8ness);
                 Perl_croak(aTHX_
                            "panic: %s: %d: Corrupt utf8ness_cache: missing"
                            " separator %.*s<-- HERE %s\n",
@@ -3868,7 +5100,8 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
 
 #  endif
 
-    Safefree(delimited);
+    /* free only when not using the buffer */
+    if ( delimited != buffer ) Safefree(delimited);
     Safefree(save_input_locale);
     return is_utf8;
 }
@@ -3878,22 +5111,21 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category)
 bool
 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
 {
-    dVAR;
     /* Internal function which returns if we are in the scope of a pragma that
      * enables the locale category 'category'.  'compiling' should indicate if
      * this is during the compilation phase (TRUE) or not (FALSE). */
 
     const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
 
-    SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
-    if (! categories || categories == &PL_sv_placeholder) {
+    SV *these_categories = cop_hints_fetch_pvs(cop, "locale", 0);
+    if (! these_categories || these_categories == &PL_sv_placeholder) {
         return FALSE;
     }
 
     /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
      * a valid unsigned */
     assert(category >= -1);
-    return cBOOL(SvUV(categories) & (1U << (category + 1)));
+    return cBOOL(SvUV(these_categories) & (1U << (category + 1)));
 }
 
 char *
@@ -3909,7 +5141,6 @@ Perl_my_strerror(pTHX_ const int errnum)
      * to the C locale */
 
     char *errstr;
-    dVAR;
 
 #ifndef USE_LOCALE_MESSAGES
 
@@ -3922,19 +5153,33 @@ Perl_my_strerror(pTHX_ const int errnum)
 
     const bool within_locale_scope = IN_LC(LC_MESSAGES);
 
-#  if defined(HAS_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
+#  ifndef USE_ITHREADS
 
-    /* This function is trivial if we don't have to worry about thread safety
-     * and have strerror_l(), as it handles the switch of locales so we don't
-     * have to deal with that.  We don't have to worry about thread safety if
-     * this is an unthreaded build, or if strerror_r() is also available.  Both
-     * it and strerror_l() are thread-safe.  Plain strerror() isn't thread
-     * safe.  But on threaded builds when strerror_r() is available, the
-     * apparent call to strerror() below is actually a macro that
-     * behind-the-scenes calls strerror_r().
-     */
+    /* This function is trivial without threads. */
+    if (within_locale_scope) {
+        errstr = savepv(strerror(errnum));
+    }
+    else {
+        const char * save_locale = savepv(do_setlocale_c(LC_MESSAGES, NULL));
+
+        do_setlocale_c(LC_MESSAGES, "C");
+        errstr = savepv(strerror(errnum));
+        do_setlocale_c(LC_MESSAGES, save_locale);
+        Safefree(save_locale);
+    }
+
+#  elif   defined(USE_POSIX_2008_LOCALE)                      \
+     &&   defined(HAS_STRERROR_L)
 
-#    if ! defined(USE_ITHREADS) || defined(HAS_STRERROR_R)
+    /* This function is also trivial if we don't have to worry about thread
+     * safety and have strerror_l(), as it handles the switch of locales so we
+     * don't have to deal with that.  We don't have to worry about thread
+     * safety if strerror_r() is also available.  Both it and strerror_l() are
+     * thread-safe.  Plain strerror() isn't thread safe.  But on threaded
+     * builds when strerror_r() is available, the apparent call to strerror()
+     * below is actually a macro that behind-the-scenes calls strerror_r(). */
+
+#    ifdef HAS_STRERROR_R
 
     if (within_locale_scope) {
         errstr = savepv(strerror(errnum));
@@ -3972,47 +5217,21 @@ Perl_my_strerror(pTHX_ const int errnum)
 #    endif
 #  else /* Doesn't have strerror_l() */
 
-#    ifdef USE_POSIX_2008_LOCALE
-
-    locale_t save_locale = NULL;
-
-#    else
-
     const char * save_locale = NULL;
     bool locale_is_C = FALSE;
 
     /* We have a critical section to prevent another thread from executing this
-     * same code at the same time.  (On unthreaded perls, the LOCK is a
+     * same code at the same time.  (On thread-safe perls, the LOCK is a
      * no-op.)  Since this is the only place in core that changes LC_MESSAGES
      * (unless the user has called setlocale(), this works to prevent races. */
-    LOCALE_LOCK;
-
-#    endif
+    SETLOCALE_LOCK;
 
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
                             "my_strerror called with errnum %d\n", errnum));
     if (! within_locale_scope) {
-        errno = 0;
-
-#  ifdef USE_POSIX_2008_LOCALE /* Use the thread-safe locale functions */
-
-        DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                                    "Not within locale scope, about to call"
-                                    " uselocale(0x%p)\n", PL_C_locale_obj));
-        save_locale = uselocale(PL_C_locale_obj);
-        if (! save_locale) {
-            DEBUG_L(PerlIO_printf(Perl_debug_log,
-                                    "uselocale failed, errno=%d\n", errno));
-        }
-        else {
-            DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                                    "uselocale returned 0x%p\n", save_locale));
-        }
-
-#    else    /* Not thread-safe build */
-
         save_locale = do_setlocale_c(LC_MESSAGES, NULL);
         if (! save_locale) {
+            SETLOCALE_UNLOCK;
             Perl_croak(aTHX_
                  "panic: %s: %d: Could not find current LC_MESSAGES locale,"
                  " errno=%d\n", __FILE__, __LINE__, errno);
@@ -4026,12 +5245,21 @@ Perl_my_strerror(pTHX_ const int errnum)
                 /* The setlocale() just below likely will zap 'save_locale', so
                  * create a copy.  */
                 save_locale = savepv(save_locale);
-                do_setlocale_c(LC_MESSAGES, "C");
+                if (! do_setlocale_c(LC_MESSAGES, "C")) {
+
+                    /* If, for some reason, the locale change failed, we
+                     * soldier on as best as possible under the circumstances,
+                     * using the current locale, and clear save_locale, so we
+                     * don't try to change back.  On z/0S, all setlocale()
+                     * calls fail after you've created a thread.  This is their
+                     * way of making sure the entire process is always a single
+                     * locale.  This means that 'use locale' is always in place
+                     * for messages under these circumstances. */
+                    Safefree(save_locale);
+                    save_locale = NULL;
+                }
             }
         }
-
-#    endif
-
     }   /* end of ! within_locale_scope */
     else {
         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
@@ -4043,38 +5271,21 @@ Perl_my_strerror(pTHX_ const int errnum)
     errstr = savepv(Strerror(errnum));
 
     if (! within_locale_scope) {
-        errno = 0;
-
-#  ifdef USE_POSIX_2008_LOCALE
-
-        DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                    "%s: %d: not within locale scope, restoring the locale\n",
-                    __FILE__, __LINE__));
-        if (save_locale && ! uselocale(save_locale)) {
-            DEBUG_L(PerlIO_printf(Perl_debug_log,
-                          "uselocale restore failed, errno=%d\n", errno));
-        }
-    }
-
-#    else
-
         if (save_locale && ! locale_is_C) {
             if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
+                SETLOCALE_UNLOCK;
                 Perl_croak(aTHX_
-                     "panic: %s: %d: setlocale restore failed, errno=%d\n",
-                             __FILE__, __LINE__, errno);
+                     "panic: %s: %d: setlocale restore to '%s' failed, errno=%d\n",
+                             __FILE__, __LINE__, save_locale, errno);
             }
             Safefree(save_locale);
         }
     }
 
-    LOCALE_UNLOCK;
+    SETLOCALE_UNLOCK;
 
-#    endif
 #  endif /* End of doesn't have strerror_l */
-#endif   /* End of does have locale messages */
-
-#ifdef DEBUGGING
+#  ifdef DEBUGGING
 
     if (DEBUG_Lv_TEST) {
         PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
@@ -4082,7 +5293,8 @@ Perl_my_strerror(pTHX_ const int errnum)
         PerlIO_printf(Perl_debug_log, "'\n");
     }
 
-#endif
+#  endif
+#endif   /* End of does have locale messages */
 
     SAVEFREEPV(errstr);
     return errstr;
@@ -4090,48 +5302,200 @@ Perl_my_strerror(pTHX_ const int errnum)
 
 /*
 
-=for apidoc sync_locale
+=for apidoc switch_to_global_locale
+
+On systems without locale support, or on typical single-threaded builds, or on
+platforms that do not support per-thread locale operations, this function does
+nothing.  On such systems that do have locale support, only a locale global to
+the whole program is available.
+
+On multi-threaded builds on systems that do have per-thread locale operations,
+this function converts the thread it is running in to use the global locale.
+This is for code that has not yet or cannot be updated to handle multi-threaded
+locale operation.  As long as only a single thread is so-converted, everything
+works fine, as all the other threads continue to ignore the global one, so only
+this thread looks at it.
+
+However, on Windows systems this isn't quite true prior to Visual Studio 15,
+at which point Microsoft fixed a bug.  A race can occur if you use the
+following operations on earlier Windows platforms:
+
+=over
+
+=item L<POSIX::localeconv|POSIX/localeconv>
+
+=item L<I18N::Langinfo>, items C<CRNCYSTR> and C<THOUSEP>
 
-Changing the program's locale should be avoided by XS code.  Nevertheless,
-certain non-Perl libraries called from XS, such as C<Gtk> do so.  When this
-happens, Perl needs to be told that the locale has changed.  Use this function
-to do so, before returning to Perl.
+=item L<perlapi/Perl_langinfo>, items C<CRNCYSTR> and C<THOUSEP>
+
+=back
+
+The first item is not fixable (except by upgrading to a later Visual Studio
+release), but it would be possible to work around the latter two items by using
+the Windows API functions C<GetNumberFormat> and C<GetCurrencyFormat>; patches
+welcome.
+
+Without this function call, threads that use the L<C<setlocale(3)>> system
+function will not work properly, as all the locale-sensitive functions will
+look at the per-thread locale, and C<setlocale> will have no effect on this
+thread.
+
+Perl code should convert to either call
+L<C<Perl_setlocale>|perlapi/Perl_setlocale> (which is a drop-in for the system
+C<setlocale>) or use the methods given in L<perlcall> to call
+L<C<POSIX::setlocale>|POSIX/setlocale>.  Either one will transparently properly
+handle all cases of single- vs multi-thread, POSIX 2008-supported or not.
+
+Non-Perl libraries, such as C<gtk>, that call the system C<setlocale> can
+continue to work if this function is called before transferring control to the
+library.
+
+Upon return from the code that needs to use the global locale,
+L<C<sync_locale()>|perlapi/sync_locale> should be called to restore the safe
+multi-thread operation.
 
 =cut
 */
 
 void
-Perl_sync_locale(pTHX)
+Perl_switch_to_global_locale()
 {
-    char * newlocale;
 
-#ifdef USE_LOCALE_CTYPE
+#ifdef USE_THREAD_SAFE_LOCALE
+#  ifdef WIN32
+
+    _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+
+#  else
+#    ifdef HAS_QUERYLOCALE
+
+    setlocale(LC_ALL, querylocale(LC_ALL_MASK, uselocale((locale_t) 0)));
+
+#    else
+
+    {
+        unsigned int i;
+
+        for (i = 0; i < LC_ALL_INDEX; i++) {
+            setlocale(categories[i], do_setlocale_r(categories[i], NULL));
+        }
+    }
+
+#    endif
+
+    uselocale(LC_GLOBAL_LOCALE);
+
+#  endif
+#endif
+
+}
+
+/*
+
+=for apidoc sync_locale
+
+L<C<Perl_setlocale>|perlapi/Perl_setlocale> can be used at any time to query or
+change the locale (though changing the locale is antisocial and dangerous on
+multi-threaded systems that don't have multi-thread safe locale operations.
+(See L<perllocale/Multi-threaded operation>).  Using the system
+L<C<setlocale(3)>> should be avoided.  Nevertheless, certain non-Perl libraries
+called from XS, such as C<Gtk> do so, and this can't be changed.  When the
+locale is changed by XS code that didn't use
+L<C<Perl_setlocale>|perlapi/Perl_setlocale>, Perl needs to be told that the
+locale has changed.  Use this function to do so, before returning to Perl.
+
+The return value is a boolean: TRUE if the global locale at the time of call
+was in effect; and FALSE if a per-thread locale was in effect.  This can be
+used by the caller that needs to restore things as-they-were to decide whether
+or not to call
+L<C<Perl_switch_to_global_locale>|perlapi/switch_to_global_locale>.
+
+=cut
+*/
+
+bool
+Perl_sync_locale()
+{
+
+#ifndef USE_LOCALE
+
+    return TRUE;
+
+#else
+
+    const char * newlocale;
+    dTHX;
+
+#  ifdef USE_POSIX_2008_LOCALE
+
+    bool was_in_global_locale = FALSE;
+    locale_t cur_obj = uselocale((locale_t) 0);
+
+    /* On Windows, unless the foreign code has turned off the thread-safe
+     * locale setting, any plain setlocale() will have affected what we see, so
+     * no need to worry.  Otherwise, If the foreign code has done a plain
+     * setlocale(), it will only affect the global locale on POSIX systems, but
+     * will affect the */
+    if (cur_obj == LC_GLOBAL_LOCALE) {
+
+#    ifdef HAS_QUERY_LOCALE
+
+        do_setlocale_c(LC_ALL, setlocale(LC_ALL, NULL));
+
+#    else
+
+        unsigned int i;
+
+        /* We can't trust that we can read the LC_ALL format on the
+         * platform, so do them individually */
+        for (i = 0; i < LC_ALL_INDEX; i++) {
+            do_setlocale_r(categories[i], setlocale(categories[i], NULL));
+        }
+
+#    endif
+
+        was_in_global_locale = TRUE;
+    }
+
+#  else
 
-    newlocale = do_setlocale_c(LC_CTYPE, NULL);
+    bool was_in_global_locale = TRUE;
+
+#  endif
+#  ifdef USE_LOCALE_CTYPE
+
+    newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
         "%s:%d: %s\n", __FILE__, __LINE__,
         setlocale_debug_string(LC_CTYPE, NULL, newlocale)));
     new_ctype(newlocale);
+    Safefree(newlocale);
 
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
+#  endif /* USE_LOCALE_CTYPE */
+#  ifdef USE_LOCALE_COLLATE
 
-    newlocale = do_setlocale_c(LC_COLLATE, NULL);
+    newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
         "%s:%d: %s\n", __FILE__, __LINE__,
         setlocale_debug_string(LC_COLLATE, NULL, newlocale)));
     new_collate(newlocale);
+    Safefree(newlocale);
 
-#endif
-#ifdef USE_LOCALE_NUMERIC
+#  endif
+#  ifdef USE_LOCALE_NUMERIC
 
-    newlocale = do_setlocale_c(LC_NUMERIC, NULL);
+    newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
         "%s:%d: %s\n", __FILE__, __LINE__,
         setlocale_debug_string(LC_NUMERIC, NULL, newlocale)));
     new_numeric(newlocale);
+    Safefree(newlocale);
 
-#endif /* USE_LOCALE_NUMERIC */
+#  endif /* USE_LOCALE_NUMERIC */
+
+    return was_in_global_locale;
+
+#endif
 
 }
 
@@ -4151,11 +5515,7 @@ S_setlocale_debug_string(const int category,        /* category number,
      * be overwritten by the next call, so this should be used just to
      * formulate a string to immediately print or savepv() on. */
 
-    /* initialise to a non-null value to keep it out of BSS and so keep
-     * -DPERL_GLOBAL_STRUCT_PRIVATE happy */
-    static char ret[128] = "If you can read this, thank your buggy C"
-                           " library strlcpy(), and change your hints file"
-                           " to undef it";
+    static char ret[256];
 
     my_strlcpy(ret, "setlocale(", sizeof(ret));
     my_strlcat(ret, category_name(category), sizeof(ret));
@@ -4188,6 +5548,58 @@ S_setlocale_debug_string(const int category,        /* category number,
 
 #endif
 
+void
+Perl_thread_locale_init()
+{
+    /* Called from a thread on startup*/
+
+#ifdef USE_THREAD_SAFE_LOCALE
+
+    dTHX_DEBUGGING;
+
+    /* C starts the new thread in the global C locale.  If we are thread-safe,
+     * we want to not be in the global locale */
+
+     DEBUG_L(PerlIO_printf(Perl_debug_log,
+            "%s:%d: new thread, initial locale is %s; calling setlocale\n",
+            __FILE__, __LINE__, setlocale(LC_ALL, NULL)));
+
+#  ifdef WIN32
+
+    _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+
+#  else
+
+    Perl_setlocale(LC_ALL, "C");
+
+#  endif
+#endif
+
+}
+
+void
+Perl_thread_locale_term()
+{
+    /* Called from a thread as it gets ready to terminate */
+
+#ifdef USE_THREAD_SAFE_LOCALE
+
+    /* C starts the new thread in the global C locale.  If we are thread-safe,
+     * we want to not be in the global locale */
+
+#  ifndef WIN32
+
+    {   /* Free up */
+        locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
+        if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
+            freelocale(cur_obj);
+        }
+    }
+
+#  endif
+#endif
+
+}
 
 /*
  * ex: set ts=8 sts=4 sw=4 et: