* the desired behavior of those functions at the moment. And, LC_MESSAGES is
* switched to the C locale for outputting the message unless within the scope
* of 'use locale'.
+ *
+ * This code now has multi-thread-safe locale handling on systems that support
+ * that. This is completely transparent to most XS code. On earlier systems,
+ * it would be possible to emulate thread-safe locales, but this likely would
+ * involve a lot of locale switching, and would require XS code changes.
+ * Macros could be written so that the code wouldn't have to know which type of
+ * system is being used. It's unlikely that we would ever do that, since most
+ * modern systems support thread-safe locales, but there was code written to
+ * this end, and is retained, #ifdef'd out.
*/
#include "EXTERN.h"
#ifdef I_WCHAR
# include <wchar.h>
#endif
+#ifdef I_WCTYPE
+# include <wctype.h>
+#endif
/* 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
# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
#endif
+
+/* Returns the Unix errno portion; ignoring any others. This is a macro here
+ * instead of putting it into perl.h, because unclear to khw what should be
+ * done generally. */
+#define GET_ERRNO saved_errno
+
/* strlen() of a literal string constant. We might want this more general,
* but using it in just this file for now. A problem with more generality is
* the compiler warnings about comparing unlike signs */
# 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
/* The top-most real element is LC_ALL */
-const char * category_names[] = {
+const char * const category_names[] = {
# ifdef USE_LOCALE_NUMERIC
"LC_NUMERIC",
# 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
# define LC_COLLATE_INDEX _DUMMY_CTYPE + 1
# define _DUMMY_COLLATE LC_COLLATE_INDEX
# else
-# define _DUMMY_COLLATE _DUMMY_COLLATE
+# define _DUMMY_COLLATE _DUMMY_CTYPE
# endif
# ifdef USE_LOCALE_TIME
# define LC_TIME_INDEX _DUMMY_COLLATE + 1
# 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 */
-/* Windows requres a customized base-level setlocale() */
-# ifdef WIN32
-# define my_setlocale(cat, locale) win32_setlocale(cat, locale)
-# else
-# define my_setlocale(cat, locale) setlocale(cat, locale)
-# endif
+/* Windows requres a customized base-level setlocale() */
+#ifdef WIN32
+# define my_setlocale(cat, locale) win32_setlocale(cat, locale)
+#else
+# define my_setlocale(cat, locale) setlocale(cat, locale)
+#endif
+
+#ifndef USE_POSIX_2008_LOCALE
+
+/* "do_setlocale_c" is intended to be called when the category is a constant
+ * 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 */
+
+/* We emulate setlocale with our own function. LC_foo is not valid for the
+ * POSIX 2008 functions. Instead LC_foo_MASK is used, which we use an array
+ * lookup to convert to. At compile time we have defined LC_foo_INDEX as the
+ * proper offset into the array 'category_masks[]'. At runtime, we have to
+ * search through the array (as the actual numbers may not be small contiguous
+ * positive integers which would lend themselves to array lookup). */
+# define do_setlocale_c(cat, locale) \
+ 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_NUMERIC
+ LC_NUMERIC_MASK,
+# endif
+# ifdef USE_LOCALE_CTYPE
+ LC_CTYPE_MASK,
+# endif
+# ifdef USE_LOCALE_COLLATE
+ LC_COLLATE_MASK,
+# endif
+# ifdef USE_LOCALE_TIME
+ LC_TIME_MASK,
+# endif
+# ifdef USE_LOCALE_MESSAGES
+ LC_MESSAGES_MASK,
+# endif
+# ifdef USE_LOCALE_MONETARY
+ LC_MONETARY_MASK,
+# endif
+# ifdef USE_LOCALE_ADDRESS
+ LC_ADDRESS_MASK,
+# endif
+# ifdef USE_LOCALE_IDENTIFICATION
+ LC_IDENTIFICATION_MASK,
+# endif
+# ifdef USE_LOCALE_MEASUREMENT
+ LC_MEASUREMENT_MASK,
+# endif
+# ifdef USE_LOCALE_PAPER
+ LC_PAPER_MASK,
+# endif
+# 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.
+ * This could catch some glitches at compile
+ * time */
+ LC_ALL_MASK
+ };
+
+STATIC const char *
+S_emulate_setlocale(const int category,
+ const char * locale,
+ unsigned int index,
+ const bool is_index_valid
+ )
+{
+ /* This function effectively performs a setlocale() on just the current
+ * thread; thus it is thread-safe. It does this by using the POSIX 2008
+ * locale functions to emulate the behavior of setlocale(). Similar to
+ * regular setlocale(), the return from this function points to memory that
+ * can be overwritten by other system calls, so needs to be copied
+ * immediately if you need to retain it. The difference here is that
+ * system calls besides another setlocale() can overwrite it.
+ *
+ * By doing this, most locale-sensitive functions become thread-safe. The
+ * exceptions are mostly those that return a pointer to static memory.
+ *
+ * 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 the 2008 functions don't use a category; instead
+ * they use a corresponding mask. Because this function operates in both
+ * worlds, it may need one or the other or both. This function can
+ * calculate the mask from the input category, but to avoid this
+ * calculation, if the caller knows at compile time what the mask is, it
+ * can pass it, setting 'is_index_valid' to TRUE; otherwise the mask
+ * parameter is ignored.
+ *
+ * POSIX 2008, for some sick reason, chose not to provide a method to find
+ * the category name of a locale. Some vendors have created a
+ * querylocale() function to do just that. This function is a lot simpler
+ * to implement on systems that have this. Otherwise, we have to keep
+ * track of what the locale has been set to, so that we can return its
+ * name to emulate setlocale(). It's also possible for C code in some
+ * library to change the locale without us knowing it, though as of
+ * September 2017, there are no occurrences in CPAN of uselocale(). Some
+ * libraries do use setlocale(), but that changes the global locale, and
+ * threads using per-thread locales will just ignore those changes.
+ * Another problem is that without querylocale(), we have to guess at what
+ * was meant by setting a locale of "". We handle this by not actually
+ * ever setting to "" (unless querylocale exists), but to emulate what we
+ * think should happen for "".
+ */
+
+ int mask;
+ locale_t old_obj;
+ locale_t new_obj;
+ 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);
+ }
+
+# endif
+
+ /* If the input mask might be incorrect, calculate the correct one */
+ if (! is_index_valid) {
+ unsigned int i;
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: finding index of category %d (%s)\n", __FILE__, __LINE__, category, category_name(category));
+ }
+
+# endif
+
+ 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.
+ * 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);
+ return NULL;
+
+ found_index: ;
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: index is %d for %s\n", __FILE__, __LINE__, index, category_name(category));
+ }
+
+# endif
+
+ }
+
+ mask = category_masks[index];
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: category name is %s; mask is 0x%x\n", __FILE__, __LINE__, category_names[index], mask);
+ }
+
+# endif
+
+ /* If just querying what the existing locale is ... */
+ if (locale == NULL) {
+ locale_t cur_obj = uselocale((locale_t) 0);
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale querying %p\n", __FILE__, __LINE__, cur_obj);
+ }
+
+# endif
+
+ if (cur_obj == LC_GLOBAL_LOCALE) {
+ return my_setlocale(category, NULL);
+ }
+
+# ifdef HAS_QUERYLOCALE
+
+ return (char *) querylocale(mask, cur_obj);
+
+# else
+
+ /* 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) \
+ /* 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)
+ {
+ /* Internal glibc for querylocale(), but doesn't handle
+ * empty-string ("") locale properly; who knows what other
+ * glitches. Check for it now, under debug. */
+
+ char * temp_name = nl_langinfo_l(_NL_LOCALE_NAME(category),
+ uselocale((locale_t) 0));
+ /*
+ PerlIO_printf(Perl_debug_log, "%s:%d: temp_name=%s\n", __FILE__, __LINE__, temp_name ? temp_name : "NULL");
+ PerlIO_printf(Perl_debug_log, "%s:%d: index=%d\n", __FILE__, __LINE__, index);
+ PerlIO_printf(Perl_debug_log, "%s:%d: PL_curlocales[index]=%s\n", __FILE__, __LINE__, PL_curlocales[index]);
+ */
+ if (temp_name && PL_curlocales[index] && strNE(temp_name, "")) {
+ if ( strNE(PL_curlocales[index], temp_name)
+ && ! ( isNAME_C_OR_POSIX(temp_name)
+ && isNAME_C_OR_POSIX(PL_curlocales[index]))) {
+
+# ifdef USE_C_BACKTRACE
+
+ dump_c_backtrace(Perl_debug_log, 20, 1);
+
+# endif
+
+ Perl_croak(aTHX_ "panic: Mismatch between what Perl thinks %s is"
+ " (%s) and what internal glibc thinks"
+ " (%s)\n", category_names[index],
+ PL_curlocales[index], temp_name);
+ }
+
+ return temp_name;
+ }
+ }
+
+# endif
+
+ /* Without querylocale(), we have to use our record-keeping we've
+ * done. */
+
+ if (category != LC_ALL) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[index]);
+ }
+
+# endif
+
+ return PL_curlocales[index];
+ }
+ else { /* For LC_ALL */
+ unsigned int i;
+ Size_t names_len = 0;
+ char * all_string;
+ bool are_all_categories_the_same_locale = TRUE;
+
+ /* If we have a valid LC_ALL value, just return it */
+ if (PL_curlocales[LC_ALL_INDEX]) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[LC_ALL_INDEX]);
+ }
+
+# endif
+
+ return PL_curlocales[LC_ALL_INDEX];
+ }
+
+ /* Otherwise, we need to construct a string of name=value pairs.
+ * We use the glibc syntax, like
+ * LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
+ * First calculate the needed size. Along the way, check if all
+ * the locale names are the same */
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
+ }
+
+# endif
+
+ names_len += strlen(category_names[i])
+ + 1 /* '=' */
+ + strlen(PL_curlocales[i])
+ + 1; /* ';' */
+
+ if (i > 0 && strNE(PL_curlocales[i], PL_curlocales[i-1])) {
+ are_all_categories_the_same_locale = FALSE;
+ }
+ }
+
+ /* If they are the same, we don't actually have to construct the
+ * string; we just make the entry in LC_ALL_INDEX valid, and be
+ * that single name */
+ if (are_all_categories_the_same_locale) {
+ PL_curlocales[LC_ALL_INDEX] = savepv(PL_curlocales[0]);
+ return PL_curlocales[LC_ALL_INDEX];
+ }
+
+ names_len++; /* Trailing '\0' */
+ SAVEFREEPV(Newx(all_string, names_len, char));
+ *all_string = '\0';
+
+ /* Then fill in the string */
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
+ }
+
+# endif
+
+ my_strlcat(all_string, category_names[i], names_len);
+ my_strlcat(all_string, "=", names_len);
+ my_strlcat(all_string, PL_curlocales[i], names_len);
+ my_strlcat(all_string, ";", names_len);
+ }
+
+# ifdef DEBUGGING
+
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, all_string);
+ }
+
+ #endif
+
+ return all_string;
+ }
+
+# ifdef EINVAL
+
+ SETERRNO(EINVAL, LIB_INVARG);
+
+# endif
+
+ return NULL;
+
+# endif
+
+ } /* End of this being setlocale(LC_foo, NULL) */
+
+ /* Here, we are switching locales. */
+
+# ifndef HAS_QUERYLOCALE
+
+ if (strEQ(locale, "")) {
+
+ /* For non-querylocale() systems, we do the setting of "" ourselves to
+ * be sure that we really know what's going on. We follow the Linux
+ * documented behavior (but if that differs from the actual behavior,
+ * this won't work exactly as the OS implements). We go out and
+ * examine the environment based on our understanding of how the system
+ * works, and use that to figure things out */
+
+ const char * const lc_all = PerlEnv_getenv("LC_ALL");
+
+ /* Use any "LC_ALL" environment variable, as it overrides everything
+ * else. */
+ if (lc_all && strNE(lc_all, "")) {
+ locale = lc_all;
+ }
+ else {
+
+ /* Otherwise, we need to dig deeper. Unless overridden, the
+ * default is the LANG environment variable; if it doesn't exist,
+ * then "C" */
+
+ const char * default_name;
+
+ default_name = PerlEnv_getenv("LANG");
+
+ if (! default_name || strEQ(default_name, "")) {
+ default_name = "C";
+ }
+
+ if (category != LC_ALL) {
+ const char * const name = PerlEnv_getenv(category_names[index]);
+
+ /* Here we are setting a single category. Assume will have the
+ * default name */
+ locale = default_name;
+
+ /* But then look for an overriding environment variable */
+ if (name && strNE(name, "")) {
+ locale = name;
+ }
+ }
+ else {
+ bool did_override = FALSE;
+ unsigned int i;
+
+ /* Here, we are getting LC_ALL. Any categories that don't have
+ * a corresponding environment variable set should be set to
+ * LANG, or to "C" if there is no LANG. If no individual
+ * categories differ from this, we can just set LC_ALL. This
+ * is buggy on systems that have extra categories that we don't
+ * know about. If there is an environment variable that sets
+ * that category, we won't know to look for it, and so our use
+ * of LANG or "C" improperly overrides it. On the other hand,
+ * if we don't do what is done here, and there is no
+ * environment variable, the category's locale should be set to
+ * LANG or "C". So there is no good solution. khw thinks the
+ * best is to look at systems to see what categories they have,
+ * and include them, and then to assume that we know the
+ * complete set */
+
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+ const char * const env_override
+ = 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))
+ {
+ return NULL;
+ }
+
+ if (strNE(this_locale, default_name)) {
+ did_override = TRUE;
+ }
+ }
+
+ /* If all the categories are the same, we can set LC_ALL to
+ * that */
+ if (! did_override) {
+ locale = default_name;
+ }
+ else {
+
+ /* Here, LC_ALL is no longer valid, as some individual
+ * categories don't match it. We call ourselves
+ * recursively, as that will execute the code that
+ * generates the proper locale string for this situation.
+ * We don't do the remainder of this function, as that is
+ * to update our records, and we've just done that for the
+ * individual categories in the loop above, and doing so
+ * would cause LC_ALL to be done as well */
+ return emulate_setlocale(LC_ALL, NULL, LC_ALL_INDEX, TRUE);
+ }
+ }
+ }
+ } /* End of this being setlocale(LC_foo, "") */
+ else if (strchr(locale, ';')) {
+
+ /* LC_ALL may actually incude a conglomeration of various categories.
+ * Without querylocale, this code uses the glibc (as of this writing)
+ * syntax for representing that, but that is not a stable API, and
+ * other platforms do it differently, so we have to handle all cases
+ * ourselves */
+
+ unsigned int i;
+ const char * s = locale;
+ const char * e = locale + strlen(locale);
+ const char * p = s;
+ const char * category_end;
+ const char * name_start;
+ const char * name_end;
+
+ /* If the string that gives what to set doesn't include all categories,
+ * the omitted ones get set to "C". To get this behavior, first set
+ * all the individual categories to "C", and override the furnished
+ * ones below */
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+ if (! emulate_setlocale(categories[i], "C", i, TRUE)) {
+ return NULL;
+ }
+ }
+
+ while (s < e) {
+
+ /* Parse through the category */
+ while (isWORDCHAR(*p)) {
+ p++;
+ }
+ category_end = p;
+
+ if (*p++ != '=') {
+ Perl_croak(aTHX_
+ "panic: %s: %d: Unexpected character in locale name '%02X",
+ __FILE__, __LINE__, *(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));
+ }
+ p++;
+ }
+ name_end = p;
+
+ /* Space past the semi-colon */
+ if (p < e) {
+ p++;
+ }
+
+ /* Find the index of the category name in our lists */
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+ char * individ_locale;
+
+ /* Keep going if this isn't the index. The strnNE() avoids a
+ * Perl_form(), but would fail if ever a category name could be
+ * a substring of another one, like if there were a
+ * "LC_TIME_DATE" */
+ if strnNE(s, category_names[i], category_end - s) {
+ continue;
+ }
+
+ /* If this index is for the single category we're changing, we
+ * have found the locale to set it to. */
+ if (category == categories[i]) {
+ locale = Perl_form(aTHX_ "%.*s",
+ (int) (name_end - name_start),
+ name_start);
+ goto ready_to_set;
+ }
+
+ assert(category == LC_ALL);
+ individ_locale = Perl_form(aTHX_ "%.*s",
+ (int) (name_end - name_start), name_start);
+ if (! emulate_setlocale(categories[i], individ_locale, i, TRUE))
+ {
+ return NULL;
+ }
+ }
+
+ s = p;
+ }
+
+ /* Here we have set all the individual categories by recursive calls.
+ * These collectively should have fixed up LC_ALL, so can just query
+ * what that now is */
+ 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: ;
+
+ /* Here at the end of having to deal with the absence of querylocale().
+ * Some cases have already been fully handled by recursive calls to this
+ * function. But at this point, we haven't dealt with those, but are now
+ * prepared to, knowing what the locale name to set this category to is.
+ * This would have come for free if this system had had querylocale() */
+
+# endif /* end of ! querylocale */
+
+ assert(PL_C_locale_obj);
+
+ /* Switching locales generally entails freeing the current one's space (at
+ * the C library's discretion). We need to stop using that locale before
+ * the switch. So switch to a known locale object that we don't otherwise
+ * mess with. This returns the locale object in effect at the time of the
+ * switch. */
+ old_obj = uselocale(PL_C_locale_obj);
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
+ }
+
+# endif
+
+ if (! old_obj) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_L_TEST || debug_initialization) {
+ dSAVE_ERRNO;
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to C failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ RESTORE_ERRNO;
+ }
+
+# endif
+
+ 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__, PL_C_locale_obj);
+ }
+
+# endif
+
+ /* 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_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: will stay in C object\n", __FILE__, __LINE__);
+ }
+
+# endif
+
+ 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: emulate_setlocale creating new object"
+ " failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ }
+
+# 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
+
+ }
+ RESTORE_ERRNO;
+ return NULL;
+ }
+
+# 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");
+ }
+
+# endif
+
+ /* 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: 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;
+ }
+ }
+
+# 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);
+ }
+
+# endif
+
+ /* 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
+ * locale that got switched to is, as it came from the environment. So
+ * have to find it */
+
+# ifdef HAS_QUERYLOCALE
+
+ if (strEQ(locale, "")) {
+ locale = querylocale(mask, new_obj);
+ }
+
+# else
+
+ /* Here, 'locale' is the return value */
+
+ /* Without querylocale(), we have to update our records */
+
+ if (category == LC_ALL) {
+ unsigned int i;
+
+ /* For LC_ALL, we change all individual categories to correspond */
+ /* PL_curlocales is a parallel array, so has same
+ * length as 'categories' */
+ for (i = 0; i <= LC_ALL_INDEX; i++) {
+ Safefree(PL_curlocales[i]);
+ PL_curlocales[i] = savepv(locale);
+ }
+
+ FIX_GLIBC_LC_MESSAGES_BUG(LC_MESSAGES_INDEX);
+ }
+ else {
+
+ /* For a single category, if it's not the same as the one in LC_ALL, we
+ * nullify LC_ALL */
+
+ if (PL_curlocales[LC_ALL_INDEX] && strNE(PL_curlocales[LC_ALL_INDEX], locale)) {
+ Safefree(PL_curlocales[LC_ALL_INDEX]);
+ PL_curlocales[LC_ALL_INDEX] = NULL;
+ }
+
+ /* Then update the category's record */
+ Safefree(PL_curlocales[index]);
+ PL_curlocales[index] = savepv(locale);
+
+ FIX_GLIBC_LC_MESSAGES_BUG(index);
+ }
+
+# endif
+
+ return locale;
+}
+
+#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 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];
+}
-/* Just placeholders for now. "_c" is intended to be called when the category
- * is a constant known at compile time; "_r", not known until run time */
-# define do_setlocale_c(category, locale) my_setlocale(category, locale)
-# define do_setlocale_r(category, locale) my_setlocale(category, locale)
+#endif
+#ifdef USE_LOCALE
STATIC void
S_set_numeric_radix(pTHX_ const bool use_locale)
|| defined(HAS_NL_LANGINFO))
const char * radix = (use_locale)
- ? my_nl_langinfo(PERL_RADIXCHAR, FALSE)
+ ? my_nl_langinfo(RADIXCHAR, FALSE)
/* FALSE => already in dest locale */
: ".";
}
# endif
+#else
+
+ PERL_UNUSED_ARG(use_locale);
+
#endif /* USE_LOCALE_NUMERIC and can find the radix char */
}
-
-void
-Perl_new_numeric(pTHX_ const char *newnum)
+STATIC void
+S_new_numeric(pTHX_ const char *newnum)
{
#ifndef USE_LOCALE_NUMERIC
* variables are true at the same time. (Toggling is a
* no-op under these circumstances.) This variable is
* used to avoid having to recalculate.
- * Any code changing the locale (outside this file) should use
- * POSIX::setlocale, which calls this function. Therefore this function
- * should be called directly only from this file and from
- * POSIX::setlocale() */
+ */
char *save_newnum;
PL_numeric_underlying = TRUE;
PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
+#ifndef TS_W32_BROKEN_LOCALECONV
+
/* If its name isn't C nor POSIX, it could still be indistinguishable from
- * them */
+ * them. But on broken Windows systems calling my_nl_langinfo() for
+ * THOUSEP can currently (but rarely) cause a race, so avoid doing that,
+ * and just always change the locale if not C nor POSIX on those systems */
if (! PL_numeric_standard) {
- PL_numeric_standard = cBOOL(strEQ(".", my_nl_langinfo(PERL_RADIXCHAR,
+ PL_numeric_standard = cBOOL(strEQ(".", my_nl_langinfo(RADIXCHAR,
FALSE /* Don't toggle locale */ ))
- && strEQ("", my_nl_langinfo(PERL_THOUSEP,
- FALSE)));
+ && strEQ("", my_nl_langinfo(THOUSEP, FALSE)));
}
+#endif
+
/* 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);
/* Keep LC_NUMERIC in the C locale. This is for XS modules, so they don't
* have to worry about the radix being a non-dot. (Core operations that
* need the underlying locale change to it temporarily). */
- set_numeric_standard();
+ if (PL_numeric_standard) {
+ set_numeric_radix(0);
+ }
+ else {
+ set_numeric_standard();
+ }
#endif /* USE_LOCALE_NUMERIC */
* to our records (which could be wrong if some XS code has changed the
* locale behind our back) */
- do_setlocale_c(LC_NUMERIC, "C");
- PL_numeric_standard = TRUE;
- PL_numeric_underlying = PL_numeric_underlying_is_standard;
- set_numeric_radix(0);
-
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
- "LC_NUMERIC locale now is standard C\n");
+ "Setting LC_NUMERIC locale to standard C\n");
}
# endif
+
+ do_setlocale_c(LC_NUMERIC, "C");
+ PL_numeric_standard = TRUE;
+ PL_numeric_underlying = PL_numeric_underlying_is_standard;
+ set_numeric_radix(0);
+
#endif /* USE_LOCALE_NUMERIC */
}
* if toggling isn't necessary according to our records (which could be
* wrong if some XS code has changed the locale behind our back) */
- do_setlocale_c(LC_NUMERIC, PL_numeric_name);
- PL_numeric_standard = PL_numeric_underlying_is_standard;
- PL_numeric_underlying = TRUE;
- set_numeric_radix(! PL_numeric_standard);
-
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
- "LC_NUMERIC locale now is %s\n",
+ "Setting LC_NUMERIC locale to %s\n",
PL_numeric_name);
}
# endif
+
+ do_setlocale_c(LC_NUMERIC, PL_numeric_name);
+ PL_numeric_standard = PL_numeric_underlying_is_standard;
+ PL_numeric_underlying = TRUE;
+ set_numeric_radix(! PL_numeric_standard);
+
#endif /* USE_LOCALE_NUMERIC */
}
#ifndef USE_LOCALE_CTYPE
- PERL_ARGS_ASSERT_NEW_CTYPE;
PERL_UNUSED_ARG(newctype);
PERL_UNUSED_CONTEXT;
* that tofold() is tolc() since fold case is not a concept in POSIX,
*
* Any code changing the locale (outside this file) should use
- * POSIX::setlocale, which calls this function. Therefore this function
- * should be called directly only from this file and from
+ * Perl_setlocale or POSIX::setlocale, which call this function. Therefore
+ * this function should be called directly only from this file and from
* POSIX::setlocale() */
- dVAR;
- UV i;
+ unsigned int i;
/* Don't check for problems if we are suppressing the warnings */
bool check_for_problems = ckWARN_d(WARN_LOCALE) || UNLIKELY(DEBUG_L_TEST);
+ bool maybe_utf8_turkic = FALSE;
PERL_ARGS_ASSERT_NEW_CTYPE;
* handle this specially because of the three problematic code points */
if (PL_in_utf8_CTYPE_locale) {
Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
+
+ /* UTF-8 locales can have special handling for 'I' and 'i' if they are
+ * Turkic. Make sure these two are the only anomalies. (We don't use
+ * towupper and towlower because they aren't in C89.) */
+
+#if defined(HAS_TOWUPPER) && defined (HAS_TOWLOWER)
+
+ if (towupper('i') == 0x130 && towlower('I') == 0x131) {
+
+#else
+
+ if (toupper('i') == 'i' && tolower('I') == 'I') {
+
+#endif
+ check_for_problems = TRUE;
+ maybe_utf8_turkic = TRUE;
+ }
}
/* We don't populate the other lists if a UTF-8 locale, but do check that
&& (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
{
bool is_bad = FALSE;
- char name[3] = { '\0' };
+ char name[4] = { '\0' };
/* Convert the name into a string */
- if (isPRINT_A(i)) {
+ if (isGRAPH_A(i)) {
name[0] = i;
name[1] = '\0';
}
else if (i == '\n') {
- my_strlcpy(name, "\n", sizeof(name));
+ my_strlcpy(name, "\\n", sizeof(name));
+ }
+ else if (i == '\t') {
+ my_strlcpy(name, "\\t", sizeof(name));
}
else {
- my_strlcpy(name, "\t", sizeof(name));
+ assert(i == ' ');
+ my_strlcpy(name, "' '", sizeof(name));
}
/* Check each possibe class */
"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",
}
}
+ if (bad_count == 2 && maybe_utf8_turkic) {
+ bad_count = 0;
+ *bad_chars_list = '\0';
+ PL_fold_locale['I'] = 'I';
+ PL_fold_locale['i'] = 'i';
+ PL_in_utf8_turkic_locale = TRUE;
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s is turkic\n",
+ __FILE__, __LINE__, newctype));
+ }
+ else {
+ PL_in_utf8_turkic_locale = FALSE;
+ }
+
# ifdef MB_CUR_MAX
/* We only handle single-byte locales (outside of UTF-8 ones; so if
# endif
- if (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale)) {
+ /* If we found problems and we want them output, do so */
+ if ( (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale))
+ && (LIKELY(ckWARN_d(WARN_LOCALE)) || UNLIKELY(DEBUG_L_TEST)))
+ {
if (UNLIKELY(bad_count) && PL_in_utf8_CTYPE_locale) {
PL_warn_locale = Perl_newSVpvf(aTHX_
"Locale '%s' contains (at least) the following characters"
- " which have\nnon-standard meanings: %s\nThe Perl program"
- " will use the standard meanings",
+ " which have\nunexpected meanings: %s\nThe Perl program"
+ " will use the expected meanings",
newctype, bad_chars_list);
-
}
else {
PL_warn_locale = Perl_newSVpvf(aTHX_
Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
/* parameter FALSE is a don't care here */
- my_nl_langinfo(PERL_CODESET, FALSE));
+ my_nl_langinfo(CODESET, FALSE));
# endif
}
+#endif
+
#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);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
- setlocale_debug_string(category, locale, result)));
+#endif
+ DEBUG_L(STMT_START {
+ dSAVE_ERRNO;
+ PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
+ setlocale_debug_string(category, locale, result));
+ RESTORE_ERRNO;
+ } STMT_END);
if (! override_LC_ALL) {
return result;
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")));
}
result = setlocale(LC_ALL, NULL);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
+ DEBUG_L(STMT_START {
+ dSAVE_ERRNO;
+ PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- setlocale_debug_string(LC_ALL, NULL, result)));
+ setlocale_debug_string(LC_ALL, NULL, result));
+ RESTORE_ERRNO;
+ } STMT_END);
return result;
}
#endif
-char *
-Perl_setlocale(int category, const char * locale)
+/*
+=for apidoc Perl_setlocale
+
+This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
+taking the same parameters, and returning the same information, except that it
+returns the correct underlying C<LC_NUMERIC> locale. Regular C<setlocale> will
+instead return C<C> if the underlying locale has a non-dot decimal point
+character, or a non-empty thousands separator for displaying floating point
+numbers. This is because perl keeps that locale category such that it has a
+dot and empty separator, changing the locale briefly during the operations
+where the underlying one is required. C<Perl_setlocale> knows about this, and
+compensates; regular C<setlocale> doesn't.
+
+Another reason it isn't completely a drop-in replacement is that it is
+declared to return S<C<const char *>>, whereas the system setlocale omits the
+C<const> (presumably because its API was specified long ago, and can't be
+updated; it is illegal to change the information C<setlocale> returns; doing
+so leads to segfaults.)
+
+Finally, C<Perl_setlocale> works under all circumstances, whereas plain
+C<setlocale> can be completely ineffective on some platforms under some
+configurations.
+
+C<Perl_setlocale> should not be used to change the locale except on systems
+where the predefined variable C<${^SAFE_LOCALES}> is 1. On some such systems,
+the system C<setlocale()> is ineffective, returning the wrong information, and
+failing to actually change the locale. C<Perl_setlocale>, however works
+properly in all circumstances.
+
+The return points to a per-thread static buffer, which is overwritten the next
+time C<Perl_setlocale> is called from the same thread.
+
+=cut
+
+*/
+
+const char *
+Perl_setlocale(const int category, const char * locale)
{
/* This wraps POSIX::setlocale() */
- char * retval;
- char * newlocale;
+#ifndef USE_LOCALE
+
+ PERL_UNUSED_ARG(category);
+ PERL_UNUSED_ARG(locale);
+
+ return "C";
+
+#else
+
+ const char * retval;
+ const char * newlocale;
+ dSAVEDERRNO;
dTHX;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
#ifdef USE_LOCALE_NUMERIC
/* A NULL locale means only query what the current one is. We have the
* LC_NUMERIC name saved, because we are normally switched into the C
- * locale for it. For an LC_ALL query, switch back to get the correct
- * results. All other categories don't require special handling */
+ * (or equivalent) locale for it. For an LC_ALL query, switch back to get
+ * the correct results. All other categories don't require special
+ * handling */
if (locale == NULL) {
if (category == LC_NUMERIC) {
- return savepv(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 */
+ return PL_numeric_name;
}
# ifdef LC_ALL
- else if (category == LC_ALL && ! PL_numeric_underlying) {
-
- SET_NUMERIC_UNDERLYING();
+ else if (category == LC_ALL) {
+ STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
}
# endif
#endif
- /* Save retval since subsequent setlocale() calls may overwrite it. */
- retval = savepv(do_setlocale_r(category, locale));
+ retval = save_to_buffer(do_setlocale_r(category, locale),
+ &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
+ SAVE_ERRNO;
+
+#if defined(USE_LOCALE_NUMERIC) && defined(LC_ALL)
+
+ if (locale == NULL && category == LC_ALL) {
+ RESTORE_LC_NUMERIC();
+ }
+
+#endif
DEBUG_L(PerlIO_printf(Perl_debug_log,
"%s:%d: %s\n", __FILE__, __LINE__,
setlocale_debug_string(category, locale, retval)));
- if (! retval) {
- /* Should never happen that a query would return an error, but be
- * sure and reset to C locale */
- if (locale == 0) {
- SET_NUMERIC_STANDARD();
- }
+ RESTORE_ERRNO;
+
+ if (! retval) {
return NULL;
}
- /* If locale == NULL, we are just querying the state, but may have switched
- * to NUMERIC_UNDERLYING. Switch back before returning. */
+ /* If locale == NULL, we are just querying the state */
if (locale == NULL) {
- SET_NUMERIC_STANDARD();
return retval;
}
# ifdef USE_LOCALE_CTYPE
- newlocale = do_setlocale_c(LC_CTYPE, NULL);
+ newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
new_ctype(newlocale);
+ Safefree(newlocale);
# endif /* USE_LOCALE_CTYPE */
# ifdef USE_LOCALE_COLLATE
- newlocale = do_setlocale_c(LC_COLLATE, NULL);
+ newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
new_collate(newlocale);
+ Safefree(newlocale);
# endif
# ifdef USE_LOCALE_NUMERIC
- newlocale = do_setlocale_c(LC_NUMERIC, NULL);
+ newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
new_numeric(newlocale);
+ Safefree(newlocale);
# endif /* USE_LOCALE_NUMERIC */
#endif /* LC_ALL */
return retval;
+#endif
}
/* Copy the NUL-terminated 'string' to 'buf' + 'offset'. 'buf' has size 'buf_size',
* growing it if necessary */
- const Size_t string_size = strlen(string) + offset + 1;
+ Size_t string_size;
PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
+ if (! string) {
+ return NULL;
+ }
+
+ string_size = strlen(string) + offset + 1;
+
if (*buf_size == 0) {
Newx(*buf, string_size, char);
*buf_size = string_size;
/*
-=head1 Locale-related functions and macros
-
=for apidoc Perl_langinfo
-This is an (almost ª) drop-in replacement for the system C<L<nl_langinfo(3)>>,
+This is an (almost) drop-in replacement for the system C<L<nl_langinfo(3)>>,
taking the same C<item> parameter values, and returning the same information.
But it is more thread-safe than regular C<nl_langinfo()>, and hides the quirks
of Perl's locale handling from your code, and can be used on systems that lack
=item *
-It delivers the correct results for the C<RADIXCHAR> and C<THOUSESEP> items,
-without you having to write extra code. The reason for the extra code would be
-because these are from the C<LC_NUMERIC> locale category, which is normally
-kept set to the C locale by Perl, no matter what the underlying locale is
-supposed to be, and so to get the expected results, you have to temporarily
-toggle into the underlying locale, and later toggle back. (You could use
-plain C<nl_langinfo> and C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this
-but then you wouldn't get the other advantages of C<Perl_langinfo()>; not
-keeping C<LC_NUMERIC> in the C locale would break a lot of CPAN, which is
-expecting the radix (decimal point) character to be a dot.)
+The reason it isn't quite a drop-in replacement is actually an advantage. The
+only difference is that it returns S<C<const char *>>, whereas plain
+C<nl_langinfo()> returns S<C<char *>>, but you are (only by documentation)
+forbidden to write into the buffer. By declaring this C<const>, the compiler
+enforces this restriction, so if it is violated, you know at compilation time,
+rather than getting segfaults at runtime.
=item *
-Depending on C<item>, it works on systems that don't have C<nl_langinfo>, hence
-makes your code more portable. Of the fifty-some possible items specified by
-the POSIX 2008 standard,
-L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
-only two are completely unimplemented. It uses various techniques to recover
-the other items, including calling C<L<localeconv(3)>>, and C<L<strftime(3)>>,
-both of which are specified in C89, so should be always be available. Later
-C<strftime()> versions have additional capabilities; C<""> is returned for
-those not available on your system.
-
-It is important to note that on such systems, this calls C<localeconv>, and so
-overwrites the static buffer returned from previous explicit calls to that
-function. Thus, if the program doesn't use or save the information from an
-explicit C<localeconv> call (which good practice suggests should be done
-anyway), use of this function can break it.
-
-The details for those items which may differ from what this emulation returns
-and what a native C<nl_langinfo()> would return are:
-
-=over
-
-=item C<CODESET>
-
-=item C<ERA>
-
-Unimplemented, so returns C<"">.
-
-=item C<YESEXPR>
-
-=item C<YESSTR>
-
-=item C<NOEXPR>
-
-=item C<NOSTR>
-
-Only the values for English are returned. C<YESSTR> and C<NOSTR> have been
-removed from POSIX 2008, and are retained for backwards compatibility. Your
-platform's C<nl_langinfo> may not support them.
-
-=item C<D_FMT>
-
-Always evaluates to C<%x>, the locale's appropriate date representation.
-
-=item C<T_FMT>
-
-Always evaluates to C<%X>, the locale's appropriate time representation.
-
-=item C<D_T_FMT>
-
-Always evaluates to C<%c>, the locale's appropriate date and time
-representation.
-
-=item C<CRNCYSTR>
-
-The return may be incorrect for those rare locales where the currency symbol
-replaces the radix character.
-Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
-to work differently.
-
-=item C<ALT_DIGITS>
+It delivers the correct results for the C<RADIXCHAR> and C<THOUSEP> items,
+without you having to write extra code. The reason for the extra code would be
+because these are from the C<LC_NUMERIC> locale category, which is normally
+kept set by Perl so that the radix is a dot, and the separator is the empty
+string, no matter what the underlying locale is supposed to be, and so to get
+the expected results, you have to temporarily toggle into the underlying
+locale, and later toggle back. (You could use plain C<nl_langinfo> and
+C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this but then you wouldn't get
+the other advantages of C<Perl_langinfo()>; not keeping C<LC_NUMERIC> in the C
+(or equivalent) locale would break a lot of CPAN, which is expecting the radix
+(decimal point) character to be a dot.)
-Currently this gives the same results as Linux does.
-Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
-to work differently.
+=item *
-=item C<ERA_D_FMT>
+The system function it replaces can have its static return buffer trashed,
+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.
-=item C<ERA_T_FMT>
+=item *
-=item C<ERA_D_T_FMT>
+Its return buffer is per-thread, so it also is never overwritten by a call to
+this function from another thread; unlike the function it replaces.
-=item C<T_FMT_AMPM>
+=item *
-These are derived by using C<strftime()>, and not all versions of that function
-know about them. C<""> is returned for these on such systems.
+But most importantly, it works on systems that don't have C<nl_langinfo>, such
+as Windows, hence makes your code more portable. Of the fifty-some possible
+items specified by the POSIX 2008 standard,
+L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
+only one is completely unimplemented, though on non-Windows platforms, another
+significant one is also not implemented). It uses various techniques to
+recover the other items, including calling C<L<localeconv(3)>>, and
+C<L<strftime(3)>>, both of which are specified in C89, so should be always be
+available. Later C<strftime()> versions have additional capabilities; C<""> is
+returned for those not available on your system.
+
+It is important to note that when called with an item that is recovered by
+using C<localeconv>, the buffer from any previous explicit call to
+C<localeconv> will be overwritten. This means you must save that buffer's
+contents if you need to access them after a call to this function. (But note
+that you might not want to be using C<localeconv()> directly anyway, because of
+issues like the ones listed in the second item of this list (above) for
+C<RADIXCHAR> and C<THOUSEP>. You can use the methods given in L<perlcall> to
+call L<POSIX/localeconv> and avoid all the issues, but then you have a hash to
+unpack).
+
+The details for those items which may deviate from what this emulation returns
+and what a native C<nl_langinfo()> would return are specified in
+L<I18N::Langinfo>.
=back
before the C<perl.h> C<#include>. You can replace your C<langinfo.h>
C<#include> with this one. (Doing it this way keeps out the symbols that plain
-C<langinfo.h> imports into the namespace for code that doesn't need it.)
-
-You also should not use the bare C<langinfo.h> item names, but should preface
-them with C<PERL_>, so use C<PERL_RADIXCHAR> instead of plain C<RADIXCHAR>.
-The C<PERL_I<foo>> versions will also work for this function on systems that do
-have a native C<nl_langinfo>.
-
-=item *
-
-It is thread-friendly, returning its result in a buffer that won't be
-overwritten by another thread, so you don't have to code for that possibility.
-The buffer can be overwritten by the next call to C<nl_langinfo> or
-C<Perl_langinfo> in the same thread.
-
-=item *
-
-ª It returns S<C<const char *>>, whereas plain C<nl_langinfo()> returns S<C<char
-*>>, but you are (only by documentation) forbidden to write into the buffer.
-By declaring this C<const>, the compiler enforces this restriction. The extra
-C<const> is why this isn't an unequivocal drop-in replacement for
-C<nl_langinfo>.
-
-=back
+C<langinfo.h> would try to import into the namespace for code that doesn't need
+it.)
The original impetus for C<Perl_langinfo()> was so that code that needs to
find out the current currency symbol, floating point radix character, or digit
return my_nl_langinfo(item, TRUE);
}
-const char *
+STATIC const char *
#ifdef HAS_NL_LANGINFO
S_my_nl_langinfo(const nl_item item, bool toggle)
#else
#endif
{
dTHX;
+ const char * retval;
+
+#ifdef USE_LOCALE_NUMERIC
/* We only need to toggle into the underlying LC_NUMERIC locale for these
* two items, and only if not already there */
- if (toggle && (( item != PERL_RADIXCHAR && item != PERL_THOUSEP)
+ if (toggle && (( item != RADIXCHAR && item != THOUSEP)
|| PL_numeric_underlying))
- {
+
+#endif /* No toggling needed if not using LC_NUMERIC */
+
toggle = FALSE;
- }
#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
-#if ! defined(HAS_POSIX_2008_LOCALE)
+# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
+ || ! 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
this code section (the only call to nl_langinfo in
the core) */
- save_to_buffer(nl_langinfo(item), &PL_langinfo_buf,
- &PL_langinfo_bufsize, 0);
+
+ /* 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;
do_free = TRUE;
}
+# ifdef USE_LOCALE_NUMERIC
+
if (toggle) {
if (PL_underlying_numeric_obj) {
cur = PL_underlying_numeric_obj;
}
}
- save_to_buffer(nl_langinfo_l(item, cur),
- &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
+# endif
+
+ /* We have to save it to a buffer, because the freelocale() just below
+ * can invalidate the internal one */
+ retval = save_to_buffer(nl_langinfo_l(item, cur),
+ &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
+
if (do_free) {
freelocale(cur);
}
# endif
- if (strEQ(PL_langinfo_buf, "")) {
- if (item == PERL_YESSTR) {
+ if (strEQ(retval, "")) {
+ if (item == YESSTR) {
return "yes";
}
- if (item == PERL_NOSTR) {
+ if (item == NOSTR) {
return "no";
}
}
- return PL_langinfo_buf;
+ return retval;
#else /* Below, emulate nl_langinfo as best we can */
# ifdef HAS_LOCALECONV
const struct lconv* lc;
+ const char * temp;
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+# ifdef TS_W32_BROKEN_LOCALECONV
+
+ const char * save_global;
+ const char * save_thread;
+ int needed_size;
+ char * ptr;
+ char * e;
+ char * item_start;
+
+# endif
# endif
# ifdef HAS_STRFTIME
switch (item) {
Size_t len;
- const char * retval;
- /* These 2 are unimplemented */
- case PERL_CODESET:
- case PERL_ERA: /* For use with strftime() %E modifier */
+ /* This is unimplemented */
+ case ERA: /* For use with strftime() %E modifier */
default:
return "";
/* We use only an English set, since we don't know any more */
- case PERL_YESEXPR: return "^[+1yY]";
- case PERL_YESSTR: return "yes";
- case PERL_NOEXPR: return "^[-0nN]";
- case PERL_NOSTR: return "no";
+ case YESEXPR: return "^[+1yY]";
+ case YESSTR: return "yes";
+ case NOEXPR: return "^[-0nN]";
+ case NOSTR: return "no";
+
+ case CODESET:
+
+# ifndef WIN32
+
+ /* On non-windows, this is unimplemented, in part because of
+ * inconsistencies between vendors. The Darwin native
+ * nl_langinfo() implementation simply looks at everything past
+ * any dot in the name, but that doesn't work for other
+ * vendors. Many Linux locales that don't have UTF-8 in their
+ * names really are UTF-8, for example; z/OS locales that do
+ * have UTF-8 in their names, aren't really UTF-8 */
+ return "";
+# else
+
+ { /* But on Windows, the name does seem to be consistent, so
+ use that. */
+ const char * p;
+ const char * first;
+ Size_t offset = 0;
+ const char * name = my_setlocale(LC_CTYPE, NULL);
+
+ if (isNAME_C_OR_POSIX(name)) {
+ return "ANSI_X3.4-1968";
+ }
+
+ /* Find the dot in the locale name */
+ first = (const char *) strchr(name, '.');
+ if (! first) {
+ first = name;
+ goto has_nondigit;
+ }
+
+ /* Look at everything past the dot */
+ first++;
+ p = first;
+
+ while (*p) {
+ if (! isDIGIT(*p)) {
+ goto has_nondigit;
+ }
+
+ p++;
+ }
+
+ /* Here everything past the dot is a digit. Treat it as a
+ * code page */
+ retval = save_to_buffer("CP", &PL_langinfo_buf,
+ &PL_langinfo_bufsize, 0);
+ offset = STRLENs("CP");
+
+ has_nondigit:
+
+ retval = save_to_buffer(first, &PL_langinfo_buf,
+ &PL_langinfo_bufsize, offset);
+ }
+
+ break;
+
+# endif
# ifdef HAS_LOCALECONV
- case PERL_CRNCYSTR:
+ case CRNCYSTR:
/* We don't bother with localeconv_l() because any system that
* has it is likely to also have nl_langinfo() */
- LOCALE_LOCK; /* Prevent interference with other threads
- using localeconv() */
+ LOCALECONV_LOCK; /* Prevent interference with other threads
+ using localeconv() */
+
+# ifdef TS_W32_BROKEN_LOCALECONV
+
+ /* This is a workaround for a Windows bug prior to VS 15.
+ * What we do here is, while locked, switch to the global
+ * locale so localeconv() works; then switch back just before
+ * the unlock. This can screw things up if some thread is
+ * already using the global locale while assuming no other is.
+ * A different workaround would be to call GetCurrencyFormat on
+ * a known value, and parse it; patches welcome
+ *
+ * We have to use LC_ALL instead of LC_MONETARY because of
+ * another bug in Windows */
+
+ save_thread = savepv(my_setlocale(LC_ALL, NULL));
+ _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+ save_global= savepv(my_setlocale(LC_ALL, NULL));
+ my_setlocale(LC_ALL, save_thread);
+
+# endif
lc = localeconv();
if ( ! lc
|| ! lc->currency_symbol
|| strEQ("", lc->currency_symbol))
{
- LOCALE_UNLOCK;
+ LOCALECONV_UNLOCK;
return "";
}
/* Leave the first spot empty to be filled in below */
- save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
- &PL_langinfo_bufsize, 1);
+ retval = save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
+ &PL_langinfo_bufsize, 1);
if (lc->mon_decimal_point && strEQ(lc->mon_decimal_point, ""))
{ /* khw couldn't figure out how the localedef specifications
would show that the $ should replace the radix; this is
just a guess as to how it might work.*/
- *PL_langinfo_buf = '.';
+ PL_langinfo_buf[0] = '.';
}
else if (lc->p_cs_precedes) {
- *PL_langinfo_buf = '-';
+ PL_langinfo_buf[0] = '-';
}
else {
- *PL_langinfo_buf = '+';
+ PL_langinfo_buf[0] = '+';
}
- LOCALE_UNLOCK;
+# ifdef TS_W32_BROKEN_LOCALECONV
+
+ my_setlocale(LC_ALL, save_global);
+ _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+ my_setlocale(LC_ALL, save_thread);
+ Safefree(save_global);
+ Safefree(save_thread);
+
+# endif
+
+ LOCALECONV_UNLOCK;
+ break;
+
+# ifdef TS_W32_BROKEN_LOCALECONV
+
+ case RADIXCHAR:
+
+ /* For this, we output a known simple floating point number to
+ * a buffer, and parse it, looking for the radix */
+
+ if (toggle) {
+ STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
+ }
+
+ if (PL_langinfo_bufsize < 10) {
+ PL_langinfo_bufsize = 10;
+ Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
+ }
+
+ needed_size = my_snprintf(PL_langinfo_buf, PL_langinfo_bufsize,
+ "%.1f", 1.5);
+ if (needed_size >= (int) PL_langinfo_bufsize) {
+ PL_langinfo_bufsize = needed_size + 1;
+ Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
+ needed_size = my_snprintf(PL_langinfo_buf, PL_langinfo_bufsize,
+ "%.1f", 1.5);
+ assert(needed_size < (int) PL_langinfo_bufsize);
+ }
+
+ ptr = PL_langinfo_buf;
+ e = PL_langinfo_buf + PL_langinfo_bufsize;
+
+ /* Find the '1' */
+ while (ptr < e && *ptr != '1') {
+ ptr++;
+ }
+ ptr++;
+
+ /* Find the '5' */
+ item_start = ptr;
+ while (ptr < e && *ptr != '5') {
+ ptr++;
+ }
+
+ /* Everything in between is the radix string */
+ if (ptr >= e) {
+ PL_langinfo_buf[0] = '?';
+ PL_langinfo_buf[1] = '\0';
+ }
+ else {
+ *ptr = '\0';
+ Move(item_start, PL_langinfo_buf, ptr - PL_langinfo_buf, char);
+ }
+
+ if (toggle) {
+ RESTORE_LC_NUMERIC();
+ }
+
+ retval = PL_langinfo_buf;
break;
- case PERL_RADIXCHAR:
- case PERL_THOUSEP:
+# else
+
+ case RADIXCHAR: /* No special handling needed */
+
+# endif
+
+ case THOUSEP:
if (toggle) {
STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
}
- LOCALE_LOCK; /* Prevent interference with other threads
- using localeconv() */
+ LOCALECONV_LOCK; /* Prevent interference with other threads
+ using localeconv() */
+
+# ifdef TS_W32_BROKEN_LOCALECONV
+
+ /* This should only be for the thousands separator. A
+ * different work around would be to use GetNumberFormat on a
+ * known value and parse the result to find the separator */
+ save_thread = savepv(my_setlocale(LC_ALL, NULL));
+ _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+ save_global = savepv(my_setlocale(LC_ALL, NULL));
+ my_setlocale(LC_ALL, save_thread);
+# if 0
+ /* This is the start of code that for broken Windows replaces
+ * the above and below code, and instead calls
+ * GetNumberFormat() and then would parse that to find the
+ * thousands separator. It needs to handle UTF-16 vs -8
+ * issues. */
+
+ needed_size = GetNumberFormatEx(PL_numeric_name, 0, "1234.5", NULL, PL_langinfo_buf, PL_langinfo_bufsize);
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "%s: %d: return from GetNumber, count=%d, val=%s\n",
+ __FILE__, __LINE__, needed_size, PL_langinfo_buf));
+
+# endif
+# endif
lc = localeconv();
if (! lc) {
- retval = "";
+ temp = "";
}
else {
- retval = (item == PERL_RADIXCHAR)
+ temp = (item == RADIXCHAR)
? lc->decimal_point
: lc->thousands_sep;
- if (! retval) {
- retval = "";
+ if (! temp) {
+ temp = "";
}
}
- save_to_buffer(retval, &PL_langinfo_buf,
- &PL_langinfo_bufsize, 0);
+ retval = save_to_buffer(temp, &PL_langinfo_buf,
+ &PL_langinfo_bufsize, 0);
+
+# ifdef TS_W32_BROKEN_LOCALECONV
- LOCALE_UNLOCK;
+ my_setlocale(LC_ALL, save_global);
+ _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+ my_setlocale(LC_ALL, save_thread);
+ Safefree(save_global);
+ Safefree(save_thread);
+
+# endif
+
+ LOCALECONV_UNLOCK;
if (toggle) {
RESTORE_LC_NUMERIC();
* for someone using them as formats (as opposed to trying to parse
* them to figure out what the locale says). The other format
* items are actually tested to verify they work on the platform */
- case PERL_D_FMT: return "%x";
- case PERL_T_FMT: return "%X";
- case PERL_D_T_FMT: return "%c";
+ case D_FMT: return "%x";
+ case T_FMT: return "%X";
+ case D_T_FMT: return "%c";
/* These formats are only available in later strfmtime's */
- case PERL_ERA_D_FMT: case PERL_ERA_T_FMT: case PERL_ERA_D_T_FMT:
- case PERL_T_FMT_AMPM:
+ case ERA_D_FMT: case ERA_T_FMT: case ERA_D_T_FMT: case T_FMT_AMPM:
/* The rest can be gotten from most versions of strftime(). */
- case PERL_ABDAY_1: case PERL_ABDAY_2: case PERL_ABDAY_3:
- case PERL_ABDAY_4: case PERL_ABDAY_5: case PERL_ABDAY_6:
- case PERL_ABDAY_7:
- case PERL_ALT_DIGITS:
- case PERL_AM_STR: case PERL_PM_STR:
- case PERL_ABMON_1: case PERL_ABMON_2: case PERL_ABMON_3:
- case PERL_ABMON_4: case PERL_ABMON_5: case PERL_ABMON_6:
- case PERL_ABMON_7: case PERL_ABMON_8: case PERL_ABMON_9:
- case PERL_ABMON_10: case PERL_ABMON_11: case PERL_ABMON_12:
- case PERL_DAY_1: case PERL_DAY_2: case PERL_DAY_3: case PERL_DAY_4:
- case PERL_DAY_5: case PERL_DAY_6: case PERL_DAY_7:
- case PERL_MON_1: case PERL_MON_2: case PERL_MON_3: case PERL_MON_4:
- case PERL_MON_5: case PERL_MON_6: case PERL_MON_7: case PERL_MON_8:
- case PERL_MON_9: case PERL_MON_10: case PERL_MON_11:
- case PERL_MON_12:
+ case ABDAY_1: case ABDAY_2: case ABDAY_3:
+ case ABDAY_4: case ABDAY_5: case ABDAY_6: case ABDAY_7:
+ case ALT_DIGITS:
+ case AM_STR: case PM_STR:
+ case ABMON_1: case ABMON_2: case ABMON_3: case ABMON_4:
+ case ABMON_5: case ABMON_6: case ABMON_7: case ABMON_8:
+ case ABMON_9: case ABMON_10: case ABMON_11: case ABMON_12:
+ case DAY_1: case DAY_2: case DAY_3: case DAY_4:
+ case DAY_5: case DAY_6: case DAY_7:
+ case MON_1: case MON_2: case MON_3: case MON_4:
+ 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;
__FILE__, __LINE__, item);
NOT_REACHED; /* NOTREACHED */
- case PERL_PM_STR: tm.tm_hour = 18;
- case PERL_AM_STR:
+ case PM_STR: tm.tm_hour = 18;
+ case AM_STR:
format = "%p";
break;
- case PERL_ABDAY_7: tm.tm_wday++;
- case PERL_ABDAY_6: tm.tm_wday++;
- case PERL_ABDAY_5: tm.tm_wday++;
- case PERL_ABDAY_4: tm.tm_wday++;
- case PERL_ABDAY_3: tm.tm_wday++;
- case PERL_ABDAY_2: tm.tm_wday++;
- case PERL_ABDAY_1:
+ case ABDAY_7: tm.tm_wday++;
+ case ABDAY_6: tm.tm_wday++;
+ case ABDAY_5: tm.tm_wday++;
+ case ABDAY_4: tm.tm_wday++;
+ case ABDAY_3: tm.tm_wday++;
+ case ABDAY_2: tm.tm_wday++;
+ case ABDAY_1:
format = "%a";
break;
- case PERL_DAY_7: tm.tm_wday++;
- case PERL_DAY_6: tm.tm_wday++;
- case PERL_DAY_5: tm.tm_wday++;
- case PERL_DAY_4: tm.tm_wday++;
- case PERL_DAY_3: tm.tm_wday++;
- case PERL_DAY_2: tm.tm_wday++;
- case PERL_DAY_1:
+ case DAY_7: tm.tm_wday++;
+ case DAY_6: tm.tm_wday++;
+ case DAY_5: tm.tm_wday++;
+ case DAY_4: tm.tm_wday++;
+ case DAY_3: tm.tm_wday++;
+ case DAY_2: tm.tm_wday++;
+ case DAY_1:
format = "%A";
break;
- case PERL_ABMON_12: tm.tm_mon++;
- case PERL_ABMON_11: tm.tm_mon++;
- case PERL_ABMON_10: tm.tm_mon++;
- case PERL_ABMON_9: tm.tm_mon++;
- case PERL_ABMON_8: tm.tm_mon++;
- case PERL_ABMON_7: tm.tm_mon++;
- case PERL_ABMON_6: tm.tm_mon++;
- case PERL_ABMON_5: tm.tm_mon++;
- case PERL_ABMON_4: tm.tm_mon++;
- case PERL_ABMON_3: tm.tm_mon++;
- case PERL_ABMON_2: tm.tm_mon++;
- case PERL_ABMON_1:
+ case ABMON_12: tm.tm_mon++;
+ case ABMON_11: tm.tm_mon++;
+ case ABMON_10: tm.tm_mon++;
+ case ABMON_9: tm.tm_mon++;
+ case ABMON_8: tm.tm_mon++;
+ case ABMON_7: tm.tm_mon++;
+ case ABMON_6: tm.tm_mon++;
+ case ABMON_5: tm.tm_mon++;
+ case ABMON_4: tm.tm_mon++;
+ case ABMON_3: tm.tm_mon++;
+ case ABMON_2: tm.tm_mon++;
+ case ABMON_1:
format = "%b";
break;
- case PERL_MON_12: tm.tm_mon++;
- case PERL_MON_11: tm.tm_mon++;
- case PERL_MON_10: tm.tm_mon++;
- case PERL_MON_9: tm.tm_mon++;
- case PERL_MON_8: tm.tm_mon++;
- case PERL_MON_7: tm.tm_mon++;
- case PERL_MON_6: tm.tm_mon++;
- case PERL_MON_5: tm.tm_mon++;
- case PERL_MON_4: tm.tm_mon++;
- case PERL_MON_3: tm.tm_mon++;
- case PERL_MON_2: tm.tm_mon++;
- case PERL_MON_1:
+ case MON_12: tm.tm_mon++;
+ case MON_11: tm.tm_mon++;
+ case MON_10: tm.tm_mon++;
+ case MON_9: tm.tm_mon++;
+ case MON_8: tm.tm_mon++;
+ case MON_7: tm.tm_mon++;
+ case MON_6: tm.tm_mon++;
+ case MON_5: tm.tm_mon++;
+ case MON_4: tm.tm_mon++;
+ case MON_3: tm.tm_mon++;
+ case MON_2: tm.tm_mon++;
+ case MON_1:
format = "%B";
break;
- case PERL_T_FMT_AMPM:
+ case T_FMT_AMPM:
format = "%r";
return_format = TRUE;
break;
- case PERL_ERA_D_FMT:
+ case ERA_D_FMT:
format = "%Ex";
return_format = TRUE;
break;
- case PERL_ERA_T_FMT:
+ case ERA_T_FMT:
format = "%EX";
return_format = TRUE;
break;
- case PERL_ERA_D_T_FMT:
+ case ERA_D_T_FMT:
format = "%Ec";
return_format = TRUE;
break;
- case PERL_ALT_DIGITS:
+ case ALT_DIGITS:
tm.tm_wday = 0;
format = "%Ow"; /* Find the alternate digit for 0 */
break;
* alternate format for wday 0. If the value is the same as
* the normal 0, there isn't an alternate, so clear the buffer.
* */
- if ( item == PERL_ALT_DIGITS
+ if ( item == ALT_DIGITS
&& strEQ(PL_langinfo_buf, "0"))
{
*PL_langinfo_buf = '\0';
LOCALE_UNLOCK;
+ retval = PL_langinfo_buf;
+
/* If to return the format, not the value, overwrite the buffer
* with it. But some strftime()s will keep the original format
* if illegal, so change those to "" */
*PL_langinfo_buf = '\0';
}
else {
- save_to_buffer(format, &PL_langinfo_buf,
- &PL_langinfo_bufsize, 0);
+ retval = save_to_buffer(format, &PL_langinfo_buf,
+ &PL_langinfo_bufsize, 0);
}
}
}
}
- return PL_langinfo_buf;
+ return retval;
#endif
* values for our db, instead of trying to change them.
* */
+
int ok = 1;
#ifndef USE_LOCALE
#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;
# ifdef USE_LOCALE_NUMERIC
assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_NUMERIC_INDEX] == LC_NUMERIC_MASK);
+# endif
# endif
# ifdef USE_LOCALE_CTYPE
assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_CTYPE_INDEX] == LC_CTYPE_MASK);
+# endif
# endif
# ifdef USE_LOCALE_COLLATE
assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_COLLATE_INDEX] == LC_COLLATE_MASK);
+# endif
# endif
# ifdef USE_LOCALE_TIME
assert(categories[LC_TIME_INDEX] == LC_TIME);
assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_TIME_INDEX] == LC_TIME_MASK);
+# endif
# endif
# ifdef USE_LOCALE_MESSAGES
assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_MESSAGES_INDEX] == LC_MESSAGES_MASK);
+# endif
# endif
# ifdef USE_LOCALE_MONETARY
assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_MONETARY_INDEX] == LC_MONETARY_MASK);
+# endif
# endif
# ifdef USE_LOCALE_ADDRESS
assert(categories[LC_ADDRESS_INDEX] == LC_ADDRESS);
assert(strEQ(category_names[LC_ADDRESS_INDEX], "LC_ADDRESS"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_ADDRESS_INDEX] == LC_ADDRESS_MASK);
+# endif
# endif
# ifdef USE_LOCALE_IDENTIFICATION
assert(categories[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION);
assert(strEQ(category_names[LC_IDENTIFICATION_INDEX], "LC_IDENTIFICATION"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION_MASK);
+# endif
# endif
# ifdef USE_LOCALE_MEASUREMENT
assert(categories[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT);
assert(strEQ(category_names[LC_MEASUREMENT_INDEX], "LC_MEASUREMENT"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT_MASK);
+# endif
# endif
# ifdef USE_LOCALE_PAPER
assert(categories[LC_PAPER_INDEX] == LC_PAPER);
assert(strEQ(category_names[LC_PAPER_INDEX], "LC_PAPER"));
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_PAPER_INDEX] == LC_PAPER_MASK);
+# endif
# endif
# ifdef USE_LOCALE_TELEPHONE
assert(categories[LC_TELEPHONE_INDEX] == LC_TELEPHONE);
assert(strEQ(category_names[LC_TELEPHONE_INDEX], "LC_TELEPHONE"));
+# ifdef USE_POSIX_2008_LOCALE
+ 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"));
assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
+# ifdef USE_POSIX_2008_LOCALE
+ assert(category_masks[LC_ALL_INDEX] == LC_ALL_MASK);
+# endif
# 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));
+# ifdef USE_THREAD_SAFE_LOCALE
+# ifdef WIN32
+
+ _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+
+# endif
+# endif
+# ifdef USE_POSIX_2008_LOCALE
+
+ 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);
+ }
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: created C object %p\n", __FILE__, __LINE__, PL_C_locale_obj);
+ }
+
+# endif
+
+# ifdef USE_LOCALE_NUMERIC
+
PL_numeric_radix_sv = newSVpvs(".");
+# endif
+
+# if defined(USE_POSIX_2008_LOCALE) && ! defined(HAS_QUERYLOCALE)
+
+ /* Initialize our records. If we have POSIX 2008, we have LC_ALL */
+ do_setlocale_c(LC_ALL, my_setlocale(LC_ALL, NULL));
+
+# endif
# ifdef LOCALE_ENVIRON_REQUIRED
/*
for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
-# if defined(USE_ITHREADS)
+# if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
/* This caches whether each category's locale is UTF-8 or not. This
* may involve changing the locale. It is ok to do this at
- * initialization time before any threads have started, but not later.
+ * initialization time before any threads have started, but not later
+ * unless thread-safe operations are used.
* Caching means that if the program heeds our dictate not to change
* locales in threaded applications, this data will remain valid, and
* it may get queried without having to change locales. If the
}
# 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;
}
PerlIO_printf(Perl_debug_log, "'\n");
}
+# endif /* DEBUGGING */
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE
+# ifdef DEBUGGING
+
STATIC void
S_print_bytes_for_locale(pTHX_
const char * const s,
}
# endif /* #ifdef DEBUGGING */
-#endif /* USE_LOCALE_COLLATE */
-
-#ifdef USE_LOCALE
STATIC const char *
S_switch_category_locale_to_template(pTHX_ const int switch_category, const int template_category, const char * template_locale)
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;
}
Safefree(original_locale);
}
+/* is_cur_LC_category_utf8 uses a small char buffer to avoid malloc/free */
+#define CUR_LC_BUFFER_SIZE 64
+
bool
Perl__is_cur_LC_category_utf8(pTHX_ int category)
{
the name in the cache */
char * delimited; /* The name plus the delimiters used to store
it in the cache */
+ char buffer[CUR_LC_BUFFER_SIZE]; /* small buffer */
char * name_pos; /* position of 'delimited' in the cache, or 0
if not there */
* utf8ness digit */
input_name_len_with_overhead = input_name_len + 3;
- /* Allocate and populate space for a copy of the name surrounded by the
- * delimiters */
- Newx(delimited, input_name_len_with_overhead, char);
+ if ( input_name_len_with_overhead <= CUR_LC_BUFFER_SIZE ) {
+ /* we can use the buffer, avoid a malloc */
+ delimited = buffer;
+ } else { /* need a malloc */
+ /* Allocate and populate space for a copy of the name surrounded by the
+ * delimiters */
+ Newx(delimited, input_name_len_with_overhead, char);
+ }
+
delimited[0] = UTF8NESS_SEP[0];
Copy(save_input_locale, delimited + 1, input_name_len, char);
delimited[input_name_len+1] = UTF8NESS_PREFIX[0];
utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
}
- Safefree(delimited);
+ /* free only when not using the buffer */
+ if ( delimited != buffer ) Safefree(delimited);
Safefree(save_input_locale);
return is_utf8;
}
* calculate it */
# if defined(USE_LOCALE_CTYPE) \
- && ( (defined(HAS_NL_LANGINFO) && defined(CODESET)) \
+ && ( defined(HAS_NL_LANGINFO) \
|| (defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)))
{
}
# endif
-# if defined(HAS_NL_LANGINFO) && defined(CODESET)
+# if defined(HAS_NL_LANGINFO)
{ /* The task is easiest if the platform has this POSIX 2001 function.
Except on some platforms it can wrongly return "", so have to have
defective locale definition. XXX We should probably check for
these in the Latin1 range and warn (but on glibc, requires
iswalnum() etc. due to their not handling 80-FF correctly */
- const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE);
+ const char *codeset = my_nl_langinfo(CODESET, FALSE);
/* FALSE => already in dest locale */
- DEBUG_L(PerlIO_printf(Perl_debug_log,
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"\tnllanginfo returned CODESET '%s'\n", codeset));
if (codeset && strNE(codeset, "")) {
{
wchar_t wc;
int len;
+ dSAVEDERRNO;
# if defined(HAS_MBRTOWC) && defined(USE_ITHREADS)
memset(&ps, 0, sizeof(ps));;
PERL_UNUSED_RESULT(mbrtowc(&wc, NULL, 0, &ps)); /* Reset any shift
state */
- errno = 0;
+ SETERRNO(0, 0);
len = mbrtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8), &ps);
+ SAVE_ERRNO;
# else
+ LOCALE_LOCK;
PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
- errno = 0;
+ SETERRNO(0, 0);
len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
+ SAVE_ERRNO;
+ LOCALE_UNLOCK;
# endif
- DEBUG_L(PerlIO_printf(Perl_debug_log,
+ RESTORE_ERRNO;
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"\treturn from mbtowc; len=%d; code_point=%x; errno=%d\n",
- len, (unsigned int) wc, errno));
+ len, (unsigned int) wc, GET_ERRNO));
is_utf8 = cBOOL( len == STRLENs(REPLACEMENT_CHARACTER_UTF8)
&& wc == (wchar_t) UNICODE_REPLACEMENT);
}
+# endif
+
restore_switched_locale(LC_CTYPE, original_ctype_locale);
goto finish_and_return;
}
-# endif
# else
/* Here, we must have a C89 compiler that doesn't have mbtowc(). Next
save_input_locale);
bool only_ascii = FALSE;
const U8 * currency_string
- = (const U8 *) my_nl_langinfo(PERL_CRNCYSTR, FALSE);
+ = (const U8 *) my_nl_langinfo(CRNCYSTR, FALSE);
/* 2nd param not relevant for this item */
const U8 * first_variant;
/* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
* otherwise assume the locale is UTF-8 if and only if the symbol
* is non-ascii UTF-8. */
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
save_input_locale, is_utf8));
goto finish_and_return;
}
* locale if we changed it */
restore_switched_locale(LC_TIME, original_time_locale);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
save_input_locale,
is_utf8_string((U8 *) formatted_time, 0)));
is_utf8 = is_utf8_string((U8 *) formatted_time, 0);
* ASCII. Go on to the next test. If we changed it, restore LC_TIME
* to its original locale */
restore_switched_locale(LC_TIME, original_time_locale);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "All time-related words for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "All time-related words for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
}
# endif
/* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
* any non-ascii means it is one; otherwise we assume it isn't */
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
save_input_locale,
is_utf8));
goto finish_and_return;
is_utf8 = TRUE;
goto finish_and_return;
}
- }
# endif
+ }
# endif
/* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
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",
"panic: %s: %d: Corrupt utf8ness_cache: missing"
" separator %.*s<-- HERE %s\n",
__FILE__, __LINE__,
- s - PL_locale_utf8ness, PL_locale_utf8ness,
+ (int) (s - PL_locale_utf8ness), PL_locale_utf8ness,
s);
}
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",
__FILE__, __LINE__,
- e - PL_locale_utf8ness, PL_locale_utf8ness,
+ (int) (e - PL_locale_utf8ness), PL_locale_utf8ness,
e);
}
e++;
"panic: %s: %d: Corrupt utf8ness_cache: utf8ness"
" must be [01] %.*s<-- HERE %s\n",
__FILE__, __LINE__,
- e + 1 - PL_locale_utf8ness, PL_locale_utf8ness,
- e + 1);
+ (int) (e + 1 - PL_locale_utf8ness),
+ PL_locale_utf8ness, e + 1);
}
if (ninstr(PL_locale_utf8ness, s, s-1, e)) {
Perl_croak(aTHX_
"panic: %s: %d: Corrupt utf8ness_cache: entry"
" has duplicate %.*s<-- HERE %s\n",
__FILE__, __LINE__,
- e - PL_locale_utf8ness, PL_locale_utf8ness,
+ (int) (e - PL_locale_utf8ness), PL_locale_utf8ness,
e);
}
s = e + 1;
# endif
- Safefree(delimited);
+ /* free only when not using the buffer */
+ if ( delimited != buffer ) Safefree(delimited);
Safefree(save_input_locale);
return is_utf8;
}
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). */
const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
- SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
- if (! categories || categories == &PL_sv_placeholder) {
+ SV *these_categories = cop_hints_fetch_pvs(cop, "locale", 0);
+ if (! these_categories || these_categories == &PL_sv_placeholder) {
return FALSE;
}
/* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
* a valid unsigned */
assert(category >= -1);
- return cBOOL(SvUV(categories) & (1U << (category + 1)));
+ return cBOOL(SvUV(these_categories) & (1U << (category + 1)));
}
char *
* to the C locale */
char *errstr;
- dVAR;
#ifndef USE_LOCALE_MESSAGES
const bool within_locale_scope = IN_LC(LC_MESSAGES);
-# if defined(HAS_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
+# ifndef USE_ITHREADS
- /* This function is trivial if we don't have to worry about thread safety
- * and have strerror_l(), as it handles the switch of locales so we don't
- * have to deal with that. We don't have to worry about thread safety if
- * this is an unthreaded build, or if strerror_r() is also available. Both
- * it and strerror_l() are thread-safe. Plain strerror() isn't thread
- * safe. But on threaded builds when strerror_r() is available, the
- * apparent call to strerror() below is actually a macro that
- * behind-the-scenes calls strerror_r().
- */
+ /* This function is trivial without threads. */
+ if (within_locale_scope) {
+ errstr = savepv(strerror(errnum));
+ }
+ else {
+ const char * save_locale = savepv(do_setlocale_c(LC_MESSAGES, NULL));
+
+ do_setlocale_c(LC_MESSAGES, "C");
+ errstr = savepv(strerror(errnum));
+ do_setlocale_c(LC_MESSAGES, save_locale);
+ Safefree(save_locale);
+ }
+
+# elif defined(USE_POSIX_2008_LOCALE) \
+ && defined(HAS_STRERROR_L)
-# if ! defined(USE_ITHREADS) || defined(HAS_STRERROR_R)
+ /* 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
+ * don't have to deal with that. We don't have to worry about thread
+ * safety if strerror_r() is also available. Both it and strerror_l() are
+ * thread-safe. Plain strerror() isn't thread safe. But on threaded
+ * builds when strerror_r() is available, the apparent call to strerror()
+ * below is actually a macro that behind-the-scenes calls strerror_r(). */
+
+# ifdef HAS_STRERROR_R
if (within_locale_scope) {
errstr = savepv(strerror(errnum));
# endif
# else /* Doesn't have strerror_l() */
-# ifdef USE_POSIX_2008_LOCALE
-
- locale_t save_locale = NULL;
-
-# else
-
const char * save_locale = NULL;
bool locale_is_C = FALSE;
/* We have a critical section to prevent another thread from executing this
- * same code at the same time. (On unthreaded perls, the LOCK is a
+ * 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;
-# endif
-
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"my_strerror called with errnum %d\n", errnum));
if (! within_locale_scope) {
- errno = 0;
-
-# ifdef USE_POSIX_2008_LOCALE /* Use the thread-safe locale functions */
-
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "Not within locale scope, about to call"
- " uselocale(0x%p)\n", PL_C_locale_obj));
- save_locale = uselocale(PL_C_locale_obj);
- if (! save_locale) {
- DEBUG_L(PerlIO_printf(Perl_debug_log,
- "uselocale failed, errno=%d\n", errno));
- }
- else {
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "uselocale returned 0x%p\n", save_locale));
- }
-
-# else /* Not thread-safe build */
-
save_locale = do_setlocale_c(LC_MESSAGES, NULL);
if (! save_locale) {
Perl_croak(aTHX_
do_setlocale_c(LC_MESSAGES, "C");
}
}
-
-# endif
-
} /* end of ! within_locale_scope */
else {
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
errstr = savepv(Strerror(errnum));
if (! within_locale_scope) {
- errno = 0;
-
-# ifdef USE_POSIX_2008_LOCALE
-
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: not within locale scope, restoring the locale\n",
- __FILE__, __LINE__));
- if (save_locale && ! uselocale(save_locale)) {
- DEBUG_L(PerlIO_printf(Perl_debug_log,
- "uselocale restore failed, errno=%d\n", errno));
- }
- }
-
-# else
-
if (save_locale && ! locale_is_C) {
if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
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;
-# endif
# endif /* End of doesn't have strerror_l */
-#endif /* End of does have locale messages */
-
-#ifdef DEBUGGING
+# ifdef DEBUGGING
if (DEBUG_Lv_TEST) {
PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
PerlIO_printf(Perl_debug_log, "'\n");
}
-#endif
+# endif
+#endif /* End of does have locale messages */
SAVEFREEPV(errstr);
return errstr;
/*
-=for apidoc sync_locale
+=for apidoc switch_to_global_locale
+
+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.
+
+On multi-threaded builds on systems that do have per-thread locale operations,
+this function converts the thread it is running in to use the global locale.
+This is for code that has not yet or cannot be updated to handle multi-threaded
+locale operation. As long as only a single thread is so-converted, everything
+works fine, as all the other threads continue to ignore the global one, so only
+this thread looks at it.
+
+However, on Windows systems this isn't quite true prior to Visual Studio 15,
+at which point Microsoft fixed a bug. A race can occur if you use the
+following operations on earlier Windows platforms:
+
+=over
+
+=item L<POSIX::localeconv|POSIX/localeconv>
-Changing the program's locale should be avoided by XS code. Nevertheless,
-certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
-happens, Perl needs to be told that the locale has changed. Use this function
-to do so, before returning to Perl.
+=item L<I18N::Langinfo>, items C<CRNCYSTR> and C<THOUSEP>
+
+=item L<perlapi/Perl_langinfo>, items C<CRNCYSTR> and C<THOUSEP>
+
+=back
+
+The first item is not fixable (except by upgrading to a later Visual Studio
+release), but it would be possible to work around the latter two items by using
+the Windows API functions C<GetNumberFormat> and C<GetCurrencyFormat>; patches
+welcome.
+
+Without this function call, threads that use the L<C<setlocale(3)>> system
+function will not work properly, as all the locale-sensitive functions will
+look at the per-thread locale, and C<setlocale> will have no effect on this
+thread.
+
+Perl code should convert to either call
+L<C<Perl_setlocale>|perlapi/Perl_setlocale> (which is a drop-in for the system
+C<setlocale>) or use the methods given in L<perlcall> to call
+L<C<POSIX::setlocale>|POSIX/setlocale>. Either one will transparently properly
+handle all cases of single- vs multi-thread, POSIX 2008-supported or not.
+
+Non-Perl libraries, such as C<gtk>, that call the system C<setlocale> can
+continue to work if this function is called before transferring control to the
+library.
+
+Upon return from the code that needs to use the global locale,
+L<C<sync_locale()>|perlapi/sync_locale> should be called to restore the safe
+multi-thread operation.
=cut
*/
void
-Perl_sync_locale(pTHX)
+Perl_switch_to_global_locale()
{
- char * newlocale;
-#ifdef USE_LOCALE_CTYPE
+#ifdef USE_THREAD_SAFE_LOCALE
+# ifdef WIN32
+
+ _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+
+# else
+# ifdef HAS_QUERYLOCALE
+
+ setlocale(LC_ALL, querylocale(LC_ALL_MASK, uselocale((locale_t) 0)));
+
+# else
+
+ {
+ unsigned int i;
+
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+ setlocale(categories[i], do_setlocale_r(categories[i], NULL));
+ }
+ }
+
+# endif
+
+ uselocale(LC_GLOBAL_LOCALE);
+
+# endif
+#endif
+
+}
+
+/*
+
+=for apidoc sync_locale
+
+L<C<Perl_setlocale>|perlapi/Perl_setlocale> can be used at any time to query or
+change the locale (though changing the locale is antisocial and dangerous on
+multi-threaded systems that don't have multi-thread safe locale operations.
+(See L<perllocale/Multi-threaded operation>). Using the system
+L<C<setlocale(3)>> should be avoided. Nevertheless, certain non-Perl libraries
+called from XS, such as C<Gtk> do so, and this can't be changed. When the
+locale is changed by XS code that didn't use
+L<C<Perl_setlocale>|perlapi/Perl_setlocale>, Perl needs to be told that the
+locale has changed. Use this function to do so, before returning to Perl.
+
+The return value is a boolean: TRUE if the global locale at the time of call
+was in effect; and FALSE if a per-thread locale was in effect. This can be
+used by the caller that needs to restore things as-they-were to decide whether
+or not to call
+L<C<Perl_switch_to_global_locale>|perlapi/switch_to_global_locale>.
+
+=cut
+*/
+
+bool
+Perl_sync_locale()
+{
+
+#ifndef USE_LOCALE
+
+ return TRUE;
+
+#else
+
+ const char * newlocale;
+ dTHX;
+
+# ifdef USE_POSIX_2008_LOCALE
+
+ bool was_in_global_locale = FALSE;
+ locale_t cur_obj = uselocale((locale_t) 0);
+
+ /* On Windows, unless the foreign code has turned off the thread-safe
+ * locale setting, any plain setlocale() will have affected what we see, so
+ * no need to worry. Otherwise, If the foreign code has done a plain
+ * setlocale(), it will only affect the global locale on POSIX systems, but
+ * will affect the */
+ if (cur_obj == LC_GLOBAL_LOCALE) {
+
+# ifdef HAS_QUERY_LOCALE
+
+ do_setlocale_c(LC_ALL, setlocale(LC_ALL, NULL));
+
+# else
+
+ unsigned int i;
+
+ /* We can't trust that we can read the LC_ALL format on the
+ * platform, so do them individually */
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+ do_setlocale_r(categories[i], setlocale(categories[i], NULL));
+ }
+
+# endif
+
+ was_in_global_locale = TRUE;
+ }
+
+# else
- newlocale = do_setlocale_c(LC_CTYPE, NULL);
+ bool was_in_global_locale = TRUE;
+
+# endif
+# ifdef USE_LOCALE_CTYPE
+
+ newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: %s\n", __FILE__, __LINE__,
setlocale_debug_string(LC_CTYPE, NULL, newlocale)));
new_ctype(newlocale);
+ Safefree(newlocale);
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
+# endif /* USE_LOCALE_CTYPE */
+# ifdef USE_LOCALE_COLLATE
- newlocale = do_setlocale_c(LC_COLLATE, NULL);
+ newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: %s\n", __FILE__, __LINE__,
setlocale_debug_string(LC_COLLATE, NULL, newlocale)));
new_collate(newlocale);
+ Safefree(newlocale);
-#endif
-#ifdef USE_LOCALE_NUMERIC
+# endif
+# ifdef USE_LOCALE_NUMERIC
- newlocale = do_setlocale_c(LC_NUMERIC, NULL);
+ newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: %s\n", __FILE__, __LINE__,
setlocale_debug_string(LC_NUMERIC, NULL, newlocale)));
new_numeric(newlocale);
+ Safefree(newlocale);
-#endif /* USE_LOCALE_NUMERIC */
+# endif /* USE_LOCALE_NUMERIC */
+
+ return was_in_global_locale;
+
+#endif
}
* 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[128] = "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));
#endif
+void
+Perl_thread_locale_init()
+{
+ /* Called from a thread on startup*/
+
+#ifdef USE_THREAD_SAFE_LOCALE
+
+ dTHX_DEBUGGING;
+
+ /* C starts the new thread in the global C locale. If we are thread-safe,
+ * we want to not be in the global locale */
+
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "%s:%d: new thread, initial locale is %s; calling setlocale\n",
+ __FILE__, __LINE__, setlocale(LC_ALL, NULL)));
+
+# ifdef WIN32
+
+ _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+
+# else
+
+ Perl_setlocale(LC_ALL, "C");
+
+# endif
+#endif
+
+}
+
+void
+Perl_thread_locale_term()
+{
+ /* Called from a thread as it gets ready to terminate */
+
+#ifdef USE_THREAD_SAFE_LOCALE
+
+ /* C starts the new thread in the global C locale. If we are thread-safe,
+ * we want to not be in the global locale */
+
+# ifndef WIN32
+
+ { /* Free up */
+ locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
+ if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
+ freelocale(cur_obj);
+ }
+ }
+
+# endif
+#endif
+
+}
/*
* ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blobdiff