/* 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
PERL_ARGS_ASSERT_STDIZE_LOCALE;
if (s) {
- const char * const t = strchr(s, '.');
- okay = FALSE;
- if (t) {
- const char * const u = strchr(t, '\n');
- if (u && (u[1] == 0)) {
- const STRLEN len = u - s;
- Move(s + 1, locs, len, char);
- locs[len] = 0;
- okay = TRUE;
- }
- }
+ const char * const t = strchr(s, '.');
+ okay = FALSE;
+ if (t) {
+ const char * const u = strchr(t, '\n');
+ if (u && (u[1] == 0)) {
+ const STRLEN len = u - s;
+ Move(s + 1, locs, len, char);
+ locs[len] = 0;
+ okay = TRUE;
+ }
+ }
}
if (!okay)
- Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
+ Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
return locs;
}
# 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.
int mask;
locale_t old_obj;
locale_t new_obj;
+ const char * safelocale = locale ? locale : "(null)";
dTHX;
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale input=%d (%s), \"%s\", %d, %d\n", __FILE__, __LINE__, category, category_name(category), locale, index, is_index_valid);
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale input=%d (%s), \"%s\", %d, %d\n", __FILE__, __LINE__, category, category_name(category), safelocale, index, is_index_valid);
}
# endif
* Fallback to the early POSIX usages */
Perl_warner(aTHX_ packWARN(WARN_LOCALE),
"Unknown locale category %d; can't set it to %s\n",
- category, locale);
+ category, safelocale);
return NULL;
found_index: ;
/* If this assert fails, adjust the size of curlocales in intrpvar.h */
STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX);
-# if defined(_NL_LOCALE_NAME) \
- && defined(DEBUGGING) \
+# if defined(_NL_LOCALE_NAME) \
+ && defined(DEBUGGING) \
+ /* On systems that accept any locale name, the real underlying \
+ * locale is often returned by this internal function, so we \
+ * can't use it */ \
&& ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME)
- /* On systems that accept any locale name, the real underlying locale
- * is often returned by this internal function, so we can't use it */
{
/* Internal glibc for querylocale(), but doesn't handle
* empty-string ("") locale properly; who knows what other
# 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: ;
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, PL_C_locale_obj);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale now using %p\n",
+ __FILE__, __LINE__, PL_C_locale_obj);
}
# endif
- /* If we weren't in a thread safe locale, set so that newlocale() below
- which uses 'old_obj', uses an empty one. Same for our reserved C object.
- The latter is defensive coding, so that, even if there is some bug, we
- will never end up trying to modify either of these, as if passed to
- newlocale(), they can be. */
- if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
- old_obj = (locale_t) 0;
- }
-
- /* Ready to create a new locale by modification of the exising one */
- new_obj = newlocale(mask, locale, old_obj);
-
- if (! new_obj) {
- dSAVE_ERRNO;
+ /* 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)) {
# ifdef DEBUGGING
- if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale creating new object failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: will stay in C object\n", __FILE__, __LINE__);
}
# endif
- if (! uselocale(old_obj)) {
+ new_obj = PL_C_locale_obj;
+
+ /* We already had switched to the C locale in preparation for freeing
+ * 'old_obj' */
+ if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) {
+ freelocale(old_obj);
+ }
+ }
+ else {
+ /* If we weren't in a thread safe locale, set so that newlocale() below
+ * which uses 'old_obj', uses an empty one. Same for our reserved C
+ * object. The latter is defensive coding, so that, even if there is
+ * some bug, we will never end up trying to modify either of these, as
+ * if passed to newlocale(), they can be. */
+ if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
+ old_obj = (locale_t) 0;
+ }
+
+ /* Ready to create a new locale by modification of the exising one */
+ new_obj = newlocale(mask, locale, old_obj);
+
+ if (! new_obj) {
+ dSAVE_ERRNO;
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale creating new object"
+ " failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
}
# endif
- }
- RESTORE_ERRNO;
- return NULL;
- }
+ if (! uselocale(old_obj)) {
# ifdef DEBUGGING
- if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p", __FILE__, __LINE__, new_obj);
- if (old_obj) {
- PerlIO_printf(Perl_debug_log, "; should have freed %p", old_obj);
- }
- PerlIO_printf(Perl_debug_log, "\n");
- }
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: switching back failed: %d\n",
+ __FILE__, __LINE__, GET_ERRNO);
+ }
# endif
- /* And switch into it */
- if (! uselocale(new_obj)) {
- dSAVE_ERRNO;
+ }
+ RESTORE_ERRNO;
+ return NULL;
+ }
# ifdef DEBUGGING
- if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to new object failed\n", __FILE__, __LINE__);
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale created %p",
+ __FILE__, __LINE__, new_obj);
+ if (old_obj) {
+ PerlIO_printf(Perl_debug_log,
+ "; should have freed %p", old_obj);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
}
# endif
- if (! uselocale(old_obj)) {
+ /* And switch into it */
+ if (! uselocale(new_obj)) {
+ dSAVE_ERRNO;
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale switching to new object"
+ " failed\n", __FILE__, __LINE__);
}
# endif
+ if (! uselocale(old_obj)) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: switching back failed: %d\n",
+ __FILE__, __LINE__, GET_ERRNO);
+ }
+
+# endif
+
+ }
+ freelocale(new_obj);
+ RESTORE_ERRNO;
+ return NULL;
}
- freelocale(new_obj);
- RESTORE_ERRNO;
- return NULL;
}
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, new_obj);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale now using %p\n",
+ __FILE__, __LINE__, new_obj);
}
# endif
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
#endif /* USE_POSIX_2008_LOCALE */
-#if 0 /* Code that was to emulate thread-safe locales on platforms that
- didn't natively support them */
-
-/* The way this would work is that we would keep a per-thread list of the
- * correct locale for that thread. Any operation that was locale-sensitive
- * would have to be changed so that it would look like this:
- *
- * LOCALE_LOCK;
- * setlocale to the correct locale for this operation
- * do operation
- * LOCALE_UNLOCK
- *
- * This leaves the global locale in the most recently used operation's, but it
- * was locked long enough to get the result. If that result is static, it
- * needs to be copied before the unlock.
- *
- * Macros could be written like SETUP_LOCALE_DEPENDENT_OP(category) that did
- * the setup, but are no-ops when not needed, and similarly,
- * END_LOCALE_DEPENDENT_OP for the tear-down
- *
- * But every call to a locale-sensitive function would have to be changed, and
- * if a module didn't cooperate by using the mutex, things would break.
- *
- * This code was abandoned before being completed or tested, and is left as-is
-*/
-
-# define do_setlocale_c(cat, locale) locking_setlocale(cat, locale, cat ## _INDEX, TRUE)
-# define do_setlocale_r(cat, locale) locking_setlocale(cat, locale, 0, FALSE)
-
-STATIC char *
-S_locking_setlocale(pTHX_
- const int category,
- const char * locale,
- int index,
- const bool is_index_valid
- )
-{
- /* This function kind of performs a setlocale() on just the current thread;
- * thus it is kind of thread-safe. It does this by keeping a thread-level
- * array of the current locales for each category. Every time a locale is
- * switched to, it does the switch globally, but updates the thread's
- * array. A query as to what the current locale is just returns the
- * appropriate element from the array, and doesn't actually call the system
- * setlocale(). The saving into the array is done in an uninterruptible
- * section of code, so is unaffected by whatever any other threads might be
- * doing.
- *
- * All locale-sensitive operations must work by first starting a critical
- * section, then switching to the thread's locale as kept by this function,
- * and then doing the operation, then ending the critical section. Thus,
- * each gets done in the appropriate locale. simulating thread-safety.
- *
- * This function takes the same parameters, 'category' and 'locale', that
- * the regular setlocale() function does, but it also takes two additional
- * 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
- * 'is_index_valid' to TRUE; otherwise the index parameter is ignored.
- *
- */
-
- /* If the input index might be incorrect, calculate the correct one */
- if (! is_index_valid) {
- unsigned int i;
-
- if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: converting category %d to index\n", __FILE__, __LINE__, category);
- }
-
- for (i = 0; i <= LC_ALL_INDEX; i++) {
- if (category == categories[i]) {
- index = i;
- goto found_index;
- }
- }
-
- /* Here, we don't know about this category, so can't handle it.
- * XXX best we can do is to unsafely set this
- * XXX warning */
-
- return my_setlocale(category, locale);
-
- found_index: ;
-
- if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: index is 0x%x\n", __FILE__, __LINE__, index);
- }
- }
-
- /* For a query, just return what's in our records */
- if (new_locale == NULL) {
- return curlocales[index];
- }
-
-
- /* Otherwise, we need to do the switch, and save the result, all in a
- * critical section */
-
- Safefree(curlocales[[index]]);
-
- /* It might be that this is called from an already-locked section of code.
- * We would have to detect and skip the LOCK/UNLOCK if so */
- LOCALE_LOCK;
-
- curlocales[index] = savepv(my_setlocale(category, new_locale));
-
- if (strEQ(new_locale, "")) {
-
-#ifdef LC_ALL
-
- /* The locale values come from the environment, and may not all be the
- * same, so for LC_ALL, we have to update all the others, while the
- * mutex is still locked */
-
- if (category == LC_ALL) {
- unsigned int i;
- for (i = 0; i < LC_ALL_INDEX) {
- curlocales[i] = my_setlocale(categories[i], NULL);
- }
- }
- }
-
-#endif
-
- LOCALE_UNLOCK;
-
- return curlocales[index];
-}
-
-#endif
#ifdef USE_LOCALE
STATIC void
char *save_newnum;
if (! newnum) {
- Safefree(PL_numeric_name);
- PL_numeric_name = NULL;
- PL_numeric_standard = TRUE;
- PL_numeric_underlying = TRUE;
- PL_numeric_underlying_is_standard = TRUE;
- return;
+ Safefree(PL_numeric_name);
+ PL_numeric_name = NULL;
+ PL_numeric_standard = TRUE;
+ PL_numeric_underlying = TRUE;
+ PL_numeric_underlying_is_standard = TRUE;
+ return;
}
save_newnum = stdize_locale(savepv(newnum));
/* Save the new name if it isn't the same as the previous one, if any */
if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
- Safefree(PL_numeric_name);
- PL_numeric_name = save_newnum;
+ Safefree(PL_numeric_name);
+ PL_numeric_name = save_newnum;
}
else {
- Safefree(save_newnum);
+ Safefree(save_newnum);
}
PL_numeric_underlying_is_standard = PL_numeric_standard;
* 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",
* an unlikely bug */
if (! newcoll) {
- if (PL_collation_name) {
- ++PL_collation_ix;
- Safefree(PL_collation_name);
- PL_collation_name = NULL;
- }
- PL_collation_standard = TRUE;
+ if (PL_collation_name) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = NULL;
+ }
+ PL_collation_standard = TRUE;
is_standard_collation:
- PL_collxfrm_base = 0;
- PL_collxfrm_mult = 2;
+ PL_collxfrm_base = 0;
+ PL_collxfrm_mult = 2;
PL_in_utf8_COLLATE_locale = FALSE;
PL_strxfrm_NUL_replacement = '\0';
PL_strxfrm_max_cp = 0;
- return;
+ return;
}
/* If this is not the same locale as currently, set the new one up */
if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
- ++PL_collation_ix;
- Safefree(PL_collation_name);
- PL_collation_name = stdize_locale(savepv(newcoll));
- PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = stdize_locale(savepv(newcoll));
+ PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
if (PL_collation_standard) {
goto is_standard_collation;
}
* get it right the first time to avoid wasted expensive string
* transformations. */
- {
+ {
/* We use the string below to find how long the tranformation of it
* is. Almost all locales are supersets of ASCII, or at least the
* ASCII letters. We use all of them, half upper half lower,
}
# endif
- }
+ }
}
#endif /* USE_LOCALE_COLLATE */
#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")));
#endif
/*
-
-=head1 Locale-related functions and macros
-
=for apidoc Perl_setlocale
This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
{
/* This wraps POSIX::setlocale() */
-#ifdef NO_LOCALE
+#ifndef USE_LOCALE
PERL_UNUSED_ARG(category);
PERL_UNUSED_ARG(locale);
=item *
The system function it replaces can have its static return buffer trashed,
-not only by a subesequent call to that function, but by a C<freelocale>,
+not only by a subsequent call to that function, but by a C<freelocale>,
C<setlocale>, or other locale change. The returned buffer of this function is
not changed until the next call to it, so the buffer is never in a trashed
state.
#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
- || ! defined(HAS_POSIX_2008_LOCALE) \
- || ! defined(DUPLOCALE)
+ || ! defined(HAS_POSIX_2008_LOCALE)
/* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
* for those items dependent on it. This must be copied to a buffer before
STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
}
- LOCALE_LOCK; /* Prevent interference from another thread executing
- this code section (the only call to nl_langinfo in
- the core) */
-
+ /* Prevent interference from another thread executing this code
+ * section. */
+ NL_LANGINFO_LOCK;
/* Copy to a per-thread buffer, which is also one that won't be
* destroyed by a subsequent setlocale(), such as the
* RESTORE_LC_NUMERIC may do just below. */
retval = save_to_buffer(nl_langinfo(item),
&PL_langinfo_buf, &PL_langinfo_bufsize, 0);
-
- LOCALE_UNLOCK;
+ NL_LANGINFO_UNLOCK;
if (toggle) {
RESTORE_LC_NUMERIC();
/* We don't bother with localeconv_l() because any system that
* has it is likely to also have nl_langinfo() */
- LOCALE_LOCK_V; /* Prevent interference with other threads
- using localeconv() */
+ LOCALECONV_LOCK; /* Prevent interference with other threads
+ using localeconv() */
# ifdef TS_W32_BROKEN_LOCALECONV
|| ! lc->currency_symbol
|| strEQ("", lc->currency_symbol))
{
- LOCALE_UNLOCK_V;
+ LOCALECONV_UNLOCK;
return "";
}
# endif
- LOCALE_UNLOCK_V;
+ LOCALECONV_UNLOCK;
break;
# ifdef TS_W32_BROKEN_LOCALECONV
STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
}
- LOCALE_LOCK_V; /* Prevent interference with other threads
- using localeconv() */
+ LOCALECONV_LOCK; /* Prevent interference with other threads
+ using localeconv() */
# ifdef TS_W32_BROKEN_LOCALECONV
# endif
- LOCALE_UNLOCK_V;
+ LOCALECONV_UNLOCK;
if (toggle) {
RESTORE_LC_NUMERIC();
case MON_5: case MON_6: case MON_7: case MON_8:
case MON_9: case MON_10: case MON_11: case MON_12:
- LOCALE_LOCK;
-
init_tm(&tm); /* Precaution against core dumps */
tm.tm_sec = 30;
tm.tm_min = 30;
tm.tm_year = 2017 - 1900;
tm.tm_wday = 0;
tm.tm_mon = 0;
+
+ GCC_DIAG_IGNORE_STMT(-Wimplicit-fallthrough);
+
switch (item) {
default:
- LOCALE_UNLOCK;
Perl_croak(aTHX_
"panic: %s: %d: switch case: %d problem",
__FILE__, __LINE__, item);
break;
}
+ GCC_DIAG_RESTORE_STMT;
+
/* We can't use my_strftime() because it doesn't look at
* tm_wday */
while (0 == strftime(PL_langinfo_buf, PL_langinfo_bufsize,
* wday was chosen because its range is all a single digit.
* Things like tm_sec have two digits as the minimum: '00' */
- LOCALE_UNLOCK;
-
retval = PL_langinfo_buf;
/* If to return the format, not the value, overwrite the buffer
* Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
* set, debugging information is output.
*
- * This looks more complicated than it is, mainly due to the #ifdefs.
+ * This looks more complicated than it is, mainly due to the #ifdefs and
+ * error handling.
+ *
+ * Besides some asserts, data structure initialization, and specific
+ * platform complications, this routine is effectively just two things.
+ *
+ * a) setlocale(LC_ALL, "");
+ *
+ * which sets LC_ALL to the values in the current environment.
+ *
+ * And for each individual category 'foo' whose value we care about:
+ *
+ * b) save_foo = setlocale(LC_foo, NULL); handle_foo(save_foo);
+ *
+ * (We don't tend to care about categories like LC_PAPER, for example.)
*
- * We try to set LC_ALL to the value determined by the environment. If
- * there is no LC_ALL on this platform, we try the individual categories we
- * know about. If this works, we are done.
+ * But there are complications. On systems without LC_ALL, it emulates
+ * step a) by looping through all the categories, and doing
*
- * But if it doesn't work, we have to do something else. We search the
- * environment variables ourselves instead of relying on the system to do
- * it. We look at, in order, LC_ALL, LANG, a system default locale (if we
- * think there is one), and the ultimate fallback "C". This is all done in
- * the same loop as above to avoid duplicating code, but it makes things
- * more complex. The 'trial_locales' array is initialized with just one
- * element; it causes the behavior described in the paragraph above this to
- * happen. If that fails, we add elements to 'trial_locales', and do extra
- * loop iterations to cause the behavior described in this paragraph.
+ * setlocale(LC_foo, "");
+ *
+ * on each.
+ *
+ * And it has to deal with if this is an embedded perl, whose locale
+ * doesn't come from the environment, but has been set up by the caller.
+ * This is pretty simply handled: the "" in the setlocale calls is not a
+ * string constant, but a variable which is set to NULL in the embedded
+ * case.
+ *
+ * But the major complication is handling failure and doing fallback.
+ * There is an array, trial_locales, the elements of which are looped over
+ * until the locale is successfully set. The array is initialized with
+ * just one element, for
+ * setlocale(LC_ALL, $NULL_or_empty)
+ * If that works, as it almost always does, there's no more elements and
+ * the loop iterates just the once. Otherwise elements are added for each
+ * of the environment variables that POSIX dictates should control the
+ * program, in priority order, with a final one being "C". The loop is
+ * repeated until the first one succeeds. If all fail, we limp along with
+ * whatever state we got to. If there is no LC_ALL, an inner loop is run
+ * through all categories (making things look complex).
+ *
+ * A further complication is that Windows has an additional fallback, the
+ * user-default ANSI code page obtained from the operating system. This is
+ * added as yet another loop iteration, just before the final "C"
*
* On Ultrix, the locale MUST come from the environment, so there is
* preliminary code to set it. I (khw) am not sure that it is necessary,
* and that this couldn't be folded into the loop, but barring any real
* platforms to test on, it's staying as-is
- *
- * A slight complication is that in embedded Perls, the locale may already
- * be set-up, and we don't want to get it from the normal environment
- * variables. This is handled by having a special environment variable
- * indicate we're in this situation. We simply set setlocale's 2nd
- * parameter to be a NULL instead of "". That indicates to setlocale that
- * it is not to change anything, but to return the current value,
- * effectively initializing perl's db to what the locale already is.
- *
- * We play the same trick with NULL if a LC_ALL succeeds. We call
- * setlocale() on the individual categores with NULL to get their existing
- * 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;
DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
# define DEBUG_LOCALE_INIT(category, locale, result) \
- STMT_START { \
- if (debug_initialization) { \
+ STMT_START { \
+ if (debug_initialization) { \
PerlIO_printf(Perl_debug_log, \
"%s:%d: %s\n", \
__FILE__, __LINE__, \
locale, \
result)); \
} \
- } STMT_END
+ } STMT_END
/* Make sure the parallel arrays are properly set up */
# ifdef USE_LOCALE_NUMERIC
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,
sizeof(PL_locale_utf8ness));
+ /* See https://github.com/Perl/perl5/issues/17824 */
+ Zero(curlocales, NOMINAL_LC_ALL_INDEX, char *);
+
# ifdef USE_THREAD_SAFE_LOCALE
# ifdef WIN32
DEBUG_LOCALE_INIT(categories[j], trial_locale, curlocales[j]);
}
- if (! setlocale_failure) { /* All succeeded */
+ if (LIKELY(! setlocale_failure)) { /* All succeeded */
break; /* Exit trial_locales loop */
}
}
This is an alternative to using the -C command line switch
(the -C if present will override this). */
{
- const char *p = PerlEnv_getenv("PERL_UNICODE");
- PL_unicode = p ? parse_unicode_opts(&p) : 0;
- if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
- PL_utf8cache = -1;
+ const char *p = PerlEnv_getenv("PERL_UNICODE");
+ PL_unicode = p ? parse_unicode_opts(&p) : 0;
+ if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
+ PL_utf8cache = -1;
}
# 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 {
if (UNLIKELY(! xbuf)) {
DEBUG_L(PerlIO_printf(Perl_debug_log,
"_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
- goto bad;
+ goto bad;
}
/* Store the collation id */
if (DEBUG_Lv_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
"_mem_collxfrm required more space than previously calculated"
- " for locale %s, trying again with new guess=%d+%zu\n",
- PL_collation_name, (int) COLLXFRM_HDR_LEN,
+ " for locale %s, trying again with new guess=%zu+%zu\n",
+ PL_collation_name, COLLXFRM_HDR_LEN,
xAlloc - COLLXFRM_HDR_LEN);
}
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;
}
# if defined(HAS_MBRTOWC) && defined(USE_ITHREADS)
/* Prefer this function if available, as it's reentrant */
- memset(&ps, 0, sizeof(ps));;
+ memzero(&ps, sizeof(ps));;
PERL_UNUSED_RESULT(mbrtowc(&wc, NULL, 0, &ps)); /* Reset any shift
state */
SETERRNO(0, 0);
# else
- LOCALE_LOCK;
+ MBTOWC_LOCK;
PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
SETERRNO(0, 0);
len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
SAVE_ERRNO;
- LOCALE_UNLOCK;
+ MBTOWC_UNLOCK;
# endif
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)
/* 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
* same code at the same time. (On thread-safe perls, the LOCK is a
* no-op.) Since this is the only place in core that changes LC_MESSAGES
* (unless the user has called setlocale(), this works to prevent races. */
- LOCALE_LOCK;
+ SETLOCALE_LOCK;
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"my_strerror called with errnum %d\n", errnum));
if (! within_locale_scope) {
save_locale = do_setlocale_c(LC_MESSAGES, NULL);
if (! save_locale) {
+ SETLOCALE_UNLOCK;
Perl_croak(aTHX_
"panic: %s: %d: Could not find current LC_MESSAGES locale,"
" errno=%d\n", __FILE__, __LINE__, errno);
/* The setlocale() just below likely will zap 'save_locale', so
* create a copy. */
save_locale = savepv(save_locale);
- do_setlocale_c(LC_MESSAGES, "C");
+ if (! do_setlocale_c(LC_MESSAGES, "C")) {
+
+ /* If, for some reason, the locale change failed, we
+ * soldier on as best as possible under the circumstances,
+ * using the current locale, and clear save_locale, so we
+ * don't try to change back. On z/0S, all setlocale()
+ * calls fail after you've created a thread. This is their
+ * way of making sure the entire process is always a single
+ * locale. This means that 'use locale' is always in place
+ * for messages under these circumstances. */
+ Safefree(save_locale);
+ save_locale = NULL;
+ }
}
}
} /* end of ! within_locale_scope */
if (! within_locale_scope) {
if (save_locale && ! locale_is_C) {
if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
+ SETLOCALE_UNLOCK;
Perl_croak(aTHX_
- "panic: %s: %d: setlocale restore failed, errno=%d\n",
- __FILE__, __LINE__, errno);
+ "panic: %s: %d: setlocale restore to '%s' failed, errno=%d\n",
+ __FILE__, __LINE__, save_locale, errno);
}
Safefree(save_locale);
}
}
- LOCALE_UNLOCK;
+ SETLOCALE_UNLOCK;
# endif /* End of doesn't have strerror_l */
# ifdef DEBUGGING
=for apidoc switch_to_global_locale
-On systems without locale support, or on single-threaded builds, or on
+On systems without locale support, or on typical single-threaded builds, or on
platforms that do not support per-thread locale operations, this function does
nothing. On such systems that do have locale support, only a locale global to
the whole program is available.
* 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));
{ /* Free up */
locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
- if (cur_obj != LC_GLOBAL_LOCALE) {
+ if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
freelocale(cur_obj);
}
}