Add a common locale panic macro and functions

This will make sure that all the necessary clean up gets done.

embed.fnc

@@ -1599,6 +1599,11 @@ ApdO	|CV*	|get_cv		|NN const char* name|I32 flags
 Apd	|CV*	|get_cvn_flags	|NN const char* name|STRLEN len|I32 flags
 ATdo	|const char*|Perl_setlocale|const int category|NULLOK const char* locale
 ATdo	|HV *	|Perl_localeconv
+Tp	|void	|force_locale_unlock
+CTpor	|void	|locale_panic	|NN const char * msg			\
+				|NN const char * file_name		\
+				|const line_t line			\
+				|const int errnum
 #if defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H)
 ATdo	|const char*|Perl_langinfo|const nl_item item
 ATdo	|const char*|Perl_langinfo8|const nl_item item|NULLOK int * utf8ness

embed.h

@@ -1322,6 +1322,7 @@
 #define find_lexical_cv(a)	Perl_find_lexical_cv(aTHX_ a)
 #define find_runcv_where(a,b,c)	Perl_find_runcv_where(aTHX_ a,b,c)
 #define find_script(a,b,c,d)	Perl_find_script(aTHX_ a,b,c,d)
+#define force_locale_unlock	Perl_force_locale_unlock
 #define free_tied_hv_pool()	Perl_free_tied_hv_pool(aTHX)
 #define get_hash_seed(a)	Perl_get_hash_seed(aTHX_ a)
 #define get_no_modify()		Perl_get_no_modify(aTHX)

locale.c

@@ -405,6 +405,21 @@ S_get_category_index(const int category, const char * locale)
 }
 
 #endif /* ifdef USE_LOCALE */
+
+void
+Perl_force_locale_unlock()
+{
+
+#if defined(USE_LOCALE_THREADS)
+
+    dTHX;
+
+        LOCALE_UNLOCK_;
+
+#endif
+
+}
+
 #ifdef USE_POSIX_2008_LOCALE
 
 STATIC locale_t
@@ -432,6 +447,27 @@ S_use_curlocale_scratch(pTHX)
 
 #endif
 
+void
+Perl_locale_panic(const char * msg,
+                  const char * file_name,
+                  const line_t line,
+                  const int errnum)
+{
+    dTHX;
+
+    PERL_ARGS_ASSERT_LOCALE_PANIC;
+
+    force_locale_unlock();
+
+#ifdef USE_C_BACKTRACE
+    dump_c_backtrace(Perl_debug_log, 20, 1);
+#endif
+
+    /* diag_listed_as: panic: %s */
+    Perl_croak(aTHX_ "%s: %d: panic: %s; errno=%d\n",
+                     file_name, line, msg, errnum);
+}
+
 #define setlocale_failure_panic_c(                                          \
                         cat, current, failed, caller_0_line, caller_1_line) \
         setlocale_failure_panic_i(cat##_INDEX_, current, failed,            \
@@ -775,18 +811,16 @@ S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale, const line_t line)
         category_end = p;
 
         if (*p++ != '=') {
-            Perl_croak(aTHX_
-                "panic: %s: %d: Unexpected character in locale name '%02X",
-                __FILE__, __LINE__, *(p-1));
+            locale_panic_(Perl_form(aTHX_
+                          "Unexpected character in locale name '%02X", *(p-1)));
         }
 
         /* Parse through the locale name */
         name_start = p;
         while (p < e && *p != ';') {
             if (! isGRAPH(*p)) {
-                Perl_croak(aTHX_
-                 "panic: %s: %d: Unexpected character in locale name '%02X",
-                 __FILE__, __LINE__, *(p-1));
+                locale_panic_(Perl_form(aTHX_
+                          "Unexpected character in locale name '%02X", *(p-1)));
             }
             p++;
         }
@@ -1469,27 +1503,21 @@ S_setlocale_failure_panic_i(pTHX_
                             const line_t caller_0_line,
                             const line_t caller_1_line)
 {
+    dSAVE_ERRNO;
     const int cat = categories[cat_index];
     const char * name = category_names[cat_index];
-    dSAVE_ERRNO;
 
     PERL_ARGS_ASSERT_SETLOCALE_FAILURE_PANIC_I;
 
-#ifdef USE_C_BACKTRACE
-    dump_c_backtrace(Perl_debug_log, 20, 1);
-#endif
-
-    SETLOCALE_UNLOCK;
-
     if (current == NULL) {
         current = querylocale_i(cat_index);
     }
 
-    RESTORE_ERRNO;
-    Perl_croak(aTHX_ "panic: %s: %d:(%d): Can't change locale for %s(%d)"
-                     " from '%s' to '%s'; errno=%d\n",
-                     __FILE__, caller_0_line, caller_1_line, name, cat,
-                     current, failed, errno);
+    Perl_locale_panic(Perl_form(aTHX_ "(%d): Can't change locale for %s(%d)"
+                                      " from '%s' to '%s'",
+                                      caller_1_line, name, cat,
+                                      current, failed),
+                      __FILE__, caller_0_line, GET_ERRNO);
     NOT_REACHED; /* NOTREACHED */
 }
 
