Add switch_to_globale_locale()

This new API function is for use in applications that call alien library
routines that are expecting the old pre-POSIX 2008 locale functionality,
namely a single global locale accessible via setlocale().

This function converts the calling thread to use that global locale, if
not already there.

6 files changed, 76 insertions, 2 deletions

diff --git a/dist/ExtUtils-ParseXS/lib/perlxs.pod b/dist/ExtUtils-ParseXS/lib/perlxs.pod
index 28f88bc78c..1419ee0ddf 100644
--- a/dist/ExtUtils-ParseXS/lib/perlxs.pod
+++ b/dist/ExtUtils-ParseXS/lib/perlxs.pod
@@ -2316,7 +2316,7 @@ operates only on the global locale, whereas each thread has its own
 locale, paying no attention to the global one.  Since converting
 these non-Perl libraries to C<Perl_setlocale> is out of the question,
 there is a new function in v5.28
-C<switch_to_global_locale> that will
+L<C<switch_to_global_locale>|perlapi/switch_to_global_locale> that will
 switch the thread it is called from so that any system C<setlocale>
 calls will have their desired effect.  The function
 L<C<sync_locale>|perlapi/sync_locale> must be called before returning to
diff --git a/embed.fnc b/embed.fnc
index d8f4fd969c..e748639e1a 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1309,6 +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
+Apdn	|void	|switch_to_global_locale
 Apdn	|bool	|sync_locale
 ApMn	|void	|thread_locale_init
 ApMn	|void	|thread_locale_term
diff --git a/embed.h b/embed.h
index e68a73380c..b417aaf083 100644
--- a/embed.h
+++ b/embed.h
@@ -714,6 +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 switch_to_global_locale	Perl_switch_to_global_locale
 #define sync_locale		Perl_sync_locale
 #define taint_env()		Perl_taint_env(aTHX)
 #define taint_proper(a,b)	Perl_taint_proper(aTHX_ a,b)
diff --git a/locale.c b/locale.c
index 8a25629d7c..66a4694ad7 100644
--- a/locale.c
+++ b/locale.c
@@ -4945,6 +4945,77 @@ Perl_my_strerror(pTHX_ const int errnum)
 
 /*
 
+=for apidoc switch_to_global_locale
+
+On systems without locale support, or on 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.
+
+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_switch_to_global_locale()
+{
+
+#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
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 06d1ef9a93..ba23771c8d 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -2267,7 +2267,7 @@ value is 1) or not (the value is 0).  This variable is always 1 if the
 perl has been compiled without threads.  It is also 1 if this perl is
 using thread-safe locale operations.  Note that an individual thread may
 choose to use the global locale (generally unsafe) by calling
-C<switch_to_global_locale>.  This variable currently is still
+L<perlapi/switch_to_global_locale>.  This variable currently is still
 set to 1 in such threads.
 
 This variable is read-only.
diff --git a/proto.h b/proto.h
index ec5009e9bd..80b9e240b5 100644
--- a/proto.h
+++ b/proto.h
@@ -3513,6 +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_switch_to_global_locale(void);
 PERL_CALLCONV bool	Perl_sync_locale(void);
 PERL_CALLCONV void	Perl_sys_init(int* argc, char*** argv);
 #define PERL_ARGS_ASSERT_SYS_INIT	\