Fix broken API: sync_locale()

This fixes GH #20565.

Lack of tests allowed sync_locale() to get broken until CPAN testing
showed it so.

Basically, I blew it in 9f5a615be674d7663d3b4719849baa1ba3027f5b.  Most
egregiously, I forgot to turn back on when a sync_locale() is executed,
the toggling for locales whose radix character isn't a dot.  And this
needs a way to tell the other code that it needs to recompute things at
this time, since our records don't reflect what happened before the
sync.

5 files changed, 63 insertions, 48 deletions

diff --git a/embed.fnc b/embed.fnc
index dd4e92e538..7e4863a514 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -3388,13 +3388,13 @@ ST	|const char *|save_to_buffer|NULLOK const char * string	\
 				    |NULLOK Size_t *buf_size
 ST	|unsigned int|get_category_index|const int category|NULLOK const char * locale
 #    ifdef USE_LOCALE_CTYPE
-S	|void	|new_ctype	|NN const char* newctype
+S	|void	|new_ctype	|NN const char* newctype|bool force
 ST	|bool	|is_codeset_name_UTF8|NN const char * name
 #    endif
 #    ifdef USE_LOCALE_NUMERIC
-S	|void	|new_numeric	|NN const char* newnum
+S	|void	|new_numeric	|NN const char* newnum|bool force
 #    endif
-S	|void	|new_LC_ALL	|NULLOK const char* unused
+S	|void	|new_LC_ALL	|NULLOK const char* unused|bool force
 S	|const char*|stdize_locale|const int category			\
 				|NULLOK const char* input_locale	\
 				|NULLOK const char **buf		\
@@ -3458,7 +3458,7 @@ S	|const char *|calculate_LC_ALL|NN const char ** individ_locales
 #      endif
 #    endif
 #    ifdef USE_LOCALE_COLLATE
-S	|void	|new_collate	|NN const char* newcoll
+S	|void	|new_collate	|NN const char* newcoll|bool force
 #      ifdef DEBUGGING
 S	|void	|print_collxfrm_input_and_return		\
 			    |NN const char * s			\
diff --git a/embed.h b/embed.h
index 6ec6300736..6dbaac205a 100644
--- a/embed.h
+++ b/embed.h
@@ -1777,19 +1777,19 @@
 #    if defined(USE_LOCALE)
 #define get_category_index	S_get_category_index
 #define mortalized_pv_copy(a)	S_mortalized_pv_copy(aTHX_ a)
-#define new_LC_ALL(a)		S_new_LC_ALL(aTHX_ a)
+#define new_LC_ALL(a,b)		S_new_LC_ALL(aTHX_ a,b)
 #define save_to_buffer		S_save_to_buffer
 #define setlocale_failure_panic_i(a,b,c,d,e)	S_setlocale_failure_panic_i(aTHX_ a,b,c,d,e)
 #define stdize_locale(a,b,c,d,e)	S_stdize_locale(aTHX_ a,b,c,d,e)
 #      if defined(USE_LOCALE_COLLATE)
-#define new_collate(a)		S_new_collate(aTHX_ a)
+#define new_collate(a,b)	S_new_collate(aTHX_ a,b)
 #      endif
 #      if defined(USE_LOCALE_CTYPE)
 #define is_codeset_name_UTF8	S_is_codeset_name_UTF8
-#define new_ctype(a)		S_new_ctype(aTHX_ a)
+#define new_ctype(a,b)		S_new_ctype(aTHX_ a,b)
 #      endif
 #      if defined(USE_LOCALE_NUMERIC)
-#define new_numeric(a)		S_new_numeric(aTHX_ a)
+#define new_numeric(a,b)	S_new_numeric(aTHX_ a,b)
 #      endif
 #      if defined(USE_POSIX_2008_LOCALE)
 #define emulate_setlocale_i(a,b,c,d)	S_emulate_setlocale_i(aTHX_ a,b,c,d)