@@ -3374,10 +3402,8 @@ S_get_nl_item_from_localeconv(pTHX_ const struct lconv *lcbuf,
         break;
 
       default:
-        Perl_croak_nocontext(
-            "panic: %s: %d: Unexpected item passed to populate_localeconv:"
-            "%d\n", __FILE__, __LINE__, item);
-        NOT_REACHED; /* NOTREACHED */                                   \
+        locale_panic_(Perl_form(aTHX_
+                    "Unexpected item passed to populate_localeconv: %d", item));
     }
 
     return (HV *) Perl_newSVpvf(aTHX_ "%s%s", prefix, temp);
@@ -4028,9 +4054,7 @@ S_my_langinfo_i(pTHX_
 
                 switch (item) {
                     default:
-                        Perl_croak(aTHX_
-                                    "panic: %s: %d: switch case: %d problem",
-                                       __FILE__, __LINE__, item);
+                locale_panic_(Perl_form(aTHX_ "switch case: %d problem", item));
                         NOT_REACHED; /* NOTREACHED */
               case PM_STR: hour = 18;
                     case AM_STR:
@@ -4682,8 +4706,9 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 
     PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
     if (! PL_C_locale_obj) {
-        Perl_croak_nocontext(
-            "panic: Cannot create POSIX 2008 C locale object; errno=%d", errno);
+        locale_panic_(Perl_form(aTHX_
+                      "Cannot create POSIX 2008 C locale object; errno=%d",
+                      errno));
     }
 
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
@@ -5689,9 +5714,8 @@ S_toggle_locale_i(pTHX_ const unsigned cat_index, const char * new_locale)
                            __FILE__, __LINE__, cat_index, category_names[cat_index], new_locale, locale_to_restore_to));
 
     if (! locale_to_restore_to) {
-        Perl_croak(aTHX_
-             "panic: %s: %d: Could not find current %s locale, errno=%d\n",
-                __FILE__, __LINE__, category_names[cat_index], errno);
+        locale_panic_(Perl_form(aTHX_ "Could not find current %s locale, errno=%d",
+                                category_names[cat_index], errno));
     }
 
     /* If the locales are the same, there's nothing to do */

perl.h

@@ -6648,6 +6648,7 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
 #  define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(c)
 #endif
 
+#define locale_panic_(m)  Perl_locale_panic((m), __FILE__, __LINE__, errno)
 
 /* Locale/thread synchronization macros. */
 #if ! (   defined(USE_LOCALE)                                               \
@@ -6814,9 +6815,7 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
                         "%s: %d: avoided lc_numeric_lock; new depth=%d\n",  \
                         __FILE__, __LINE__, PL_lc_numeric_mutex_depth));    \
                 if (cond_to_panic_if_already_locked) {                      \
-                    Perl_croak_nocontext("panic: %s: %d: Trying to change"  \
-                                         " LC_NUMERIC incompatibly",        \
-                                         __FILE__, __LINE__);               \
+                  locale_panic_("Trying to change LC_NUMERIC incompatibly");\
                 }                                                           \
             }                                                               \
         } STMT_END

proto.h

@@ -1117,6 +1117,8 @@ PERL_STATIC_INLINE I32	Perl_foldEQ_locale(const char* a, const char* b, I32 len)
 PERL_CALLCONV I32	Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags);
 #define PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS	\
 	assert(s1); assert(s2)
+PERL_CALLCONV void	Perl_force_locale_unlock(void);
+#define PERL_ARGS_ASSERT_FORCE_LOCALE_UNLOCK
 PERL_CALLCONV char*	Perl_form(pTHX_ const char* pat, ...)
 			__attribute__format__(__printf__,pTHX_1,pTHX_2);
 #define PERL_ARGS_ASSERT_FORM	\
@@ -1839,6 +1841,11 @@ PERL_CALLCONV HV*	Perl_load_charnames(pTHX_ SV * char_name, const char * context
 PERL_CALLCONV void	Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...);
 #define PERL_ARGS_ASSERT_LOAD_MODULE	\
 	assert(name)
+PERL_CALLCONV_NO_RET void	Perl_locale_panic(const char * msg, const char * file_name, const line_t line, const int errnum)
+			__attribute__noreturn__;
+#define PERL_ARGS_ASSERT_LOCALE_PANIC	\
+	assert(msg); assert(file_name)
+
 PERL_CALLCONV OP*	Perl_localize(pTHX_ OP *o, I32 lex);
 #define PERL_ARGS_ASSERT_LOCALIZE	\
 	assert(o)