wrap uselocale

locale.c

@@ -425,6 +425,23 @@ static int debug_initialization = 0;
 #  error Revert the commit that added this line
 #endif
 
+#if defined(MULTIPLICITY) && defined(DEBUGGING)
+#  define wrap_uselocale(a)   \
+    ({  \
+       locale_t obj = uselocale(a); \
+       const char * name; \
+       if (obj == LC_GLOBAL_LOCALE) name = "global object";             \
+       else if (obj == PL_cur_locale_obj) name = "current locale object"; \
+       else if (obj == PL_C_locale_obj) name = "C object";              \
+       else name = Perl_form(aTHX_ "0x%p", (void *) obj);                    \
+       if (a == 0) {DEBUG_U(PerlIO_printf(Perl_debug_log, "uselocale(0) returned %s\n", name)); \
+       } else {DEBUG_U(PerlIO_printf(Perl_debug_log, "changing locale to 0x%p returned %s\n", (void *) a, name)); } \
+        obj;\
+    })
+#else
+#  define wrap_uselocale(a)   uselocale(a)
+#endif
+
 #ifdef WIN32_USE_FAKE_OLD_MINGW_LOCALES
 
    /* Use -Accflags=-DWIN32_USE_FAKE_OLD_MINGW_LOCALES on a POSIX or *nix box
@@ -1065,7 +1082,7 @@ S_use_curlocale_scratch(pTHX)
      * 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);
+    locale_t cur = wrap_uselocale((locale_t) 0);
 
     if (cur != LC_GLOBAL_LOCALE) {
         return cur;
@@ -2412,7 +2429,7 @@ S_querylocale_2008_i(pTHX_ const locale_category_index index,
      *      find_locale_from_environment() give details on the potential race.)
      */
 
-    const locale_t cur_obj = uselocale((locale_t) 0);
+    const locale_t cur_obj = wrap_uselocale((locale_t) 0);
     const char * retval;
 
 #  ifdef MULTIPLICITY
