locale.c: Add fcn to hide edge case undefined behavior

The POSIX 2008 API has an edge case in that the result of most of the functions when called with a global (as opposed to a per-thread) locale is undefined. The duplocale() function is the exception which will create a per-thread locale containing the values copied from the global one. This commit just calls duplocale, if needed, and the caller need not concern itself with this possibility
Perl · May 5, 2021 · 75ab944 · 75ab944
1 parent 16f0bd1
commit 75ab944
Show file tree

Hide file tree

Showing 9 changed files with 48 additions and 23 deletions.
diff --git a/embed.fnc b/embed.fnc
@@ -3255,6 +3255,7 @@ S	|const char*|emulate_setlocale_i|const unsigned int index	\
 				    |NULLOK const char* new_locale	\
 				    |const int recalc_LC_ALL
 S	|const char*|my_querylocale_i|const unsigned int index
+S	|locale_t   |use_curlocale_scratch
 S	|const char *|setlocale_from_aggregate_LC_ALL			\
 				|NN const char * locale
 S	|const char*|update_PL_curlocales_i|const unsigned int index	\

diff --git a/embed.h b/embed.h
@@ -1715,6 +1715,7 @@
 #define my_querylocale_i(a)	S_my_querylocale_i(aTHX_ a)
 #define setlocale_from_aggregate_LC_ALL(a)	S_setlocale_from_aggregate_LC_ALL(aTHX_ a)
 #define update_PL_curlocales_i(a,b,c)	S_update_PL_curlocales_i(aTHX_ a,b,c)
+#define use_curlocale_scratch()	S_use_curlocale_scratch(aTHX)
 #      endif
 #      if defined(USE_QUERYLOCALE)
 #define calculate_LC_ALL(a)	S_calculate_LC_ALL(aTHX_ a)

diff --git a/embedvar.h b/embedvar.h
@@ -286,6 +286,7 @@
 #define PL_scopestack_ix	(vTHX->Iscopestack_ix)
 #define PL_scopestack_max	(vTHX->Iscopestack_max)
 #define PL_scopestack_name	(vTHX->Iscopestack_name)
+#define PL_scratch_locale_obj	(vTHX->Iscratch_locale_obj)
 #define PL_secondgv		(vTHX->Isecondgv)
 #define PL_setlocale_buf	(vTHX->Isetlocale_buf)
 #define PL_setlocale_bufsize	(vTHX->Isetlocale_bufsize)

diff --git a/intrpvar.h b/intrpvar.h
@@ -813,6 +813,9 @@ PERLVARI(I, underlying_numeric_obj, locale_t, NULL)
 
 #  endif
 #endif /* !USE_LOCALE_NUMERIC */
+#ifdef USE_POSIX_2008_LOCALE
+PERLVARI(I, scratch_locale_obj, locale_t, 0)
+#endif
 
 /* Array of signal handlers, indexed by signal number, through which the C
    signal handler dispatches.  */

diff --git a/locale.c b/locale.c
@@ -419,6 +419,32 @@ S_category_name(const int category)
 }
 
 #endif /* ifdef USE_LOCALE */
+#ifdef USE_POSIX_2008_LOCALE
+
+STATIC locale_t
+S_use_curlocale_scratch(pTHX)
+{
+    /* This function is used to hide from the caller the case where the current
+     * locale_t object in POSIX 2008 is the global one, which is illegal in
+     * many of the P2008 API calls.  This checks for that and, if necessary
+     * creates a proper P2008 object.  Any prior object is deleted, as is any
+     * remaining object during global destruction. */
+
+    locale_t cur = uselocale((locale_t) 0);
+
+    if (cur != LC_GLOBAL_LOCALE) {
+        return cur;
+    }
+
+    if (PL_scratch_locale_obj) {
+        freelocale(PL_scratch_locale_obj);
+    }
+
+    PL_scratch_locale_obj = duplocale(LC_GLOBAL_LOCALE);
+    return PL_scratch_locale_obj;
+}
+
+#endif
 
 #define setlocale_failure_panic_c(                                          \
                         cat, current, failed, caller_0_line, caller_1_line) \
