locale.c: Refactor S_get_category_index()

There is actually only one place where the locale category can be input
from code outside this file.  Now that the previous commit added
validation to that one spot, The rest of the calls should already be
validated, and if the input is bad, it means that there is a serious
error in the logic of this code, and warrants panicking.

This commit collapses two functions into one plus a macro to call it
with the right parameters.  It moves the warning into the one place
where it is useful, and panics if there is a problem otherwise.

And it adds tests for the warning.

embed.fnc

@@ -4328,11 +4328,10 @@ S	|void	|populate_hash_from_localeconv				\
 				|NULLOK const lconv_offset_t *integers
 # endif
 # if defined(USE_LOCALE)
-RST	|unsigned int|get_category_index				\
+RS	|unsigned int|get_category_index_helper 			\
 				|const int category			\
-				|NULLOK const char *locale
-RST	|unsigned int|get_category_index_nowarn 			\
-				|const int category
+				|NULLOK bool *success			\
+				|const line_t caller_line
 Ri	|const char *|mortalized_pv_copy				\
 				|NULLOK const char * const pv
 S	|void	|new_LC_ALL	|NULLOK const char *unused		\

embed.h

@@ -1268,8 +1268,7 @@
 #       define populate_hash_from_localeconv(a,b,c,d,e) S_populate_hash_from_localeconv(aTHX_ a,b,c,d,e)
 #     endif
 #     if defined(USE_LOCALE)
-#       define get_category_index               S_get_category_index
-#       define get_category_index_nowarn        S_get_category_index_nowarn
+#       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 new_LC_ALL(a,b)                  S_new_LC_ALL(aTHX_ a,b)
 #       define save_to_buffer                   S_save_to_buffer

ext/XS-APItest/t/locale.t

@@ -12,9 +12,16 @@ my @locales = eval { find_locales( &LC_NUMERIC ) };
 
 if (@locales) {
     use POSIX;
+    no warnings;
+    use warnings 'locale';
+    my $warning = "";
+    local $SIG{__WARN__} = sub { $warning = shift; };
                    # Choose a number unlikely to be a legal category
     ok(! setlocale(1114112, $locales[0]),
                    "Fails to set an illegal category to a legal locale");
+    like($warning, qr/Unknown locale category/i,
+         "And warns about the illegal category, using the proper warning"
+       . " category");
 }
 
 my $comma_locale;

locale.c

@@ -234,7 +234,7 @@ static const char C_thousands_sep[] = "";
 #    define setlocale_debug_string_c(category, locale, result)              \
                 setlocale_debug_string_i(category##_INDEX_, locale, result)
 #    define setlocale_debug_string_r(category, locale, result)              \
-             setlocale_debug_string_i(get_category_index(category, locale), \
+             setlocale_debug_string_i(get_category_index(category),         \
                                       locale, result)
 #  endif
 
@@ -401,13 +401,16 @@ S_get_displayable_string(pTHX_
 #endif
 #ifdef USE_LOCALE
 
+# define get_category_index(cat) get_category_index_helper(cat, NULL, __LINE__)
+
 STATIC unsigned int
-S_get_category_index_nowarn(const int category)
+S_get_category_index_helper(pTHX_ const int category, bool * succeeded,
+                                  const line_t caller_line)
 {
-    PERL_ARGS_ASSERT_GET_CATEGORY_INDEX_NOWARN;
+    PERL_ARGS_ASSERT_GET_CATEGORY_INDEX_HELPER;
 
     /* Given a category, return the equivalent internal index we generally use
-     * instead, or negative if not found. */
+     * instead, warn or panic if not found. */
 
     unsigned int i;
 
@@ -422,48 +425,29 @@ S_get_category_index_nowarn(const int category)
       case LC_ALL: i =  LC_ALL_INDEX_; break;
 #  endif
 
-    /* Return an out-of-bounds value */
-      default: return LC_ALL_INDEX_ + 1;
+      default: goto unknown_locale;
     }
 
-    dTHX_DEBUGGING;
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                           "index of category %d (%s) is %d\n",
-                           category, category_names[i], i));
-    return i;
-}
-
-STATIC unsigned int
-S_get_category_index(const int category, const char * locale)
-{
-    /* Given a category, return the equivalent internal index we generally use
-     * instead.
-     *
-     * 'locale' is for use in any generated diagnostics, and may be NULL
-     */
+                           "index of category %d (%s) is %d;"
+                           " called from %" LINE_Tf "\n",
+                           category, category_names[i], i, caller_line));
 
-    const char * conditional_warn_text = "; can't set it to ";
-    const int index = get_category_index_nowarn(category);
-
-    if (index <= LC_ALL_INDEX_) {
-        return index;
+    if (succeeded) {
+        *succeeded = true;
     }
 
-    /* Here, we don't know about this category, so can't handle it. */
-
-    if (! locale) {
-        locale = "";
-        conditional_warn_text = "";
-    }
+    return i;
 
-    /* diag_listed_as: Unknown locale category %d; can't set it to %s */
-    Perl_warner_nocontext(packWARN(WARN_LOCALE),
-                          "Unknown locale category %d%s%s",
-                          category, conditional_warn_text, locale);
+  unknown_locale:
 
-    SET_EINVAL;
+    if (succeeded) {
+        *succeeded = false;
+        return 0;   /* Arbitrary */
+    }
 
-    return index;   /* 'index' is known to be out-of-bounds */
+    locale_panic_(Perl_form(aTHX_ "Unknown locale category %d", category));
+    NOT_REACHED; /* NOTREACHED */
 }
 
 #endif /* ifdef USE_LOCALE */
@@ -2622,7 +2606,11 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
     if (strEQ(locale, "")) {
         /* Note this function may change the locale, but that's ok because we
          * are about to change it anyway */
-        locale = find_locale_from_environment(get_category_index(category, ""));
+        locale = find_locale_from_environment(get_category_index(category));
+        if (locale == NULL) {
+            SET_EINVAL;
+            return NULL;
+        }
     }
 
     const char * result = wrap_wsetlocale(category, locale);
@@ -2718,8 +2706,28 @@ Perl_setlocale(const int category, const char * locale)
                           "Entering Perl_setlocale(%d, \"%s\")\n",
                           category, locale));
 
-    unsigned int cat_index = get_category_index_nowarn(category);
-    if (cat_index > LC_ALL_INDEX_) {
+    bool valid_category;
+    unsigned int cat_index = get_category_index_helper(category,
+                                                       &valid_category,
+                                                       __LINE__);
+    if (! valid_category) {
+        if (ckWARN(WARN_LOCALE)) {
+            const char * conditional_warn_text;
+            if (locale == NULL) {
+                conditional_warn_text = "";
+                locale = "";
+            }
+            else {
+                conditional_warn_text = "; can't set it to ";
+            }
+
+            /* diag_listed_as: Unknown locale category %d; can't set it to %s */
+            Perl_warner(aTHX_
+                           packWARN(WARN_LOCALE),
+                           "Unknown locale category %d%s%s",
+                           category, conditional_warn_text, locale);
+        }
+
         SET_EINVAL;
         return NULL;
     }