XXX why not failing tests before this?Create S_native_querylocale_i()…

… and use it

This new function differs from the already existing plain
querylocale_i() in that it returns in the platform's native format,
instead of the internal=to-perl one.

The internal one is used generally so that code doesn't have to cope
with multiple possible formats.  The format of the new locale in
Perl_setlocale() is going to be in native format.  We effectively
translate it into our internal one at the input edge, and that is used
thereafter.

But until this commit, the translation back to native format at the
output edge was incomplete.

This mostly worked because native format differs from locale.c
internal format in just two ways.

One is the locale for LC_NUMERIC.  perl keeps it generally in the C
locale, except for brief intervals which higher level code specifies,
when the real locale is swapped in.  (Actually, this isn't quite true.
If the real locale is indistinguishable from C as far as LC_NUMERIC
goes, perl is happy to use it rather than C, so as to save swapping.)
locale.c had the code in it to translate the internal format back to
native, so it worked for this case.

The other is LC_ALL when not all categories are set to the same locale.
Windows and Linux use 'name=value;' pairs notation, while things derived
from BSD (and others) use a positional notation in which only the values
are given, and the system knows which category a given value is for from
its position in the string.  Perl worked fine for the name=value pairs
notation, because that is the same as its internal one, so no
translation got done, but until this commit, there were issues on
positional platforms.  This seldom got in the way since most people, if
they set the locale at all, will just set it to some single 'foo'.

What this commit effectively does is change Perl_setlocale() to return
the value in the native format which the libc functions are expecting.
This differs from what it used to return only on platforms which use the
positional notation and only for LC_ALL when not all categories are set
to the same locale.

The new function subsumes much of the work previously done in
Perl_setlocale(), and it is able to simplify some of that work.

embed.fnc

@@ -4340,6 +4340,8 @@ RS	|unsigned int|get_category_index_helper 			\
 				|const line_t caller_line
 Ri	|const char *|mortalized_pv_copy				\
 				|NULLOK const char * const pv
+S	|const char *|native_querylocale_i				\
+				|const unsigned int cat_index
 S	|void	|new_LC_ALL	|NULLOK const char *unused		\
 				|bool force
 void

embed.h

@@ -1272,6 +1272,7 @@
 #       define calculate_LC_ALL_string(a,b,c,d) S_calculate_LC_ALL_string(aTHX_ a,b,c,d)
 #       define get_category_index_helper(a,b,c) S_get_category_index_helper(aTHX_ a,b,c)
 #       define mortalized_pv_copy(a)            S_mortalized_pv_copy(aTHX_ a)
+#       define native_querylocale_i(a)          S_native_querylocale_i(aTHX_ a)
 #       define new_LC_ALL(a,b)                  S_new_LC_ALL(aTHX_ a,b)
 #       define output_check_environment_warning(a,b,c) S_output_check_environment_warning(aTHX_ a,b,c)
 #       define save_to_buffer                   S_save_to_buffer

locale.c

@@ -4134,6 +4134,63 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
 }
 
 #endif
+#ifdef USE_LOCALE
+
+STATIC const char *
+S_native_querylocale_i(pTHX_ const unsigned int cat_index)
+{
+    /* Determine the current locale and return it in the form the platform's
+     * native locale handling understands.  This is different only from our
+     * internal form for the LC_ALL category, as platforms differ in how they
+     * represent that.
+     *
+     * This is only called from Perl_setlocale().  As such it returns in
+     * PL_setlocale_buf */
+
+#  ifdef USE_LOCALE_NUMERIC
+
+    /* We have the LC_NUMERIC name saved, because we are normally switched into
+     * the C locale (or equivalent) for it. */
+    if (cat_index == LC_NUMERIC_INDEX_) {
+
+        /* We don't have to copy this return value, as it is a per-thread
+         * variable, and won't change until a future setlocale */
+        return PL_numeric_name;
+    }
+
+#  endif
+#  ifdef LC_ALL
+
+    if (cat_index != LC_ALL_INDEX_)
+
+#  endif
+
+    {
+        /* Here, not LC_ALL, and not LC_NUMERIC: the actual and native values
+         * match */
+        return save_to_buffer(querylocale_i(cat_index),
+                              &PL_setlocale_buf, &PL_setlocale_bufsize);
+    }
+
+    /* Below, querying LC_ALL */
+
+#  ifdef LC_ALL
+#    ifdef USE_PL_CURLOCALES
+#      define LC_ALL_ARG  PL_curlocales
+#    else
+#      define LC_ALL_ARG  NULL  /* Causes calculate_LC_ALL_string() to find the
+                                   locale using a querylocale function */
+#    endif
+
+    return calculate_LC_ALL_string(LC_ALL_ARG, EXTERNAL_FORMAT_FOR_QUERY,
+                                   true,   /* Use setlocale_buf for result */
+                                   __LINE__);
+#    undef LC_ALL_ARG
+#  endif    /* has LC_ALL */
+
+}
+
+#endif      /* USE_LOCALE */
 
 /*
 =for apidoc Perl_setlocale
@@ -4198,7 +4255,6 @@ Perl_setlocale(const int category, const char * locale)
 
 #else
 
-    const char * retval;
     dTHX;
 
     DEBUG_L(PerlIO_printf(Perl_debug_log,
@@ -4231,88 +4287,18 @@ Perl_setlocale(const int category, const char * locale)
         return NULL;
     }
 
+    /* Get current locale */
+    const char * current_locale = native_querylocale_i(cat_index);
+
     /* A NULL locale means only query what the current one is. */
     if (locale == NULL) {
+        return current_locale;
+    }
 