@@ -2732,13 +2758,7 @@ S_my_nl_langinfo(const int item, bool toggle)
              locale. */
 
     {
-        bool do_free = FALSE;
-        locale_t cur = uselocale((locale_t) 0);
-
-        if (cur == LC_GLOBAL_LOCALE) {
-            cur = duplocale(LC_GLOBAL_LOCALE);
-            do_free = TRUE;
-        }
+        locale_t cur = use_curlocale_scratch();
 
 #    ifdef USE_LOCALE_NUMERIC
 
@@ -2748,7 +2768,6 @@ S_my_nl_langinfo(const int item, bool toggle)
             }
             else {
                 cur = newlocale(LC_NUMERIC_MASK, PL_numeric_name, cur);
-                do_free = TRUE;
             }
         }
 
@@ -2758,10 +2777,6 @@ S_my_nl_langinfo(const int item, bool toggle)
          * 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);
-        }
     }
 
 #  endif
@@ -5414,26 +5429,17 @@ Perl_my_strerror(pTHX_ const int errnum)
      * threaded-build.  We use strerror_l() for everything, constructing a
      * locale to pass to it if necessary */
 
-    bool do_free = FALSE;
     locale_t locale_to_use;
 
     if (within_locale_scope) {
-        locale_to_use = uselocale((locale_t) 0);
-        if (locale_to_use == LC_GLOBAL_LOCALE) {
-            locale_to_use = duplocale(LC_GLOBAL_LOCALE);
-            do_free = TRUE;
-        }
+        locale_to_use = use_curlocale_scratch();
     }
     else {  /* Use C locale if not within 'use locale' scope */
         locale_to_use = PL_C_locale_obj;
     }
 
     errstr = savepv(strerror_l(errnum, locale_to_use));
 
-    if (do_free) {
-        freelocale(locale_to_use);
-    }
-
 #    endif
 #  else /* Doesn't have strerror_l() */
 

diff --git a/makedef.pl b/makedef.pl
@@ -414,10 +414,16 @@ sub readvar {
 {
     ++$skip{$_} foreach qw(
         PL_C_locale_obj
-        PL_curlocales
+        PL_scratch_locale_obj
         PL_underlying_numeric_obj
     );
 }
+unless ($define{USE_POSIX_2008_LOCALE} && ! $define{HAS_QUERY_LOCALE})
+{
+    ++$skip{$_} foreach qw(
+        PL_curlocales
+    );
+}
 
 unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
     ++$skip{$_} foreach qw(

diff --git a/perl.c b/perl.c
@@ -1132,6 +1132,10 @@ perl_destruct(pTHXx)
             freelocale(old_locale);
         }
     }
+    if (PL_scratch_locale_obj) {
+        freelocale(PL_scratch_locale_obj);
+        PL_scratch_locale_obj = NULL;
+    }
 #  ifdef USE_LOCALE_NUMERIC
     if (PL_underlying_numeric_obj) {
         DEBUG_Lv(PerlIO_printf(Perl_debug_log,

diff --git a/proto.h b/proto.h
@@ -5167,6 +5167,8 @@ STATIC const char *	S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale)
 STATIC const char*	S_update_PL_curlocales_i(pTHX_ const unsigned int index, const char * new_locale, int recalc_LC_ALL);
 #define PERL_ARGS_ASSERT_UPDATE_PL_CURLOCALES_I	\
 	assert(new_locale)
+STATIC locale_t	S_use_curlocale_scratch(pTHX);
+#define PERL_ARGS_ASSERT_USE_CURLOCALE_SCRATCH
 #    endif
 #    if defined(USE_QUERYLOCALE)
 STATIC const char *	S_calculate_LC_ALL(pTHX_ const locale_t cur_obj);

diff --git a/sv.c b/sv.c
@@ -15671,6 +15671,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
 #  if defined(USE_POSIX_2008_LOCALE)
     PL_underlying_numeric_obj = NULL;
+    PL_scratch_locale_obj = NULL;
 #  endif
 #endif /* !USE_LOCALE_NUMERIC */