@@ -2620,7 +2637,7 @@ S_bool_setlocale_2008_i(pTHX_
      */
 
     int mask = category_masks[index];
-    const locale_t entry_obj = uselocale((locale_t) 0);
+    const locale_t entry_obj = wrap_uselocale((locale_t) 0);
 
 #  ifdef MULTIPLICITY
     assert(entry_obj== LC_GLOBAL_LOCALE || entry_obj == PL_cur_locale_obj);
@@ -2732,7 +2749,7 @@ S_bool_setlocale_2008_i(pTHX_
      * the C library's discretion), hence we can't be using that locale at the
      * time of the switch (this wasn't obvious to khw from the man pages).  So
      * switch to a known locale object that we don't otherwise mess with. */
-    if (! uselocale(PL_C_locale_obj)) {
+    if (! wrap_uselocale(PL_C_locale_obj)) {
 
         /* Not being able to change to the C locale is severe; don't keep
          * going.  */
@@ -2932,7 +2949,7 @@ S_bool_setlocale_2008_i(pTHX_
 
     /* Here, successfully created an object representing the desired locale;
      * now switch into it */
-    if (! uselocale(new_obj)) {
+    if (! wrap_uselocale(new_obj)) {
         freelocale(new_obj);
         locale_panic_(Perl_form(aTHX_ "(called from %" LINE_Tf "):"
                                       " bool_setlocale_2008_i: switching"
@@ -2979,7 +2996,7 @@ S_bool_setlocale_2008_i(pTHX_
 
     /* We earlier switched to the LC_ALL => C locale in anticipation of it
      * succeeding,  Now have to switch back to the state upon entry.  */
-    if (! uselocale(entry_obj)) {
+    if (! wrap_uselocale(entry_obj)) {
         setlocale_failure_panic_i(index, "switching back to",
                                   locale_on_entry, __LINE__, caller_line);
     }
@@ -6552,7 +6569,7 @@ S_my_langinfo_i(pTHX_
      && defined(HAS_NL_LANGINFO_L)              \
      && defined(MULTIPLICITY)
 
-    const locale_t cur_obj = uselocale(0);
+    const locale_t cur_obj = wrap_uselocale(0);
     if (   cur_obj != LC_GLOBAL_LOCALE
         && strEQ(locale, querylocale_i(cat_index)))
     {
@@ -7999,7 +8016,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
      * anyway, but deferring it can lead to leaks of memory that would also get
      * malloc'd in the interim.  We arbitrarily switch to the C locale,
      * overridden below  */
-    if (! uselocale(PL_C_locale_obj)) {
+    if (! wrap_uselocale(PL_C_locale_obj)) {
         locale_panic_(Perl_form(aTHX_
                                 "Can't uselocale(%p), LC_ALL supposed to"
                                 " be 'C'",
@@ -8397,7 +8414,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
                            "finished Perl_init_i18nl10n; actual obj=%p,"
                            " expected obj=%p, initial=%s\n",
-                           uselocale(0), PL_cur_locale_obj,
+                           wrap_uselocale(0), PL_cur_locale_obj,
                            get_LC_ALL_display()));
 #  endif
 
@@ -9719,7 +9736,7 @@ handle all cases of single- vs multi-thread, POSIX 2008-supported or not.
 #elif defined(USE_POSIX_2008_LOCALE)
 #  define CHANGE_SYSTEM_LOCALE_TO_GLOBAL                                \
     STMT_START {                                                        \
-        locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);              \
+        locale_t old_locale = wrap_uselocale(LC_GLOBAL_LOCALE);              \
         if (! old_locale) {                                             \
             locale_panic_("Could not change to global locale");         \
         }                                                               \
@@ -9751,7 +9768,7 @@ Perl_switch_to_global_locale(pTHX)
     * global locale or not. */
 #  ifdef USE_POSIX_2008_LOCALE
 
-    const bool perl_controls = (LC_GLOBAL_LOCALE != uselocale((locale_t) 0));
+    const bool perl_controls = (LC_GLOBAL_LOCALE != wrap_uselocale((locale_t) 0));
 
 #  elif defined(USE_THREAD_SAFE_LOCALE) && defined(WIN32)
 
@@ -9895,7 +9912,7 @@ Perl_sync_locale(pTHX)
 
 #    elif defined(USE_POSIX_2008_LOCALE)    /* Thread-safe POSIX 2008 */
 
-    was_in_global = (LC_GLOBAL_LOCALE == uselocale(LC_GLOBAL_LOCALE));
+    was_in_global = (LC_GLOBAL_LOCALE == wrap_uselocale(LC_GLOBAL_LOCALE));
 
 #    else
 #      error Unexpected Configuration
@@ -10039,7 +10056,7 @@ Perl_switch_locale_context(pTHX)
 
 #  ifdef USE_POSIX_2008_LOCALE
 
-    if (! uselocale(PL_cur_locale_obj)) {
+    if (! wrap_uselocale(PL_cur_locale_obj)) {
         locale_panic_(Perl_form(aTHX_
                                 "Can't uselocale(%p), LC_ALL supposed to"
                                 " be '%s'",
@@ -10090,7 +10107,7 @@ Perl_thread_locale_init(pTHX)
                            " calling setlocale(LC_ALL, \"C\")\n",
                            get_LC_ALL_display()));
 
-    if (! uselocale(PL_C_locale_obj)) {
+    if (! wrap_uselocale(PL_C_locale_obj)) {
 
         /* Not being able to change to the C locale is severe; don't keep
          * going.  */
@@ -10135,7 +10152,7 @@ Perl_thread_locale_term(pTHX)
 #if defined(USE_POSIX_2008_LOCALE) && defined(USE_THREADS)
 
     /* Switch to the global locale, so can free up the per-thread object */
-    locale_t actual_obj = uselocale(LC_GLOBAL_LOCALE);
+    locale_t actual_obj = wrap_uselocale(LC_GLOBAL_LOCALE);
     if (actual_obj != LC_GLOBAL_LOCALE && actual_obj != PL_C_locale_obj) {
         freelocale(actual_obj);
     }