Revise sync_locale() for safe multi-threaded operation

This function now returns a boolean, and does not want an aTHX
parameter.  There should be no impact on code that uses the macro form
to call it.

diff --git a/embed.fnc b/embed.fnc
index 73139f3..d8f4fd9 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1309,7 +1309,7 @@ Xpn       |void   |_warn_problematic_locale
 Xp     |void   |set_numeric_underlying
 Xp     |void   |set_numeric_standard
 Xp     |bool   |_is_in_locale_category|const bool compiling|const int category
-Apd    |void   |sync_locale
+Apdn   |bool   |sync_locale
 ApMn   |void   |thread_locale_init
 ApMn   |void   |thread_locale_term
 ApdO   |void   |require_pv     |NN const char* pv

diff --git a/embed.h b/embed.h
index 6d3a986..e68a733 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -714,7 +714,7 @@
 #define sv_vsetpvf(a,b,c)      Perl_sv_vsetpvf(aTHX_ a,b,c)
 #define sv_vsetpvf_mg(a,b,c)   Perl_sv_vsetpvf_mg(aTHX_ a,b,c)
 #define sv_vsetpvfn(a,b,c,d,e,f,g)     Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
-#define sync_locale()          Perl_sync_locale(aTHX)
+#define sync_locale            Perl_sync_locale
 #define taint_env()            Perl_taint_env(aTHX)
 #define taint_proper(a,b)      Perl_taint_proper(aTHX_ a,b)
 #define thread_locale_init     Perl_thread_locale_init

diff --git a/locale.c b/locale.c
index 595a016..8a25629 100644 (file)
--- a/locale.c
+++ b/locale.c
@@ -4947,19 +4947,67 @@ Perl_my_strerror(pTHX_ const int errnum)
 
 =for apidoc sync_locale
 
-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.
+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
 */
 
-void
-Perl_sync_locale(pTHX)
+bool
+Perl_sync_locale()
 {
     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
+
+    bool was_in_global_locale = TRUE;
+
+#endif
 #ifdef USE_LOCALE_CTYPE
 
     newlocale = do_setlocale_c(LC_CTYPE, NULL);
@@ -4988,6 +5036,7 @@ Perl_sync_locale(pTHX)
 
 #endif /* USE_LOCALE_NUMERIC */
 
+    return was_in_global_locale;
 }
 
 #if defined(DEBUGGING) && defined(USE_LOCALE)

diff --git a/proto.h b/proto.h
index 920d625..ec5009e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3513,7 +3513,7 @@ PERL_CALLCONV SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV* l
 #define PERL_ARGS_ASSERT_SWASH_INIT    \
        assert(pkg); assert(name); assert(listsv)
 
-PERL_CALLCONV void     Perl_sync_locale(pTHX);
+PERL_CALLCONV bool     Perl_sync_locale(void);
 PERL_CALLCONV void     Perl_sys_init(int* argc, char*** argv);
 #define PERL_ARGS_ASSERT_SYS_INIT      \
        assert(argc); assert(argv)