#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
/* The top-most real element is LC_ALL */
-const char * category_names[] = {
+const char * const category_names[] = {
# ifdef USE_LOCALE_NUMERIC
"LC_NUMERIC",
# 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
/* If this assert fails, adjust the size of curlocales in intrpvar.h */
STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX);
-# if defined(_NL_LOCALE_NAME) && defined(DEBUGGING)
-
+# if defined(_NL_LOCALE_NAME) \
+ && defined(DEBUGGING) \
+ && ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME)
+ /* On systems that accept any locale name, the real underlying locale
+ * is often returned by this internal function, so we can't use it */
{
/* Internal glibc for querylocale(), but doesn't handle
* empty-string ("") locale properly; who knows what other
- * glitches. Check it for now, under debug. */
+ * glitches. Check for it now, under debug. */
char * temp_name = nl_langinfo_l(_NL_LOCALE_NAME(category),
uselocale((locale_t) 0));
}
- assert(PL_C_locale_obj);
-
- /* Otherwise, we are switching locales. This will generally entail 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 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;
- }
-
- /* Create the new locale (it may actually modify the current one). */
+ /* Here, we are switching locales. */
# ifndef HAS_QUERYLOCALE
}
if (! default_name || strEQ(default_name, "")) {
- default_name = "C";
+ default_name = "C";
}
else if (PL_scopestack_ix != 0) {
SAVEFREEPV(default_name);
* 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 * 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) {
- unsigned int i;
/* Parse through the category */
while (isWORDCHAR(*p)) {
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 */
- /* Ready to create a new locale by modification of the exising one */
- new_obj = newlocale(mask, locale, old_obj);
+ assert(PL_C_locale_obj);
- if (! new_obj) {
- dSAVE_ERRNO;
+ /* 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_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale creating new object failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
- }
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
+ }
# endif
- if (! uselocale(old_obj)) {
+ if (! 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);
- }
+ 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
- }
- RESTORE_ERRNO;
return NULL;
}
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p\n", __FILE__, __LINE__, new_obj);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale now using %p\n",
+ __FILE__, __LINE__, PL_C_locale_obj);
}
# endif
- /* And switch into it */
- if (! uselocale(new_obj)) {
- dSAVE_ERRNO;
+ /* If we are switching to the LC_ALL C locale, it already exists. Use
+ * it instead of trying to create a new locale */
+ if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(locale)) {
# ifdef DEBUGGING
- if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to new object failed\n", __FILE__, __LINE__);
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: will stay in C object\n", __FILE__, __LINE__);
}
# endif
- if (! uselocale(old_obj)) {
+ new_obj = PL_C_locale_obj;
+
+ /* We already had switched to the C locale in preparation for freeing
+ * 'old_obj' */
+ if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) {
+ freelocale(old_obj);
+ }
+ }
+ else {
+ /* If we weren't in a thread safe locale, set so that newlocale() below
+ * which uses 'old_obj', uses an empty one. Same for our reserved C
+ * object. The latter is defensive coding, so that, even if there is
+ * some bug, we will never end up trying to modify either of these, as
+ * if passed to newlocale(), they can be. */
+ if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
+ old_obj = (locale_t) 0;
+ }
+
+ /* Ready to create a new locale by modification of the exising one */
+ new_obj = newlocale(mask, locale, old_obj);
+
+ if (! new_obj) {
+ dSAVE_ERRNO;
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale creating new object"
+ " failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
}
# endif
+ 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;
}
- freelocale(new_obj);
- RESTORE_ERRNO;
- return NULL;
}
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, new_obj);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale now using %p\n",
+ __FILE__, __LINE__, new_obj);
}
# endif
}
#endif
+#ifdef USE_LOCALE
STATIC void
S_set_numeric_radix(pTHX_ const bool use_locale)
}
# endif
+#else
+
+ PERL_UNUSED_ARG(use_locale);
+
#endif /* USE_LOCALE_NUMERIC and can find the radix char */
}
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(RADIXCHAR,
FALSE /* Don't toggle locale */ ))
&& 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);
* 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;
/* 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 */
}
}
+ 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"
}
+#endif
+
#ifdef WIN32
STATIC char *
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, instead of C<C> always, as
-perl keeps that locale category as C<C>, changing it briefly during the
-operations where the underlying one is required.
+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>. (If it were being written today, plain setlocale would be declared
-const, since it is illegal to change the information it returns; doing so leads
-to segfaults.)
+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
{
/* This wraps POSIX::setlocale() */
+#ifdef NO_LOCALE
+
+ PERL_UNUSED_ARG(category);
+ PERL_UNUSED_ARG(locale);
+
+ return "C";
+
+#else
+
const char * retval;
const char * newlocale;
dSAVEDERRNO;
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
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) {
# 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
+
}
PERL_STATIC_INLINE const char *
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 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.)
+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.)
=item *
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 two are completely unimplemented (though the loss of one of these is
-significant). 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.
+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
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 != 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_THREAD_SAFE_NL_LANGINFO_L) \
- || ! defined(HAS_POSIX_2008_LOCALE)
+ || ! defined(HAS_POSIX_2008_LOCALE) \
+ || ! defined(DUPLOCALE)
/* 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
do_free = TRUE;
}
+# ifdef USE_LOCALE_NUMERIC
+
if (toggle) {
if (PL_underlying_numeric_obj) {
cur = PL_underlying_numeric_obj;
}
}
+# 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),
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;
- /* These 2 are unimplemented */
- case CODESET:
+ /* This is unimplemented */
case ERA: /* For use with strftime() %E modifier */
default:
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 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() */
+ LOCALE_LOCK_V; /* 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;
+ LOCALE_UNLOCK_V;
return "";
}
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
+
+ LOCALE_UNLOCK_V;
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;
+
+# 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() */
+ LOCALE_LOCK_V; /* 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 = save_to_buffer(temp, &PL_langinfo_buf,
&PL_langinfo_bufsize, 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
+
+ LOCALE_UNLOCK_V;
if (toggle) {
RESTORE_LC_NUMERIC();
* values for our db, instead of trying to change them.
* */
+ dVAR;
+
int ok = 1;
#ifndef USE_LOCALE
# endif
# endif
-# if defined(LC_ALL_MASK) && defined(HAS_POSIX_2008_LOCALE)
+# ifdef USE_POSIX_2008_LOCALE
PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
if (! 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 */
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(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;
}
&& 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
is_utf8 = TRUE;
goto finish_and_return;
}
- }
# endif
+ }
# endif
/* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
# endif
- Safefree(delimited);
+ /* free only when not using the buffer */
+ if ( delimited != buffer ) Safefree(delimited);
Safefree(save_input_locale);
return is_utf8;
}
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 *
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);
+ }
-# if ! defined(USE_ITHREADS) || defined(HAS_STRERROR_R)
+# elif defined(HAS_POSIX_2008_LOCALE) \
+ && defined(HAS_STRERROR_L) \
+ && defined(HAS_DUPLOCALE)
+
+ /* This function is also trivial if we don't have to worry about thread
+ * safety and have strerror_l(), as it handles the switch of locales so we
+ * 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));
LOCALE_UNLOCK;
# 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 switch_to_global_locale
-On systems without locale support, or on single-threaded builds, or on
+On systems without locale support, or on typical single-threaded builds, or on
platforms that do not support per-thread locale operations, this function does
nothing. On such systems that do have locale support, only a locale global to
the whole program is available.
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>
+
+=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
bool
Perl_sync_locale()
{
+
+#ifndef USE_LOCALE
+
+ return TRUE;
+
+#else
+
const char * newlocale;
dTHX;
-#ifdef USE_POSIX_2008_LOCALE
+# ifdef USE_POSIX_2008_LOCALE
bool was_in_global_locale = FALSE;
locale_t cur_obj = uselocale((locale_t) 0);
* will affect the */
if (cur_obj == LC_GLOBAL_LOCALE) {
-# ifdef HAS_QUERY_LOCALE
+# ifdef HAS_QUERY_LOCALE
do_setlocale_c(LC_ALL, setlocale(LC_ALL, NULL));
-# else
+# else
unsigned int i;
do_setlocale_r(categories[i], setlocale(categories[i], NULL));
}
-# endif
+# endif
was_in_global_locale = TRUE;
}
-#else
+# else
bool was_in_global_locale = TRUE;
-#endif
-#ifdef USE_LOCALE_CTYPE
+# endif
+# ifdef USE_LOCALE_CTYPE
- newlocale = do_setlocale_c(LC_CTYPE, NULL);
+ 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
+
}
#if defined(DEBUGGING) && defined(USE_LOCALE)
# ifndef WIN32
{ /* Free up */
+ dVAR;
locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
- if (cur_obj != LC_GLOBAL_LOCALE) {
+ if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
freelocale(cur_obj);
}
}
https://perl5.git.perl.org / perl5.git / blobdiff