diff --git a/embed.fnc b/embed.fnc index cc4f7cb418ba..0b552b6e40a9 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3253,11 +3253,13 @@ S |void |new_LC_ALL |NULLOK const char* unused # ifdef USE_POSIX_2008_LOCALE S |const char*|emulate_setlocale_i|const unsigned int index \ |NULLOK const char* new_locale \ - |const int recalc_LC_ALL + |const int recalc_LC_ALL \ + |const line_t line 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 + |NN const char * locale \ + |const line_t line S |const char*|update_PL_curlocales_i|const unsigned int index \ |NN const char * new_locale \ |int recalc_LC_ALL diff --git a/embed.h b/embed.h index c2ac14d2c6cc..68340e31327e 100644 --- a/embed.h +++ b/embed.h @@ -1710,10 +1710,10 @@ #define stdize_locale(a,b,c,d) S_stdize_locale(aTHX_ a,b,c,d) #define switch_category_locale_to_template(a,b,c) S_switch_category_locale_to_template(aTHX_ a,b,c) # if defined(USE_POSIX_2008_LOCALE) -#define emulate_setlocale_i(a,b,c) S_emulate_setlocale_i(aTHX_ a,b,c) +#define emulate_setlocale_i(a,b,c,d) S_emulate_setlocale_i(aTHX_ a,b,c,d) #define find_locale_from_environment(a) S_find_locale_from_environment(aTHX_ a) #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 setlocale_from_aggregate_LC_ALL(a,b) S_setlocale_from_aggregate_LC_ALL(aTHX_ a,b) #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 diff --git a/locale.c b/locale.c index c5d7f9a4641f..c4f1fc95cc81 100644 --- a/locale.c +++ b/locale.c @@ -516,12 +516,12 @@ S_use_curlocale_scratch(pTHX) * are equivalents, like LC_NUMERIC_MASK, which we use instead, converting to * by using get_category_index() followed by table lookup. */ -# define emulate_setlocale_c(cat, locale, recalc_LC_ALL) \ - emulate_setlocale_i(cat##_INDEX_, locale, recalc_LC_ALL) +# define emulate_setlocale_c(cat, locale, recalc_LC_ALL, line) \ + emulate_setlocale_i(cat##_INDEX_, locale, recalc_LC_ALL, line) /* A wrapper for the macros below. TRUE => do recalculate LC_ALL */ # define common_emulate_setlocale(i, locale) \ - emulate_setlocale_i(i, locale, TRUE) + emulate_setlocale_i(i, locale, TRUE, __LINE__) # define setlocale_i(i, locale) common_emulate_setlocale(i, locale) # define setlocale_c(cat, locale) setlocale_i(cat##_INDEX_, locale) @@ -649,8 +649,8 @@ S_my_querylocale_i(pTHX_ const unsigned int index) category = categories[index]; - DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: my_querylocale_i %p\n", - __FILE__, __LINE__, cur_obj)); + DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: my_querylocale_i(%s) on %p\n", + __FILE__, __LINE__, category_names[index], cur_obj)); if (cur_obj == LC_GLOBAL_LOCALE) { retval = porcelain_setlocale(category, NULL); } @@ -736,7 +736,7 @@ S_update_PL_curlocales_i(pTHX_ } STATIC const char * -S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale) +S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale, const line_t line) { /* This function parses the value of the LC_ALL locale, assuming glibc * syntax, and sets each individual category on the system to the proper @@ -774,9 +774,9 @@ S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale) * all the individual categories to "C", and override the furnished * ones below. FALSE => No need to recalculate LC_ALL, as this is a * temporary state */ - if (! emulate_setlocale_c(LC_ALL, "C", FALSE)) { + if (! emulate_setlocale_c(LC_ALL, "C", FALSE, line)) { setlocale_failure_panic_c(LC_ALL, locale_on_entry, - "C", __LINE__, 0); + "C", __LINE__, line); NOT_REACHED; /* NOTREACHED */ } @@ -828,13 +828,14 @@ S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale) /* FALSE => Don't recalculate LC_ALL; we'll do it ourselves after * the loop */ - if (! emulate_setlocale_i(i, individ_locale, FALSE)) { + if (! emulate_setlocale_i(i, individ_locale, FALSE, line)) { /* But if we have to back out, do fix up LC_ALL */ - if (! emulate_setlocale_c(LC_ALL, locale_on_entry, TRUE)) { + if (! emulate_setlocale_c(LC_ALL, locale_on_entry, TRUE, line)) + { Safefree(locale_on_entry); setlocale_failure_panic_i(i, individ_locale, - locale, __LINE__, 0); + locale, __LINE__, line); NOT_REACHED; /* NOTREACHED */ } Safefree(locale_on_entry); @@ -942,7 +943,8 @@ STATIC const char * S_emulate_setlocale_i(pTHX_ const unsigned int index, const char * new_locale, - const int recalc_LC_ALL) + const int recalc_LC_ALL, + const line_t line) { /* This function effectively performs a setlocale() on just the current * thread; thus it is thread-safe. It does this by using the POSIX 2008 @@ -993,7 +995,7 @@ S_emulate_setlocale_i(pTHX_ } if (strchr(new_locale, ';')) { - return setlocale_from_aggregate_LC_ALL(new_locale); + return setlocale_from_aggregate_LC_ALL(new_locale, line); } /* Here at the end of having to deal with the absence of querylocale(). @@ -1028,22 +1030,22 @@ S_emulate_setlocale_i(pTHX_ old_obj = uselocale(PL_C_locale_obj); DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i was using %p\n", - __FILE__, __LINE__, old_obj)); + "%s:%d:(%d): emulate_setlocale_i was using %p\n", + __FILE__, __LINE__, line, old_obj)); if (! old_obj) { dSAVE_ERRNO; DEBUG_L(PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i switching to C" - " failed: %d\n", __FILE__, __LINE__, GET_ERRNO)); + "%s:%d:(%d): emulate_setlocale_i switching to C" + " failed: %d\n", __FILE__, __LINE__, line, GET_ERRNO)); RESTORE_ERRNO; return NULL; } DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i now using %p\n", - __FILE__, __LINE__, PL_C_locale_obj)); + "%s:%d:(%d): emulate_setlocale_i now using C object=%p\n", + __FILE__, __LINE__, line, PL_C_locale_obj)); /* If this call is to switch LC_ALL to the 'C' locale, it already exists, * and in fact, we already have switched to it (in preparation for what @@ -1080,8 +1082,8 @@ S_emulate_setlocale_i(pTHX_ dSAVE_ERRNO; DEBUG_L(PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i creating new object" - " failed: %d\n", __FILE__, __LINE__, GET_ERRNO)); + "%s:%d:(%d): emulate_setlocale_i creating new object" + " failed: %d\n", __FILE__, __LINE__, line, GET_ERRNO)); if (! uselocale(old_obj)) { DEBUG_L(PerlIO_printf(Perl_debug_log, @@ -1094,8 +1096,8 @@ S_emulate_setlocale_i(pTHX_ DEBUG_Lv(STMT_START { PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i created %p", - __FILE__, __LINE__, new_obj); + "%s:%d:(%d): emulate_setlocale_i created %p", + __FILE__, __LINE__, line, new_obj); if (old_obj) PerlIO_printf(Perl_debug_log, "; should have freed %p", old_obj); PerlIO_printf(Perl_debug_log, "\n"); @@ -1106,8 +1108,8 @@ S_emulate_setlocale_i(pTHX_ dSAVE_ERRNO; DEBUG_L(PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i switching to new object" - " failed\n", __FILE__, __LINE__)); + "%s:%d:(%d): emulate_setlocale_i switching to new object" + " failed\n", __FILE__, __LINE__, line)); if (! uselocale(old_obj)) { @@ -1124,8 +1126,8 @@ S_emulate_setlocale_i(pTHX_ /* Here, we are using 'new_obj' which matches the input 'new_locale'. */ DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: emulate_setlocale_i now using %p\n", - __FILE__, __LINE__, new_obj)); + "%s:%d:(%d): emulate_setlocale_i now using %p\n", + __FILE__, __LINE__, line, new_obj)); /* We are done, except for updating our records (if the system doesn't keep * them) and in the case of locale "", we don't actually know what the @@ -2478,9 +2480,12 @@ Perl_setlocale(const int category, const char * locale) const char * retval; unsigned int cat_index; - dSAVEDERRNO; dTHX; + DEBUG_L(PerlIO_printf(Perl_debug_log, + "%s:%d: entering Perl_setlocale(%d, %s)\n", + __FILE__, __LINE__, category, locale)); + /* A NULL locale means only query what the current one is. */ if (locale == NULL) { @@ -2494,6 +2499,9 @@ Perl_setlocale(const int category, const char * locale) /* 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, + "%s:%d: returning stashed numeric=%s\n", + __FILE__, __LINE__, 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 */ @@ -2527,21 +2535,17 @@ Perl_setlocale(const int category, const char * locale) # endif + DEBUG_L(PerlIO_printf(Perl_debug_log, "returning '%s'\n", retval)); + return retval; } /* End of querying the current locale */ cat_index = get_category_index(category, NULL); retval = save_to_buffer(setlocale_i(cat_index, locale), &PL_setlocale_buf, &PL_setlocale_bufsize, 0); - SAVE_ERRNO; - - DEBUG_L(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - setlocale_debug_string_r(category, locale, retval))); - - RESTORE_ERRNO; - if (! retval) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Perl_setlocale returning (null)\n")); return NULL; } @@ -2551,6 +2555,9 @@ Perl_setlocale(const int category, const char * locale) update_functions[cat_index](aTHX_ retval); } + DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: returning '%s'\n", + __FILE__, __LINE__, retval)); + return retval; #endif @@ -3996,7 +4003,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * them now, calculating LC_ALL only on the final go round, when all have * been set. */ for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) { - (void) emulate_setlocale_i(i, curlocales[i], LOOPING); + (void) emulate_setlocale_i(i, curlocales[i], LOOPING, __LINE__); } # endif diff --git a/proto.h b/proto.h index d612172e72d1..733413a8c5cc 100644 --- a/proto.h +++ b/proto.h @@ -5155,13 +5155,13 @@ STATIC const char* S_stdize_locale(pTHX_ const int category, const char* input_l STATIC const char* S_switch_category_locale_to_template(pTHX_ const int switch_category, const int template_category, const char * template_locale); #define PERL_ARGS_ASSERT_SWITCH_CATEGORY_LOCALE_TO_TEMPLATE # if defined(USE_POSIX_2008_LOCALE) -STATIC const char* S_emulate_setlocale_i(pTHX_ const unsigned int index, const char* new_locale, const int recalc_LC_ALL); +STATIC const char* S_emulate_setlocale_i(pTHX_ const unsigned int index, const char* new_locale, const int recalc_LC_ALL, const line_t line); #define PERL_ARGS_ASSERT_EMULATE_SETLOCALE_I STATIC const char * S_find_locale_from_environment(pTHX_ const unsigned int index); #define PERL_ARGS_ASSERT_FIND_LOCALE_FROM_ENVIRONMENT STATIC const char* S_my_querylocale_i(pTHX_ const unsigned int index); #define PERL_ARGS_ASSERT_MY_QUERYLOCALE_I -STATIC const char * S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale); +STATIC const char * S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale, const line_t line); #define PERL_ARGS_ASSERT_SETLOCALE_FROM_AGGREGATE_LC_ALL \ assert(locale) STATIC const char* S_update_PL_curlocales_i(pTHX_ const unsigned int index, const char * new_locale, int recalc_LC_ALL);