diff --git a/ext/XS-APItest/t/locale.t b/ext/XS-APItest/t/locale.t
index 19efa9546b..1a14fb45cf 100644
--- a/ext/XS-APItest/t/locale.t
+++ b/ext/XS-APItest/t/locale.t
@@ -62,12 +62,8 @@ SKIP: {
        "comma recognized in global comma locale for SvNV");
     isnt(sync_locale, 0, "sync_locale() returns that was in the global locale");
 
-    TODO: {
-        local $TODO = "GH #20565";
-
-        is(check_in_bounds(newSvNV("4.888"), 4.88, 4.89), 1,
-        "dot recognized in perl-controlled comma locale for SvNV");
-    }
+    is(check_in_bounds(newSvNV("4.888"), 4.88, 4.89), 1,
+    "dot recognized in perl-controlled comma locale for SvNV");
 }
 
 my %correct_C_responses = (
diff --git a/locale.c b/locale.c
index d2117d2ca3..885faff836 100644
--- a/locale.c
+++ b/locale.c
@@ -355,7 +355,7 @@ STATIC const char * const category_names[] = {
 
 /* A few categories require additional setup when they are changed.  This table
  * points to the functions that do that setup */
-STATIC void (*update_functions[]) (pTHX_ const char *) = {
+STATIC void (*update_functions[]) (pTHX_ const char *, bool force) = {
 #  ifdef USE_LOCALE_CTYPE
                                 S_new_ctype,
 #  endif
@@ -1826,7 +1826,7 @@ S_setlocale_failure_panic_i(pTHX_
 #  ifdef USE_LOCALE_NUMERIC
 
 STATIC void
-S_new_numeric(pTHX_ const char *newnum)
+S_new_numeric(pTHX_ const char *newnum, bool force)
 {
     PERL_ARGS_ASSERT_NEW_NUMERIC;
 
@@ -1880,8 +1880,10 @@ S_new_numeric(pTHX_ const char *newnum)
                            "Called new_numeric with %s, PL_numeric_name=%s\n",
                            newnum, PL_numeric_name));
 
-    /* If this isn't actually a change, do nothing */
-    if (strEQ(PL_numeric_name, newnum)) {
+    /* If not forcing this procedure, and there isn't actually a change from
+     * our records, do nothing.  (Our records can be wrong when sync'ing to the
+     * locale set up by an external library, hence the 'force' parameter) */
+    if (! force && strEQ(PL_numeric_name, newnum)) {
         return;
     }
 
@@ -2040,9 +2042,10 @@ Perl_set_numeric_underlying(pTHX)
 #  ifdef USE_LOCALE_CTYPE
 
 STATIC void
-S_new_ctype(pTHX_ const char *newctype)
+S_new_ctype(pTHX_ const char *newctype, bool force)
 {
     PERL_ARGS_ASSERT_NEW_CTYPE;
+    PERL_UNUSED_ARG(force);
 
     /* Called after each libc setlocale() call affecting LC_CTYPE, to tell
      * core Perl this and that 'newctype' is the name of the new locale.
@@ -2473,18 +2476,17 @@ Perl__warn_problematic_locale()
 }
 
 STATIC void
-S_new_LC_ALL(pTHX_ const char *unused)
+S_new_LC_ALL(pTHX_ const char *unused, bool force)
 {
-    unsigned int i;
+    PERL_ARGS_ASSERT_NEW_LC_ALL;
+    PERL_UNUSED_ARG(unused);
 
     /* LC_ALL updates all the things we care about. */
 
-    PERL_UNUSED_ARG(unused);
-
-    for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
+    for (unsigned int i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
         if (update_functions[i]) {
             const char * this_locale = querylocale_i(i);
-            update_functions[i](aTHX_ this_locale);
+            update_functions[i](aTHX_ this_locale, force);
         }
     }
 }
@@ -2492,9 +2494,10 @@ S_new_LC_ALL(pTHX_ const char *unused)
 #  ifdef USE_LOCALE_COLLATE
 
 STATIC void
-S_new_collate(pTHX_ const char *newcoll)
+S_new_collate(pTHX_ const char *newcoll, bool force)
 {
     PERL_ARGS_ASSERT_NEW_COLLATE;
+    PERL_UNUSED_ARG(force);
 
     /* Called after each libc setlocale() call affecting LC_COLLATE, to tell
      * core Perl this and that 'newcoll' is the name of the new locale.
@@ -2855,7 +2858,7 @@ Perl_setlocale(const int category, const char * locale)
     /* Now that have changed locales, we have to update our records to
      * correspond.  Only certain categories have extra work to update. */
     if (update_functions[cat_index]) {
-        update_functions[cat_index](aTHX_ retval);
+        update_functions[cat_index](aTHX_ retval, false);
     }
 
     DEBUG_L(PerlIO_printf(Perl_debug_log, "returning '%s'\n", retval));
@@ -5110,19 +5113,19 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
     PL_numeric_radix_sv    = newSV(1);
     PL_underlying_radix_sv = newSV(1);
     Newxz(PL_numeric_name, 1, char);    /* Single NUL character */
-    new_numeric("C");
+    new_numeric("C", false);
 
 #  endif
 #  ifdef USE_LOCALE_COLLATE
 
     Newxz(PL_collation_name, 1, char);
-    new_collate("C");
+    new_collate("C", false);
 
 #  endif
 #  ifdef USE_LOCALE_CTYPE
 
     Newxz(PL_ctype_name, 1, char);
-    new_ctype("C");
+    new_ctype("C", false);
 
 #  endif
 #  ifdef USE_PL_CURLOCALES
@@ -5441,7 +5444,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #  endif
 
     /* Done with finding the locales; update the auxiliary records */
-    new_LC_ALL(NULL);
+    new_LC_ALL(NULL, false);
 
     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
         Safefree(curlocales[i]);
@@ -6816,9 +6819,11 @@ Perl_switch_to_global_locale(pTHX)
 #  ifdef USE_THREAD_SAFE_LOCALE
 #    if defined(WIN32)
 
+    const char * thread_locale = posix_setlocale(LC_ALL, NULL);
     _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+    posix_setlocale(LC_ALL, thread_locale);
 
-#    elif defined(USE_POSIX_2008_LOCALE)
+#    else   /* Must be USE_POSIX_2008_LOCALE) */
 
     const char * cur_thread_locales[NOMINAL_LC_ALL_INDEX + 1];
 
@@ -6828,6 +6833,7 @@ Perl_switch_to_global_locale(pTHX)
     }
 
     /* Now switch to global */
+    DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Switching to global locale\n"));
 
     locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);
     if (! old_locale) {
@@ -6846,8 +6852,6 @@ Perl_switch_to_global_locale(pTHX)
     }
     POSIX_SETLOCALE_UNLOCK;
 
-#    else
-#      error Unexpected Configuration
 #    endif
 #  endif
 #  ifdef USE_LOCALE_NUMERIC
@@ -6919,30 +6923,45 @@ Perl_sync_locale(pTHX)
 #  ifdef USE_THREAD_SAFE_LOCALE
 #    if defined(WIN32)
 
-    was_in_global = _configthreadlocale(_ENABLE_PER_THREAD_LOCALE)
-                                    == _DISABLE_PER_THREAD_LOCALE;
+    was_in_global = _configthreadlocale(_DISABLE_PER_THREAD_LOCALE)
+                                     == _DISABLE_PER_THREAD_LOCALE;
 
 #    elif defined(USE_POSIX_2008_LOCALE)
 
-    was_in_global = LC_GLOBAL_LOCALE == uselocale((locale_t) 0);
+    was_in_global = (LC_GLOBAL_LOCALE == uselocale((locale_t) 0));
 
 #    else
 #      error Unexpected Configuration
 #    endif
 #  endif    /* USE_THREAD_SAFE_LOCALE */
-#  ifdef LC_ALL
 
-    /* Use the external interface Perl_setlocale() to make sure all setup gets
-     * done */
-    Perl_setlocale(LC_ALL, stdized_setlocale(LC_ALL, NULL));
+    /* Here, we are in the global locale.  Get and save the values for each
+     * category. */
+    const char * current_globals[NOMINAL_LC_ALL_INDEX];
+    for (unsigned i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
+        POSIX_SETLOCALE_LOCK;
+        current_globals[i] = savepv(stdized_setlocale(categories[i], NULL));
+        POSIX_SETLOCALE_UNLOCK;
+    }
+
+    /* Now we have to convert the current thread to use them */
 
-#  else
+#  if defined(WIN32)
+
+    /* On Windows, convert to per-thread behavior.  This isn't necessary in
+     * POSIX 2008, as the conversion gets done automatically in the loop below.
+     * */
+    _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+
+#  endif
 
     for (unsigned i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
-        Perl_setlocale(categories[i], stdized_setlocale(categories[i], NULL));
+        setlocale_i(i, current_globals[i]);
+        Safefree(current_globals[i]);
     }
 
-#  endif
+    /* And update our remaining records.  'true' => force recalculation */
+    new_LC_ALL(NULL, true);
 
     return was_in_global;
 
diff --git a/proto.h b/proto.h
index 43f74ee06a..f387a54338 100644
--- a/proto.h
+++ b/proto.h
@@ -5730,7 +5730,7 @@ PERL_STATIC_INLINE const char *	S_mortalized_pv_copy(pTHX_ const char * const pv
 #define PERL_ARGS_ASSERT_MORTALIZED_PV_COPY
 #endif
 
-STATIC void	S_new_LC_ALL(pTHX_ const char* unused);
+STATIC void	S_new_LC_ALL(pTHX_ const char* unused, bool force);
 #define PERL_ARGS_ASSERT_NEW_LC_ALL
 STATIC void	S_restore_toggled_locale_i(pTHX_ const unsigned cat_index, const char * original_locale, const line_t caller_line);
 #define PERL_ARGS_ASSERT_RESTORE_TOGGLED_LOCALE_I
@@ -5747,7 +5747,7 @@ STATIC const char *	S_toggle_locale_i(pTHX_ const unsigned switch_cat_index, con
 #define PERL_ARGS_ASSERT_TOGGLE_LOCALE_I	\
 	assert(new_locale)
 #    if defined(USE_LOCALE_COLLATE)
-STATIC void	S_new_collate(pTHX_ const char* newcoll);
+STATIC void	S_new_collate(pTHX_ const char* newcoll, bool force);
 #define PERL_ARGS_ASSERT_NEW_COLLATE	\
 	assert(newcoll)
 #    endif
@@ -5755,12 +5755,12 @@ STATIC void	S_new_collate(pTHX_ const char* newcoll);
 STATIC bool	S_is_codeset_name_UTF8(const char * name);
 #define PERL_ARGS_ASSERT_IS_CODESET_NAME_UTF8	\
 	assert(name)
-STATIC void	S_new_ctype(pTHX_ const char* newctype);
+STATIC void	S_new_ctype(pTHX_ const char* newctype, bool force);
 #define PERL_ARGS_ASSERT_NEW_CTYPE	\
 	assert(newctype)
 #    endif
 #    if defined(USE_LOCALE_NUMERIC)
-STATIC void	S_new_numeric(pTHX_ const char* newnum);
+STATIC void	S_new_numeric(pTHX_ const char* newnum, bool force);
 #define PERL_ARGS_ASSERT_NEW_NUMERIC	\
 	assert(newnum)
 #    endif