-#  ifndef USE_LOCALE_NUMERIC
-
-        /* Without LC_NUMERIC, it's trivial; we just return the value */
-        return save_to_buffer(querylocale_i(cat_index),
-                              &PL_setlocale_buf, &PL_setlocale_bufsize);
-#  else
-
-        /* We have the LC_NUMERIC name saved, because we are normally switched
-         * into the C locale (or equivalent) for it. */
-        if (category == LC_NUMERIC) {
-            DEBUG_L(PerlIO_printf(Perl_debug_log,
-                    "Perl_setlocale(LC_NUMERIC, NULL) returning stashed '%s'\n",
-                    PL_numeric_name));
-
-            /* We don't have to copy this return value, as it is a per-thread
-             * variable, and won't change until a future setlocale */
-            return PL_numeric_name;
-        }
-
-#    ifndef LC_ALL
-
-        /* Without LC_ALL, just return the value */
-        return save_to_buffer(querylocale_i(cat_index),
-                              &PL_setlocale_buf, &PL_setlocale_bufsize);
-
-#    else
-
-        /* Here, LC_ALL is available on this platform.  It's the one
-         * complicating category (because it can contain a toggled LC_NUMERIC
-         * value), for all the remaining ones (we took care of LC_NUMERIC
-         * above), just return the value */
-        if (category != LC_ALL) {
-            return save_to_buffer(querylocale_i(cat_index),
-                                  &PL_setlocale_buf, &PL_setlocale_bufsize);
-        }
-
-        bool toggled = FALSE;
-
-        /* For an LC_ALL query, switch back to the underlying numeric locale
-         * (if we aren't there already) so as to get the correct results.  Our
-         * records for all the other categories are valid without switching */
-        if (! PL_numeric_underlying) {
-            set_numeric_underlying(__FILE__, __LINE__);
-            toggled = TRUE;
-        }
-
-        retval = querylocale_c(LC_ALL);
-
-        if (toggled) {
-            set_numeric_standard(__FILE__, __LINE__);
-        }
-
-        DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",
-                           setlocale_debug_string_i(cat_index, locale, retval)));
-
-        return save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize);
-
-#    endif      /* Has LC_ALL */
-#  endif        /* Has LC_NUMERIC */
-
-    } /* End of querying the current locale */
-
-    retval = querylocale_i(cat_index);
-
-    /* If the new locale is the same as the current one, nothing is actually
-     * being changed, so do nothing. */
-    if (      strEQ(retval, locale)
-        && (   ! affects_LC_NUMERIC(category)
-
-#  ifdef USE_LOCALE_NUMERIC
-
-            || strEQ(locale, PL_numeric_name)
-
-#  endif
-
-    )) {
+    if (strEQ(current_locale, locale)) {
         DEBUG_L(PerlIO_printf(Perl_debug_log,
-                              "Already in requested locale: no action taken\n"));
-        return save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize);
+                             "Already in requested locale: no action taken\n"));
+        return current_locale;
     }
 
     /* Here, an actual change is being requested.  Do it */
@@ -4322,16 +4308,14 @@ Perl_setlocale(const int category, const char * locale)
         return NULL;
     }
 
-    assert(strNE(retval, ""));
-    retval = save_to_buffer(querylocale_i(cat_index),
-                            &PL_setlocale_buf, &PL_setlocale_bufsize);
-
     /* 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, false);
+        update_functions[cat_index](aTHX_ querylocale_i(cat_index), false);
     }
 
+    const char * retval = native_querylocale_i(cat_index);
+
     DEBUG_L(PerlIO_printf(Perl_debug_log, "returning '%s'\n", retval));
 
     return retval;