/* If the environment says to, we can output debugging information during
* initialization. This is done before option parsing, and before any thread
* creation, so can be a file-level static */
-#if ! defined(DEBUGGING) || defined(PERL_GLOBAL_STRUCT)
+#if ! defined(DEBUGGING)
# define debug_initialization 0
# define DEBUG_INITIALIZATION_set(v)
#else
# ifdef USE_LOCALE_TELEPHONE
LC_TELEPHONE,
# endif
+# ifdef USE_LOCALE_SYNTAX
+ LC_SYNTAX,
+# endif
+# ifdef USE_LOCALE_TOD
+ LC_TOD,
+# endif
# ifdef LC_ALL
LC_ALL,
# endif
# ifdef USE_LOCALE_TELEPHONE
"LC_TELEPHONE",
# endif
+# ifdef USE_LOCALE_SYNTAX
+ "LC_SYNTAX",
+# endif
+# ifdef USE_LOCALE_TOD
+ "LC_TOD",
+# endif
# ifdef LC_ALL
"LC_ALL",
# endif
# else
# define _DUMMY_TELEPHONE _DUMMY_PAPER
# endif
+# ifdef USE_LOCALE_SYNTAX
+# define LC_SYNTAX_INDEX _DUMMY_TELEPHONE + 1
+# define _DUMMY_SYNTAX LC_SYNTAX_INDEX
+# else
+# define _DUMMY_SYNTAX _DUMMY_TELEPHONE
+# endif
+# ifdef USE_LOCALE_TOD
+# define LC_TOD_INDEX _DUMMY_SYNTAX + 1
+# define _DUMMY_TOD LC_TOD_INDEX
+# else
+# define _DUMMY_TOD _DUMMY_SYNTAX
+# endif
# ifdef LC_ALL
-# define LC_ALL_INDEX _DUMMY_TELEPHONE + 1
+# define LC_ALL_INDEX _DUMMY_TOD + 1
# endif
#endif /* ifdef USE_LOCALE */
* known at compile time; "do_setlocale_r", not known until run time */
# define do_setlocale_c(cat, locale) my_setlocale(cat, locale)
# define do_setlocale_r(cat, locale) my_setlocale(cat, locale)
+# define FIX_GLIBC_LC_MESSAGES_BUG(i)
#else /* Below uses POSIX 2008 */
emulate_setlocale(cat, locale, cat ## _INDEX, TRUE)
# define do_setlocale_r(cat, locale) emulate_setlocale(cat, locale, 0, FALSE)
+# if ! defined(__GLIBC__) || ! defined(USE_LOCALE_MESSAGES)
+
+# define FIX_GLIBC_LC_MESSAGES_BUG(i)
+
+# else /* Invalidate glibc cache of loaded translations, see [perl #134264] */
+
+# include <libintl.h>
+# define FIX_GLIBC_LC_MESSAGES_BUG(i) \
+ STMT_START { \
+ if ((i) == LC_MESSAGES_INDEX) { \
+ textdomain(textdomain(NULL)); \
+ } \
+ } STMT_END
+
+# endif
+
/* A third array, parallel to the ones above to map from category to its
* equivalent mask */
const int category_masks[] = {
# ifdef USE_LOCALE_TELEPHONE
LC_TELEPHONE_MASK,
# endif
+# ifdef USE_LOCALE_SYNTAX
+ LC_SYNTAX_MASK,
+# endif
+# ifdef USE_LOCALE_TOD
+ LC_TOD_MASK,
+# endif
/* LC_ALL can't be turned off by a Configure
* option, and in Posix 2008, should always be
* here, so compile it in unconditionally.
# endif
- }
+ } /* End of this being setlocale(LC_foo, NULL) */
/* Here, we are switching locales. */
const char * default_name;
- /* To minimize other threads messing with the environment, we copy
- * the variable, making it a temporary. But this doesn't work upon
- * program initialization before any scopes are created, and at
- * this time, there's nothing else going on that would interfere.
- * So skip the copy in that case */
- if (PL_scopestack_ix == 0) {
- default_name = PerlEnv_getenv("LANG");
- }
- else {
- default_name = savepv(PerlEnv_getenv("LANG"));
- }
+ default_name = PerlEnv_getenv("LANG");
if (! default_name || strEQ(default_name, "")) {
default_name = "C";
}
- else if (PL_scopestack_ix != 0) {
- SAVEFREEPV(default_name);
- }
if (category != LC_ALL) {
const char * const name = PerlEnv_getenv(category_names[index]);
for (i = 0; i < LC_ALL_INDEX; i++) {
const char * const env_override
- = savepv(PerlEnv_getenv(category_names[i]));
+ = PerlEnv_getenv(category_names[i]);
const char * this_locale = ( env_override
&& strNE(env_override, ""))
? env_override
: default_name;
if (! emulate_setlocale(categories[i], this_locale, i, TRUE))
{
- Safefree(env_override);
return NULL;
}
if (strNE(this_locale, default_name)) {
did_override = TRUE;
}
-
- Safefree(env_override);
}
/* If all the categories are the same, we can set LC_ALL to
}
}
}
- }
+ } /* End of this being setlocale(LC_foo, "") */
else if (strchr(locale, ';')) {
/* LC_ALL may actually incude a conglomeration of various categories.
assert(category == LC_ALL);
return do_setlocale_c(LC_ALL, NULL);
- }
+ } /* End of this being setlocale(LC_ALL,
+ "LC_CTYPE=foo;LC_NUMERIC=bar;...") */
ready_to_set: ;
# endif
- /* If we are switching to the LC_ALL C locale, it already exists. Use
+ /* If this call is to switch to the LC_ALL C locale, it already exists, and
+ * in fact, we already have switched to it (in preparation for what
+ * normally is to come). But since we're already there, continue to use
* it instead of trying to create a new locale */
if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(locale)) {
Safefree(PL_curlocales[i]);
PL_curlocales[i] = savepv(locale);
}
+
+ FIX_GLIBC_LC_MESSAGES_BUG(LC_MESSAGES_INDEX);
}
else {
/* Then update the category's record */
Safefree(PL_curlocales[index]);
PL_curlocales[index] = savepv(locale);
+
+ FIX_GLIBC_LC_MESSAGES_BUG(index);
}
# endif
* ones. This is because as described earlier. If we know on input the
* index corresponding to the category into the array where we store the
* current locales, we don't have to calculate it. If the caller knows at
- * compile time what the index is, it it can pass it, setting
+ * compile time what the index is, it can pass it, setting
* 'is_index_valid' to TRUE; otherwise the index parameter is ignored.
*
*/
* this function should be called directly only from this file and from
* POSIX::setlocale() */
- dVAR;
unsigned int i;
/* Don't check for problems if we are suppressing the warnings */
"isxdigit('%s') unexpectedly is %d\n",
name, cBOOL(isxdigit(i))));
}
- if (UNLIKELY(tolower(i) != (int) toLOWER_A(i))) {
+ if (UNLIKELY(tolower(i) != (int) toLOWER_A(i))) {
is_bad = TRUE;
DEBUG_L(PerlIO_printf(Perl_debug_log,
"tolower('%s')=0x%x instead of the expected 0x%x\n",
name, tolower(i), (int) toLOWER_A(i)));
}
- if (UNLIKELY(toupper(i) != (int) toUPPER_A(i))) {
+ if (UNLIKELY(toupper(i) != (int) toUPPER_A(i))) {
is_bad = TRUE;
DEBUG_L(PerlIO_printf(Perl_debug_log,
"toupper('%s')=0x%x instead of the expected 0x%x\n",
#ifdef WIN32
+#define USE_WSETLOCALE
+
+#ifdef USE_WSETLOCALE
+
+STATIC char *
+S_wrap_wsetlocale(pTHX_ int category, const char *locale) {
+ wchar_t *wlocale;
+ wchar_t *wresult;
+ char *result;
+
+ if (locale) {
+ int req_size =
+ MultiByteToWideChar(CP_UTF8, 0, locale, -1, NULL, 0);
+
+ if (!req_size) {
+ errno = EINVAL;
+ return NULL;
+ }
+
+ Newx(wlocale, req_size, wchar_t);
+ if (!MultiByteToWideChar(CP_UTF8, 0, locale, -1, wlocale, req_size)) {
+ Safefree(wlocale);
+ errno = EINVAL;
+ return NULL;
+ }
+ }
+ else {
+ wlocale = NULL;
+ }
+ wresult = _wsetlocale(category, wlocale);
+ Safefree(wlocale);
+ if (wresult) {
+ int req_size =
+ WideCharToMultiByte(CP_UTF8, 0, wresult, -1, NULL, 0, NULL, NULL);
+ Newx(result, req_size, char);
+ SAVEFREEPV(result); /* is there something better we can do here? */
+ if (!WideCharToMultiByte(CP_UTF8, 0, wresult, -1,
+ result, req_size, NULL, NULL)) {
+ errno = EINVAL;
+ return NULL;
+ }
+ }
+ else {
+ result = NULL;
+ }
+
+ return result;
+}
+
+#endif
+
STATIC char *
S_win32_setlocale(pTHX_ int category, const char* locale)
{
}
+#ifdef USE_WSETLOCALE
+ result = S_wrap_wsetlocale(aTHX_ category, locale);
+#else
result = setlocale(category, locale);
+#endif
DEBUG_L(STMT_START {
dSAVE_ERRNO;
PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
for (i = 0; i < LC_ALL_INDEX; i++) {
result = PerlEnv_getenv(category_names[i]);
if (result && strNE(result, "")) {
+#ifdef USE_WSETLOCALE
+ S_wrap_wsetlocale(aTHX_ categories[i], result);
+#else
setlocale(categories[i], result);
+#endif
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
setlocale_debug_string(categories[i], result, "not captured")));
/*
-=head1 Locale-related functions and macros
+=for apidoc_section Locales
=for apidoc Perl_setlocale
{
/* This wraps POSIX::setlocale() */
-#ifdef NO_LOCALE
+#ifndef USE_LOCALE
PERL_UNUSED_ARG(category);
PERL_UNUSED_ARG(locale);
* values for our db, instead of trying to change them.
* */
- dVAR;
int ok = 1;
#else /* USE_LOCALE */
# ifdef __GLIBC__
- const char * const language = savepv(PerlEnv_getenv("LANGUAGE"));
+ const char * const language = PerlEnv_getenv("LANGUAGE");
# endif
: "";
const char* trial_locales[5]; /* 5 = 1 each for "", LC_ALL, LANG, "", C */
unsigned int trial_locales_count;
- const char * const lc_all = savepv(PerlEnv_getenv("LC_ALL"));
- const char * const lang = savepv(PerlEnv_getenv("LANG"));
+ const char * const lc_all = PerlEnv_getenv("LC_ALL");
+ const char * const lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
unsigned int i;
assert(category_masks[LC_TELEPHONE_INDEX] == LC_TELEPHONE_MASK);
# endif
# endif
+# ifdef USE_LOCALE_SYNTAX
+ assert(categories[LC_SYNTAX_INDEX] == LC_SYNTAX);
+ assert(strEQ(category_names[LC_SYNTAX_INDEX], "LC_SYNTAX"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_SYNTAX_INDEX] == LC_SYNTAX_MASK);
+# endif
+# endif
+# ifdef USE_LOCALE_TOD
+ assert(categories[LC_TOD_INDEX] == LC_TOD);
+ assert(strEQ(category_names[LC_TOD_INDEX], "LC_TOD"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_TOD_INDEX] == LC_TOD_MASK);
+# endif
+# endif
# ifdef LC_ALL
assert(categories[LC_ALL_INDEX] == LC_ALL);
assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
# endif
# endif /* DEBUGGING */
+ /* Initialize the per-thread mbrFOO() state variables. See POSIX.xs for
+ * why these particular incantations are used. */
+#ifdef HAS_MBRLEN
+ memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
+#endif
+#ifdef HAS_MBRTOWC
+ memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
+#endif
+#ifdef HAS_WCTOMBR
+ wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
+#endif
+
/* Initialize the cache of the program's UTF-8ness for the always known
* locales C and POSIX */
my_strlcpy(PL_locale_utf8ness, C_and_POSIX_utf8ness,
}
# endif
-# ifdef __GLIBC__
-
- Safefree(language);
-
-# endif
-
- Safefree(lc_all);
- Safefree(lang);
-
#endif /* USE_LOCALE */
#ifdef DEBUGGING
cur_min_x + COLLXFRM_HDR_LEN))
{
PL_strxfrm_NUL_replacement = j;
+ Safefree(cur_min_x);
cur_min_x = x;
}
else {
cur_max_x + COLLXFRM_HDR_LEN))
{
PL_strxfrm_max_cp = j;
+ Safefree(cur_max_x);
cur_max_x = x;
}
else {
return xbuf;
bad:
- Safefree(xbuf);
- if (s != input_string) {
- Safefree(s);
- }
- *xlen = 0;
# ifdef DEBUGGING
# endif
+ Safefree(xbuf);
+ if (s != input_string) {
+ Safefree(s);
+ }
+ *xlen = 0;
+
return NULL;
}
Safefree(restore_to_locale);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale unchanged as %s\n",
- category_name(switch_category), restore_to_locale));
+ category_name(switch_category), template_locale));
return NULL;
}
Copy(delimited, utf8ness_cache, input_name_len_with_overhead - 1, char);
utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
- if ((PL_locale_utf8ness[strlen(PL_locale_utf8ness)-1]
- & (PERL_UINTMAX_T) ~1) != '0')
- {
+ if ((PL_locale_utf8ness[strlen(PL_locale_utf8ness)-1] & ~1) != '0') {
Perl_croak(aTHX_
"panic: %s: %d: Corrupt utf8ness_cache=%s\nlen=%zu,"
" inserted_name=%s, its_len=%zu\n",
s++;
e = strchr(s, UTF8NESS_PREFIX[0]);
if (! e) {
+ e = PL_locale_utf8ness + strlen(PL_locale_utf8ness);
Perl_croak(aTHX_
"panic: %s: %d: Corrupt utf8ness_cache: missing"
" separator %.*s<-- HERE %s\n",
bool
Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
{
- dVAR;
/* Internal function which returns if we are in the scope of a pragma that
* enables the locale category 'category'. 'compiling' should indicate if
* this is during the compilation phase (TRUE) or not (FALSE). */
* to the C locale */
char *errstr;
- dVAR;
#ifndef USE_LOCALE_MESSAGES
Safefree(save_locale);
}
-# elif defined(HAS_POSIX_2008_LOCALE) \
- && defined(HAS_STRERROR_L) \
- && defined(HAS_DUPLOCALE)
+# elif defined(USE_POSIX_2008_LOCALE) \
+ && defined(HAS_STRERROR_L) \
+ && defined(HAS_DUPLOCALE)
/* This function is also trivial if we don't have to worry about thread
* safety and have strerror_l(), as it handles the switch of locales so we
* be overwritten by the next call, so this should be used just to
* formulate a string to immediately print or savepv() on. */
- /* initialise to a non-null value to keep it out of BSS and so keep
- * -DPERL_GLOBAL_STRUCT_PRIVATE happy */
- static char ret[256] = "If you can read this, thank your buggy C"
- " library strlcpy(), and change your hints file"
- " to undef it";
+ static char ret[256];
my_strlcpy(ret, "setlocale(", sizeof(ret));
my_strlcat(ret, category_name(category), sizeof(ret));
# ifndef WIN32
{ /* Free up */
- dVAR;
locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
freelocale(cur_obj);
https://perl5.git.perl.org / perl5.git / blobdiff