#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",
/* 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));
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, PL_C_locale_obj);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale now using %p\n",
+ __FILE__, __LINE__, PL_C_locale_obj);
}
# endif
- /* If we weren't in a thread safe locale, set so that newlocale() below
- which uses 'old_obj', uses an empty one. Same for our reserved C object.
- The latter is defensive coding, so that, even if there is some bug, we
- will never end up trying to modify either of these, as if passed to
- newlocale(), they can be. */
- if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
- old_obj = (locale_t) 0;
- }
-
- /* Ready to create a new locale by modification of the exising one */
- new_obj = newlocale(mask, locale, old_obj);
-
- if (! new_obj) {
- dSAVE_ERRNO;
+ /* If 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 creating new object failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: will stay in C object\n", __FILE__, __LINE__);
}
# endif
- if (! uselocale(old_obj)) {
+ new_obj = PL_C_locale_obj;
+
+ /* We already had switched to the C locale in preparation for freeing
+ * 'old_obj' */
+ if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) {
+ freelocale(old_obj);
+ }
+ }
+ else {
+ /* If we weren't in a thread safe locale, set so that newlocale() below
+ * which uses 'old_obj', uses an empty one. Same for our reserved C
+ * object. The latter is defensive coding, so that, even if there is
+ * some bug, we will never end up trying to modify either of these, as
+ * if passed to newlocale(), they can be. */
+ if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
+ old_obj = (locale_t) 0;
+ }
+
+ /* Ready to create a new locale by modification of the exising one */
+ new_obj = newlocale(mask, locale, old_obj);
+
+ if (! new_obj) {
+ dSAVE_ERRNO;
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale creating new object"
+ " failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
}
# endif
- }
- RESTORE_ERRNO;
- return NULL;
- }
+ if (! uselocale(old_obj)) {
# ifdef DEBUGGING
- if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p; should have freed %p\n", __FILE__, __LINE__, new_obj, old_obj);
- }
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: switching back failed: %d\n",
+ __FILE__, __LINE__, GET_ERRNO);
+ }
# endif
- /* And switch into it */
- if (! uselocale(new_obj)) {
- dSAVE_ERRNO;
+ }
+ RESTORE_ERRNO;
+ return NULL;
+ }
# ifdef DEBUGGING
- if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to new object failed\n", __FILE__, __LINE__);
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale created %p",
+ __FILE__, __LINE__, new_obj);
+ if (old_obj) {
+ PerlIO_printf(Perl_debug_log,
+ "; should have freed %p", old_obj);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
}
# endif
- if (! uselocale(old_obj)) {
+ /* And switch into it */
+ if (! uselocale(new_obj)) {
+ dSAVE_ERRNO;
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale switching to new object"
+ " failed\n", __FILE__, __LINE__);
}
# endif
+ if (! uselocale(old_obj)) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: switching back failed: %d\n",
+ __FILE__, __LINE__, GET_ERRNO);
+ }
+
+# endif
+
+ }
+ freelocale(new_obj);
+ RESTORE_ERRNO;
+ return NULL;
}
- freelocale(new_obj);
- RESTORE_ERRNO;
- return NULL;
}
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, new_obj);
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: emulate_setlocale now using %p\n",
+ __FILE__, __LINE__, new_obj);
}
# endif
/* 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
}
}
+ 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
# 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"
* values for our db, instead of trying to change them.
* */
+ dVAR;
+
int ok = 1;
#ifndef USE_LOCALE
# endif /* DEBUGGING */
#endif /* USE_LOCALE_COLLATE */
-#ifdef DEBUGGING
+#ifdef USE_LOCALE
+# ifdef DEBUGGING
STATIC void
S_print_bytes_for_locale(pTHX_
}
}
-#endif /* #ifdef DEBUGGING */
-
-#ifdef USE_LOCALE
+# endif /* #ifdef DEBUGGING */
STATIC const char *
S_switch_category_locale_to_template(pTHX_ const int switch_category, const int template_category, const char * template_locale)
=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.
# 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