In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/1159483a303d3acd96053c88ea1bbf1fd4cf8196?hp=645a04a443d51be04bd2b42bdeb6f4d609eba522>
- Log ----------------------------------------------------------------- commit 1159483a303d3acd96053c88ea1bbf1fd4cf8196 Author: Karl Williamson <[email protected]> Date: Sun Jul 23 22:08:50 2017 -0600 Perl_locale(): Refactor for clarity This code is full of 'if's interrupted by #ifdefs, which makes it hard to read. Changing it to a switch() makes it much easier to understand. commit 9f82ea3e1dc3e9f97cb6c7944b1fa2a95bc256fa Author: Karl Williamson <[email protected]> Date: Sun Jul 23 21:53:28 2017 -0600 locale.c:sync_locale(): Add debugging info commit dc0ba7ebeb15ec1b95866a38ab30b798fda9cc56 Author: Karl Williamson <[email protected]> Date: Sun Jul 23 21:39:46 2017 -0600 locale.c:sync_locale(): Rmv useless call This was changing to use the locale's radix, but this is unnecessary for the later things in this function, and those change things to use dot, so this call is useless. commit c70a3e686e2d68a187926a0868eafd79d4767ae0 Author: Karl Williamson <[email protected]> Date: Thu Sep 14 13:32:58 2017 -0600 locale.c: Use new nl_langinfo equivalent This converts the final plain nl_langinfo() function call in locale.c to use the new equivalent that is more thread safe, and you don't have to free the returned memory. There was an unlikely leak before this, if the return was somehow "". commit c72493e024c54c16563371b4cc62b9d2c1dae030 Author: Karl Williamson <[email protected]> Date: Wed Sep 13 21:17:28 2017 -0600 locale.c: Rmv erroneous complement operator The extra '!' that snuck in there caused this code to not work properly. Fortunately, it doesn't get used except as a last resort, and that apparently hasn't happened so as to have gotten reported from the field. A test can't be added because it would only occur on a system that had bad locales. commit d2b24094d5f9c39457520a4a1ecbabb9e3999245 Author: Karl Williamson <[email protected]> Date: Thu Sep 14 12:44:40 2017 -0600 locale.c: Refactor locale macros This standardizes things to make things easier to understand and prepare for future commits commit 837ce802ac50d13b509fabc8243dffb4a93a621b Author: Karl Williamson <[email protected]> Date: Thu Jul 20 19:16:55 2017 -0600 locale.c: Convert setlocale() calls to macros This will be useful in future commits commit b8cc575c43d6ed3f6b7eb7b3f1eefeb1b57ac7d1 Author: Karl Williamson <[email protected]> Date: Wed Jul 19 11:34:08 2017 -0600 locale.c: Change static fcn name The new name more closely reflects what it does commit 86799d2d7311249b2270db1ccb7d283999810d4f Author: Karl Williamson <[email protected]> Date: Thu Jul 20 16:20:01 2017 -0600 locale.c: Refactor static fcn to save work This adds a parameter to the function that sets the radix character for floating point numbers. We know that the radix by default is a dot, so no need to calculate it in that case. This code was previously using localeconv() to find the locale's decimal point. The just added my_nl_langinfo() fcn does the same with an easier API, and is more thread safe, and automatically switches to use localeconv() when n nl_langinfo() isn't available, so revise the conditional compilation directives that previously were necessary, and collapse directives that were unnecessarily nested. And adjust indentation commit f61748ac869b88af2e2557f16421f2d4a8fd09f5 Author: Karl Williamson <[email protected]> Date: Mon Sep 11 19:12:56 2017 -0600 locale.c: Create extended internal Perl_langinfo() This extended version allows it to be called so that it uses the current locale for the LC_NUMERIC, instead of toggling to the underlying one. (This can be useful when in the middle of things.) This ability won't be used until the next commit commit ffd84c7aee3f6c6d089b68f20a631602b655664e Author: Karl Williamson <[email protected]> Date: Thu Jul 20 16:24:42 2017 -0600 locale.c: Rmv redundant fcn call This function is called as part of the call made in the line before. No need to do it twice. commit 7d4bcc4aabeca7ed957fe3cabd112522ea301a59 Author: Karl Williamson <[email protected]> Date: Sat Jul 15 18:19:48 2017 -0600 locale.c: White-space, comment, rearrange some #else This file is full of conditional compilation, due to the fact that locale support has been highly variable in the OSes Perl has operated on. This commit properly indents nested compiler directives, and makes sure there is a blank line between the directives and real code. I find that much easier to read. It also re-orders some #ifdef some_feature Many lines of code handling feature #else 1 to 3 lines of trivial code to avoid compilation warnings #endif to #ifndef some_feature 1 to 3 lines of trivial code to avoid compilation warnings #else Many lines of code handling feature #endif Otherwise the trivial code may be hundreds of lines from the original '#if', which makes it hard to grok. This commit also clarifies and fixes typos in comments, and removes some obsolete comments. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 9 +- embed.h | 14 +- locale.c | 1005 ++++++++++++++++++++++++++++++++++++------------------------- proto.h | 14 +- 4 files changed, 630 insertions(+), 412 deletions(-) diff --git a/embed.fnc b/embed.fnc index d87e109544..527e476f7a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2723,6 +2723,11 @@ s |bool |isa_lookup |NN HV *stash|NN const char * const name \ #endif #if defined(PERL_IN_LOCALE_C) +# ifdef HAS_NL_LANGINFO +sn |const char*|my_nl_langinfo|const nl_item item|bool toggle +# else +sn |const char*|my_nl_langinfo|const int item|bool toggle +# endif in |const char *|save_to_buffer|NN const char * string \ |NULLOK char **buf \ |NN Size_t *buf_size \ @@ -2731,9 +2736,9 @@ in |const char *|save_to_buffer|NN const char * string \ s |char* |stdize_locale |NN char* locs s |void |new_collate |NULLOK const char* newcoll s |void |new_ctype |NN const char* newctype -s |void |set_numeric_radix +s |void |set_numeric_radix|const bool use_locale # ifdef WIN32 -s |char* |my_setlocale |int category|NULLOK const char* locale +s |char* |win32_setlocale|int category|NULLOK const char* locale # endif # ifdef DEBUGGING s |void |print_collxfrm_input_and_return \ diff --git a/embed.h b/embed.h index 89e329a878..a07d719ec9 100644 --- a/embed.h +++ b/embed.h @@ -1413,6 +1413,11 @@ # endif # endif # endif +# if !(defined(HAS_NL_LANGINFO)) +# if defined(PERL_IN_LOCALE_C) +#define my_nl_langinfo S_my_nl_langinfo +# endif +# endif # if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO)) #define sighandler Perl_sighandler # endif @@ -1501,6 +1506,11 @@ #define do_semop(a,b) Perl_do_semop(aTHX_ a,b) #define do_shmio(a,b,c) Perl_do_shmio(aTHX_ a,b,c) # endif +# if defined(HAS_NL_LANGINFO) +# if defined(PERL_IN_LOCALE_C) +#define my_nl_langinfo S_my_nl_langinfo +# endif +# endif # if defined(HAS_SIGACTION) && defined(SA_SIGINFO) #define sighandler Perl_sighandler # endif @@ -1592,10 +1602,10 @@ # if defined(USE_LOCALE) #define new_collate(a) S_new_collate(aTHX_ a) #define new_ctype(a) S_new_ctype(aTHX_ a) -#define set_numeric_radix() S_set_numeric_radix(aTHX) +#define set_numeric_radix(a) S_set_numeric_radix(aTHX_ a) #define stdize_locale(a) S_stdize_locale(aTHX_ a) # if defined(WIN32) -#define my_setlocale(a,b) S_my_setlocale(aTHX_ a,b) +#define win32_setlocale(a,b) S_win32_setlocale(aTHX_ a,b) # endif # endif # endif diff --git a/locale.c b/locale.c index 5db28add69..364eb0bc38 100644 --- a/locale.c +++ b/locale.c @@ -23,8 +23,8 @@ /* utility functions for handling locale-specific stuff like what * character represents the decimal point. * - * All C programs have an underlying locale. Perl generally doesn't pay any - * attention to it except within the scope of a 'use locale'. For most + * All C programs have an underlying locale. Perl code generally doesn't pay + * any attention to it except within the scope of a 'use locale'. For most * categories, it accomplishes this by just using different operations if it is * in such scope than if not. However, various libc functions called by Perl * are affected by the LC_NUMERIC category, so there are macros in perl.h that @@ -45,14 +45,14 @@ * initialization. This is done before option parsing, and before any thread * creation, so can be a file-level static */ #ifdef DEBUGGING -# ifdef PERL_GLOBAL_STRUCT +# ifdef PERL_GLOBAL_STRUCT /* no global syms allowed */ -# define debug_initialization 0 -# define DEBUG_INITIALIZATION_set(v) -# else +# define debug_initialization 0 +# define DEBUG_INITIALIZATION_set(v) +# else static bool debug_initialization = FALSE; -# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v) -# endif +# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v) +# endif #endif #ifdef USE_LOCALE @@ -102,35 +102,60 @@ S_stdize_locale(pTHX_ char *locs) #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 + +/* 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) + STATIC void -S_set_numeric_radix(pTHX) +S_set_numeric_radix(pTHX_ const bool use_locale) { -#ifdef USE_LOCALE_NUMERIC -# ifdef HAS_LOCALECONV - const struct lconv* const lc = localeconv(); + /* If 'use_locale' is FALSE, set to use a dot for the radix character. If + * TRUE, use the radix character derived from the current locale */ - if (lc && lc->decimal_point) { - if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { - SvREFCNT_dec(PL_numeric_radix_sv); - PL_numeric_radix_sv = NULL; - } - else { - if (PL_numeric_radix_sv) - sv_setpv(PL_numeric_radix_sv, lc->decimal_point); - else - PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); - if (! is_utf8_invariant_string((U8 *) lc->decimal_point, 0) - && is_utf8_string((U8 *) lc->decimal_point, 0) +#if defined(USE_LOCALE_NUMERIC) && ( defined(HAS_LOCALECONV) \ + || defined(HAS_NL_LANGINFO)) + + /* We only set up the radix SV if we are to use a locale radix ... */ + if (use_locale) { + const char * radix = my_nl_langinfo(PERL_RADIXCHAR, FALSE); + /* FALSE => already in dest locale */ + + /* ... and the character being used isn't a dot */ + if (strNE(radix, ".")) { + if (PL_numeric_radix_sv) { + sv_setpv(PL_numeric_radix_sv, radix); + } + else { + PL_numeric_radix_sv = newSVpv(radix, 0); + } + + if ( ! is_utf8_invariant_string( + (U8 *) SvPVX(PL_numeric_radix_sv), SvCUR(PL_numeric_radix_sv)) + && is_utf8_string( + (U8 *) SvPVX(PL_numeric_radix_sv), SvCUR(PL_numeric_radix_sv)) && _is_cur_LC_category_utf8(LC_NUMERIC)) { - SvUTF8_on(PL_numeric_radix_sv); + SvUTF8_on(PL_numeric_radix_sv); } - } + goto done; + } } - else - PL_numeric_radix_sv = NULL; -#ifdef DEBUGGING + SvREFCNT_dec(PL_numeric_radix_sv); + PL_numeric_radix_sv = NULL; + + done: ; + +# ifdef DEBUGGING + if (DEBUG_L_TEST || debug_initialization) { PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n", (PL_numeric_radix_sv) @@ -140,10 +165,10 @@ S_set_numeric_radix(pTHX) ? cBOOL(SvUTF8(PL_numeric_radix_sv)) : 0); } -#endif -# endif /* HAS_LOCALECONV */ -#endif /* USE_LOCALE_NUMERIC */ +# endif +#endif /* USE_LOCALE_NUMERIC and can find the radix char */ + } /* Is the C string input 'name' "C" or "POSIX"? If so, and 'name' is the @@ -156,14 +181,20 @@ S_set_numeric_radix(pTHX) * punct: 21-2F 3A-40 5B-60 7B-7E A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD * Oddly, none there are listed as alphas, though some represent alphabetics * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */ -#define isNAME_C_OR_POSIX(name) ((name) != NULL \ - && ((*(name) == 'C' && (*(name + 1)) == '\0') \ - || strEQ((name), "POSIX"))) +#define isNAME_C_OR_POSIX(name) \ + ( (name) != NULL \ + && (( *(name) == 'C' && (*(name + 1)) == '\0') \ + || strEQ((name), "POSIX"))) void Perl_new_numeric(pTHX_ const char *newnum) { -#ifdef USE_LOCALE_NUMERIC + +#ifndef USE_LOCALE_NUMERIC + + PERL_UNUSED_ARG(newnum); + +#else /* Called after all libc setlocale() calls affecting LC_NUMERIC, to tell * core Perl this and that 'newnum' is the name of the new locale. @@ -224,60 +255,67 @@ Perl_new_numeric(pTHX_ const char *newnum) * need the underlying locale change to it temporarily). */ set_numeric_standard(); - set_numeric_radix(); - -#else - PERL_UNUSED_ARG(newnum); #endif /* USE_LOCALE_NUMERIC */ + } void Perl_set_numeric_standard(pTHX) { + #ifdef USE_LOCALE_NUMERIC + /* Toggle the LC_NUMERIC locale to C. Most code should use the macros like * SET_NUMERIC_STANDARD() in perl.h instead of calling this directly. The * macro avoids calling this routine if toggling isn't necessary according * to our records (which could be wrong if some XS code has changed the * locale behind our back) */ - setlocale(LC_NUMERIC, "C"); + do_setlocale_c(LC_NUMERIC, "C"); PL_numeric_standard = TRUE; PL_numeric_local = isNAME_C_OR_POSIX(PL_numeric_name); - set_numeric_radix(); -#ifdef DEBUGGING + set_numeric_radix(0); + +# ifdef DEBUGGING + if (DEBUG_L_TEST || debug_initialization) { PerlIO_printf(Perl_debug_log, "Underlying LC_NUMERIC locale now is C\n"); } -#endif +# endif #endif /* USE_LOCALE_NUMERIC */ + } void Perl_set_numeric_local(pTHX) { + #ifdef USE_LOCALE_NUMERIC + /* Toggle the LC_NUMERIC locale to the current underlying default. Most - * code should use the macros like SET_NUMERIC_LOCAL() in perl.h instead of - * calling this directly. The macro avoids calling this routine if - * toggling isn't necessary according to our records (which could be wrong - * if some XS code has changed the locale behind our back) */ + * code should use the macros like SET_NUMERIC_UNDERLYING() in perl.h + * instead of calling this directly. The macro avoids calling this routine + * if toggling isn't necessary according to our records (which could be + * wrong if some XS code has changed the locale behind our back) */ - setlocale(LC_NUMERIC, PL_numeric_name); + do_setlocale_c(LC_NUMERIC, PL_numeric_name); PL_numeric_standard = isNAME_C_OR_POSIX(PL_numeric_name); PL_numeric_local = TRUE; - set_numeric_radix(); -#ifdef DEBUGGING + set_numeric_radix(1); + +# ifdef DEBUGGING + if (DEBUG_L_TEST || debug_initialization) { PerlIO_printf(Perl_debug_log, "Underlying LC_NUMERIC locale now is %s\n", PL_numeric_name); } -#endif +# endif #endif /* USE_LOCALE_NUMERIC */ + } /* @@ -286,7 +324,14 @@ Perl_set_numeric_local(pTHX) STATIC void S_new_ctype(pTHX_ const char *newctype) { -#ifdef USE_LOCALE_CTYPE + +#ifndef USE_LOCALE_CTYPE + + PERL_ARGS_ASSERT_NEW_CTYPE; + PERL_UNUSED_ARG(newctype); + PERL_UNUSED_CONTEXT; + +#else /* Called after all libc setlocale() calls affecting LC_CTYPE, to tell * core Perl this and that 'newctype' is the name of the new locale. @@ -349,10 +394,10 @@ S_new_ctype(pTHX_ const char *newctype) * nowadays. It isn't a problem for most controls to be changed * into something else; we check only \n and \t, though perhaps \r * could be an issue as well. */ - if (check_for_problems + if ( check_for_problems && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n')) { - if ((isALPHANUMERIC_A(i) && ! isALPHANUMERIC_LC(i)) + if (( isALPHANUMERIC_A(i) && ! isALPHANUMERIC_LC(i)) || (isPUNCT_A(i) && ! isPUNCT_LC(i)) || (isBLANK_A(i) && ! isBLANK_LC(i)) || (i == '\n' && ! isCNTRL_LC(i))) @@ -381,7 +426,8 @@ S_new_ctype(pTHX_ const char *newctype) } } -#ifdef MB_CUR_MAX +# ifdef MB_CUR_MAX + /* We only handle single-byte locales (outside of UTF-8 ones; so if * this locale requires more than one byte, there are going to be * problems. */ @@ -401,7 +447,8 @@ S_new_ctype(pTHX_ const char *newctype) { multi_byte_locale = TRUE; } -#endif + +# endif if (bad_count || multi_byte_locale) { PL_warn_locale = Perl_newSVpvf(aTHX_ @@ -433,12 +480,12 @@ S_new_ctype(pTHX_ const char *newctype) * here is transparent to this function's caller */ const char * const badlocale = savepv(newctype); - setlocale(LC_CTYPE, "C"); + do_setlocale_c(LC_CTYPE, "C"); /* The '0' below suppresses a bogus gcc compiler warning */ Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale), 0); - setlocale(LC_CTYPE, badlocale); + do_setlocale_c(LC_CTYPE, badlocale); Safefree(badlocale); if (IN_LC(LC_CTYPE)) { @@ -450,9 +497,7 @@ S_new_ctype(pTHX_ const char *newctype) } #endif /* USE_LOCALE_CTYPE */ - PERL_ARGS_ASSERT_NEW_CTYPE; - PERL_UNUSED_ARG(newctype); - PERL_UNUSED_CONTEXT; + } void @@ -484,16 +529,17 @@ Perl__warn_problematic_locale() STATIC void S_new_collate(pTHX_ const char *newcoll) { -#ifdef USE_LOCALE_COLLATE + +#ifndef USE_LOCALE_COLLATE + + PERL_UNUSED_ARG(newcoll); + PERL_UNUSED_CONTEXT; + +#else /* Called after all libc setlocale() calls affecting LC_COLLATE, to tell * core Perl this and that 'newcoll' is the name of the new locale. * - * 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(). - * * The design of locale collation is that every locale change is given an * index 'PL_collation_ix'. The first time a string particpates in an * operation that requires collation while locale collation is active, it @@ -681,7 +727,8 @@ S_new_collate(pTHX_ const char *newcoll) PL_collxfrm_base = base + 1; } -#ifdef DEBUGGING +# ifdef DEBUGGING + if (DEBUG_L_TEST || debug_initialization) { PerlIO_printf(Perl_debug_log, "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, " @@ -692,80 +739,96 @@ S_new_collate(pTHX_ const char *newcoll) x_len_shorter, x_len_longer, PL_collxfrm_mult, PL_collxfrm_base); } -#endif +# endif + } } -#else - PERL_UNUSED_ARG(newcoll); #endif /* USE_LOCALE_COLLATE */ -} -#ifndef WIN32 /* No wrapper except on Windows */ - -#define my_setlocale(a,b) setlocale(a,b) +} -#else /* WIN32 */ +#ifdef WIN32 STATIC char * -S_my_setlocale(pTHX_ int category, const char* locale) +S_win32_setlocale(pTHX_ int category, const char* locale) { /* This, for Windows, emulates POSIX setlocale() behavior. There is no - * difference unless the input locale is "", which means on Windows to get - * the machine default, which is set via the computer's "Regional and - * Language Options" (or its current equivalent). In POSIX, it instead - * means to find the locale from the user's environment. This routine - * looks in the environment, and, if anything is found, uses that instead - * of going to the machine default. If there is no environment override, - * the machine default is used, as normal, by calling the real setlocale() - * with "". The POSIX behavior is to use the LC_ALL variable if set; - * otherwise to use the particular category's variable if set; otherwise to - * use the LANG variable. */ + * difference between the two unless the input locale is "", which normally + * means on Windows to get the machine default, which is set via the + * computer's "Regional and Language Options" (or its current equivalent). + * In POSIX, it instead means to find the locale from the user's + * environment. This routine changes the Windows behavior to first look in + * the environment, and, if anything is found, use that instead of going to + * the machine default. If there is no environment override, the machine + * default is used, by calling the real setlocale() with "". + * + * The POSIX behavior is to use the LC_ALL variable if set; otherwise to + * use the particular category's variable if set; otherwise to use the LANG + * variable. */ bool override_LC_ALL = FALSE; char * result; if (locale && strEQ(locale, "")) { -# ifdef LC_ALL + +# ifdef LC_ALL + locale = PerlEnv_getenv("LC_ALL"); if (! locale) { -#endif + +# endif switch (category) { -# ifdef LC_ALL + +# ifdef LC_ALL case LC_ALL: override_LC_ALL = TRUE; break; /* We already know its variable isn't set */ -# endif -# ifdef USE_LOCALE_TIME + +# endif +# ifdef USE_LOCALE_TIME + case LC_TIME: locale = PerlEnv_getenv("LC_TIME"); break; -# endif -# ifdef USE_LOCALE_CTYPE + +# endif +# ifdef USE_LOCALE_CTYPE + case LC_CTYPE: locale = PerlEnv_getenv("LC_CTYPE"); break; -# endif -# ifdef USE_LOCALE_COLLATE + +# endif +# ifdef USE_LOCALE_COLLATE + case LC_COLLATE: locale = PerlEnv_getenv("LC_COLLATE"); break; -# endif -# ifdef USE_LOCALE_MONETARY + +# endif +# ifdef USE_LOCALE_MONETARY + case LC_MONETARY: locale = PerlEnv_getenv("LC_MONETARY"); break; -# endif -# ifdef USE_LOCALE_NUMERIC + +# endif +# ifdef USE_LOCALE_NUMERIC + case LC_NUMERIC: locale = PerlEnv_getenv("LC_NUMERIC"); break; -# endif -# ifdef USE_LOCALE_MESSAGES + +# endif +# ifdef USE_LOCALE_MESSAGES + case LC_MESSAGES: locale = PerlEnv_getenv("LC_MESSAGES"); break; -# endif + +# endif + default: /* This is a category, like PAPER_SIZE that we don't * know about; and so can't provide a wrapper. */ @@ -777,9 +840,13 @@ S_my_setlocale(pTHX_ int category, const char* locale) locale = ""; } } -# ifdef LC_ALL + +# ifdef LC_ALL + } -# endif + +# endif + } result = setlocale(category, locale); @@ -795,7 +862,9 @@ S_my_setlocale(pTHX_ int category, const char* locale) * lower priority than the other LC_foo variables, so override it for each * one that is set. (If they are set to "", it means to use the same thing * we just set LC_ALL to, so can skip) */ -# ifdef USE_LOCALE_TIME + +# ifdef USE_LOCALE_TIME + result = PerlEnv_getenv("LC_TIME"); if (result && strNE(result, "")) { setlocale(LC_TIME, result); @@ -803,8 +872,10 @@ S_my_setlocale(pTHX_ int category, const char* locale) __FILE__, __LINE__, setlocale_debug_string(LC_TIME, result, "not captured"))); } -# endif -# ifdef USE_LOCALE_CTYPE + +# endif +# ifdef USE_LOCALE_CTYPE + result = PerlEnv_getenv("LC_CTYPE"); if (result && strNE(result, "")) { setlocale(LC_CTYPE, result); @@ -812,8 +883,10 @@ S_my_setlocale(pTHX_ int category, const char* locale) __FILE__, __LINE__, setlocale_debug_string(LC_CTYPE, result, "not captured"))); } -# endif -# ifdef USE_LOCALE_COLLATE + +# endif +# ifdef USE_LOCALE_COLLATE + result = PerlEnv_getenv("LC_COLLATE"); if (result && strNE(result, "")) { setlocale(LC_COLLATE, result); @@ -821,8 +894,10 @@ S_my_setlocale(pTHX_ int category, const char* locale) __FILE__, __LINE__, setlocale_debug_string(LC_COLLATE, result, "not captured"))); } -# endif -# ifdef USE_LOCALE_MONETARY + +# endif +# ifdef USE_LOCALE_MONETARY + result = PerlEnv_getenv("LC_MONETARY"); if (result && strNE(result, "")) { setlocale(LC_MONETARY, result); @@ -830,8 +905,10 @@ S_my_setlocale(pTHX_ int category, const char* locale) __FILE__, __LINE__, setlocale_debug_string(LC_MONETARY, result, "not captured"))); } -# endif -# ifdef USE_LOCALE_NUMERIC + +# endif +# ifdef USE_LOCALE_NUMERIC + result = PerlEnv_getenv("LC_NUMERIC"); if (result && strNE(result, "")) { setlocale(LC_NUMERIC, result); @@ -839,8 +916,10 @@ S_my_setlocale(pTHX_ int category, const char* locale) __FILE__, __LINE__, setlocale_debug_string(LC_NUMERIC, result, "not captured"))); } -# endif -# ifdef USE_LOCALE_MESSAGES + +# endif +# ifdef USE_LOCALE_MESSAGES + result = PerlEnv_getenv("LC_MESSAGES"); if (result && strNE(result, "")) { setlocale(LC_MESSAGES, result); @@ -848,7 +927,8 @@ S_my_setlocale(pTHX_ int category, const char* locale) __FILE__, __LINE__, setlocale_debug_string(LC_MESSAGES, result, "not captured"))); } -# endif + +# endif result = setlocale(LC_ALL, NULL); DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", @@ -866,9 +946,9 @@ Perl_setlocale(int category, const char * locale) /* This wraps POSIX::setlocale() */ char * retval; + char * newlocale; dTHX; - #ifdef USE_LOCALE_NUMERIC /* A NULL locale means only query what the current one is. We @@ -881,19 +961,19 @@ Perl_setlocale(int category, const char * locale) return savepv(PL_numeric_name); } -# ifdef LC_ALL +# ifdef LC_ALL else if (category == LC_ALL) { SET_NUMERIC_UNDERLYING(); } -# endif +# endif } #endif - retval = my_setlocale(category, locale); + retval = do_setlocale_r(category, locale); DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__, @@ -904,6 +984,7 @@ Perl_setlocale(int category, const char * locale) if (locale == 0) { SET_NUMERIC_STANDARD(); } + return NULL; } @@ -916,105 +997,63 @@ Perl_setlocale(int category, const char * locale) SET_NUMERIC_STANDARD(); return retval; } - else { /* Now that have switched locales, we have to update our records to - correspond */ - -#ifdef USE_LOCALE_CTYPE - - if ( category == LC_CTYPE - -# ifdef LC_ALL - - || category == LC_ALL - -# endif - - ) - { - char *newctype; - -# ifdef LC_ALL - if (category == LC_ALL) { - newctype = setlocale(LC_CTYPE, NULL); - DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - setlocale_debug_string(LC_CTYPE, NULL, newctype))); - } - else + /* Now that have switched locales, we have to update our records to + * correspond. */ -# endif + switch (category) { - newctype = retval; - new_ctype(newctype); - } +#ifdef USE_LOCALE_CTYPE -#endif /* USE_LOCALE_CTYPE */ + case LC_CTYPE: + new_ctype(retval); + break; +#endif #ifdef USE_LOCALE_COLLATE - if ( category == LC_COLLATE - -# ifdef LC_ALL - - || category == LC_ALL - -# endif - - ) - { - char *newcoll; - -# ifdef LC_ALL - - if (category == LC_ALL) { - newcoll = setlocale(LC_COLLATE, NULL); - DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - setlocale_debug_string(LC_COLLATE, NULL, newcoll))); - } - else - -# endif - - newcoll = retval; - new_collate(newcoll); - } - -#endif /* USE_LOCALE_COLLATE */ + case LC_COLLATE: + new_collate(retval); + break; +#endif #ifdef USE_LOCALE_NUMERIC - if ( category == LC_NUMERIC + case LC_NUMERIC: + new_numeric(retval); + break; -# ifdef LC_ALL +#endif +#ifdef LC_ALL - || category == LC_ALL + case LC_ALL: -# endif + /* LC_ALL updates all the things we care about. The values may not + * be the same as 'retval', as the locale "" may have set things + * individually */ - ) - { - char *newnum; +# ifdef USE_LOCALE_CTYPE -# ifdef LC_ALL + newlocale = do_setlocale_c(LC_CTYPE, NULL); + new_ctype(newlocale); - if (category == LC_ALL) { - newnum = setlocale(LC_NUMERIC, NULL); - DEBUG_Lv(PerlIO_printf(Perl_debug_log, - "%s:%d: %s\n", __FILE__, __LINE__, - setlocale_debug_string(LC_NUMERIC, NULL, newnum))); - } - else +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE -# endif + newlocale = do_setlocale_c(LC_COLLATE, NULL); + new_collate(newlocale); - newnum = retval; - new_numeric(newnum); - } +# endif +# ifdef USE_LOCALE_NUMERIC -#endif /* USE_LOCALE_NUMERIC */ + newlocale = do_setlocale_c(LC_NUMERIC, NULL); + new_numeric(newlocale); + +# endif /* USE_LOCALE_NUMERIC */ +#endif /* LC_ALL */ + default: + break; } return retval; @@ -1051,7 +1090,7 @@ S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t =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 @@ -1167,7 +1206,7 @@ C<Perl_langinfo> in the same thread. =item * -ªIt returns S<C<const char *>>, whereas plain C<nl_langinfo()> returns S<C<char +ª 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 @@ -1194,7 +1233,16 @@ Perl_langinfo(const nl_item item) Perl_langinfo(const int item) #endif { - bool toggle = TRUE; + return my_nl_langinfo(item, TRUE); +} + +const char * +#ifdef HAS_NL_LANGINFO +S_my_nl_langinfo(const nl_item item, bool toggle) +#else +S_my_nl_langinfo(const int item, bool toggle) +#endif +{ dTHX; #if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */ @@ -1209,7 +1257,7 @@ Perl_langinfo(const int item) if (toggle) { if (item == PERL_RADIXCHAR || item == PERL_THOUSEP) { - setlocale(LC_NUMERIC, PL_numeric_name); + do_setlocale_c(LC_NUMERIC, PL_numeric_name); } else { toggle = FALSE; @@ -1219,7 +1267,7 @@ Perl_langinfo(const int item) save_to_buffer(nl_langinfo(item), &PL_langinfo_buf, &PL_langinfo_bufsize, 0); if (toggle) { - setlocale(LC_NUMERIC, "C"); + do_setlocale_c(LC_NUMERIC, "C"); } LOCALE_UNLOCK; @@ -1327,7 +1375,7 @@ Perl_langinfo(const int item) LOCALE_LOCK; if (toggle) { - setlocale(LC_NUMERIC, PL_numeric_name); + do_setlocale_c(LC_NUMERIC, PL_numeric_name); } lc = localeconv(); @@ -1362,7 +1410,7 @@ Perl_langinfo(const int item) save_to_buffer(retval, &PL_langinfo_buf, &PL_langinfo_bufsize, 0); if (toggle) { - setlocale(LC_NUMERIC, "C"); + do_setlocale_c(LC_NUMERIC, "C"); } LOCALE_UNLOCK; @@ -1376,7 +1424,7 @@ Perl_langinfo(const int item) * and so are returned unconditionally; they may not be what the locale * actually says, but should give good enough results for someone using * them as formats (as opposed to trying to parse them to figure out - * what the locale says). The other format ones are actually tested to + * 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"; @@ -1641,9 +1689,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * it. We look at, in order, LC_ALL, LANG, a system default locale (if we * think there is one), and the ultimate fallback "C". This is all done in * the same loop as above to avoid duplicating code, but it makes things - * more complex. After the original failure, we add the fallback - * possibilities to the list of locales to try, and iterate the loop - * through them all until one succeeds. + * more complex. The 'trial_locales' array is initialized with just one + * element; it causes the behavior described in the paragraph above this to + * happen. If that fails, we add elements to 'trial_locales', and do extra + * loop iterations to cause the behavior described in this paragraph. * * On Ultrix, the locale MUST come from the environment, so there is * preliminary code to set it. I (khw) am not sure that it is necessary, @@ -1665,19 +1714,31 @@ Perl_init_i18nl10n(pTHX_ int printwarn) int ok = 1; -#if defined(USE_LOCALE) -#ifdef USE_LOCALE_CTYPE +#ifndef USE_LOCALE + + PERL_UNUSED_ARG(printwarn); + +#else /* USE_LOCALE */ +# ifdef USE_LOCALE_CTYPE + char *curctype = NULL; -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE + +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE + char *curcoll = NULL; -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC + +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + char *curnum = NULL; -#endif /* USE_LOCALE_NUMERIC */ -#ifdef __GLIBC__ + +# endif /* USE_LOCALE_NUMERIC */ +# ifdef __GLIBC__ + const char * const language = savepv(PerlEnv_getenv("LANGUAGE")); -#endif + +# endif /* NULL uses the existing already set up locale */ const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT")) @@ -1703,18 +1764,23 @@ Perl_init_i18nl10n(pTHX_ int printwarn) bool done = FALSE; char * sl_result; /* return from setlocale() */ char * locale_param; -#ifdef WIN32 + +# ifdef WIN32 + /* In some systems you can find out the system default locale * and use that as the fallback locale. */ -# define SYSTEM_DEFAULT_LOCALE -#endif -#ifdef SYSTEM_DEFAULT_LOCALE +# define SYSTEM_DEFAULT_LOCALE +# endif +# ifdef SYSTEM_DEFAULT_LOCALE + const char *system_default_locale = NULL; -#endif -#ifdef DEBUGGING +# endif +# ifdef DEBUGGING + DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))); -# define DEBUG_LOCALE_INIT(category, locale, result) \ + +# define DEBUG_LOCALE_INIT(category, locale, result) \ STMT_START { \ if (debug_initialization) { \ PerlIO_printf(Perl_debug_log, \ @@ -1725,23 +1791,27 @@ Perl_init_i18nl10n(pTHX_ int printwarn) result)); \ } \ } STMT_END -#else -# define DEBUG_LOCALE_INIT(a,b,c) -#endif -#ifndef LOCALE_ENVIRON_REQUIRED +# else +# define DEBUG_LOCALE_INIT(a,b,c) +# endif + +# ifndef LOCALE_ENVIRON_REQUIRED + PERL_UNUSED_VAR(done); PERL_UNUSED_VAR(locale_param); -#else + +# else /* * Ultrix setlocale(..., "") fails if there are no environment * variables from which to get a locale name. */ -# ifdef LC_ALL +# ifdef LC_ALL + if (lang) { - sl_result = my_setlocale(LC_ALL, setlocale_init); + sl_result = do_setlocale_c(LC_ALL, setlocale_init); DEBUG_LOCALE_INIT(LC_ALL, setlocale_init, sl_result); if (sl_result) done = TRUE; @@ -1749,64 +1819,75 @@ Perl_init_i18nl10n(pTHX_ int printwarn) setlocale_failure = TRUE; } if (! setlocale_failure) { -# ifdef USE_LOCALE_CTYPE + +# ifdef USE_LOCALE_CTYPE + locale_param = (! done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? setlocale_init : NULL; - curctype = my_setlocale(LC_CTYPE, locale_param); + curctype = do_setlocale_c(LC_CTYPE, locale_param); DEBUG_LOCALE_INIT(LC_CTYPE, locale_param, sl_result); if (! curctype) setlocale_failure = TRUE; else curctype = savepv(curctype); -# endif /* USE_LOCALE_CTYPE */ -# ifdef USE_LOCALE_COLLATE + +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE + locale_param = (! done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? setlocale_init : NULL; - curcoll = my_setlocale(LC_COLLATE, locale_param); + curcoll = do_setlocale_c(LC_COLLATE, locale_param); DEBUG_LOCALE_INIT(LC_COLLATE, locale_param, sl_result); if (! curcoll) setlocale_failure = TRUE; else curcoll = savepv(curcoll); -# endif /* USE_LOCALE_COLLATE */ -# ifdef USE_LOCALE_NUMERIC + +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + locale_param = (! done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? setlocale_init : NULL; - curnum = my_setlocale(LC_NUMERIC, locale_param); + curnum = do_setlocale_c(LC_NUMERIC, locale_param); DEBUG_LOCALE_INIT(LC_NUMERIC, locale_param, sl_result); if (! curnum) setlocale_failure = TRUE; else curnum = savepv(curnum); -# endif /* USE_LOCALE_NUMERIC */ -# ifdef USE_LOCALE_MESSAGES + +# endif /* USE_LOCALE_NUMERIC */ +# ifdef USE_LOCALE_MESSAGES + locale_param = (! done && (lang || PerlEnv_getenv("LC_MESSAGES"))) ? setlocale_init : NULL; - sl_result = my_setlocale(LC_MESSAGES, locale_param); + sl_result = do_setlocale_c(LC_MESSAGES, locale_param); DEBUG_LOCALE_INIT(LC_MESSAGES, locale_param, sl_result); if (! sl_result) { setlocale_failure = TRUE; } -# endif /* USE_LOCALE_MESSAGES */ -# ifdef USE_LOCALE_MONETARY + +# endif /* USE_LOCALE_MESSAGES */ +# ifdef USE_LOCALE_MONETARY + locale_param = (! done && (lang || PerlEnv_getenv("LC_MONETARY"))) ? setlocale_init : NULL; - sl_result = my_setlocale(LC_MONETARY, locale_param); + sl_result = do_setlocale_c(LC_MONETARY, locale_param); DEBUG_LOCALE_INIT(LC_MONETARY, locale_param, sl_result); if (! sl_result) { setlocale_failure = TRUE; } -# endif /* USE_LOCALE_MONETARY */ - } -# endif /* LC_ALL */ +# endif /* USE_LOCALE_MONETARY */ + + } -#endif /* !LOCALE_ENVIRON_REQUIRED */ +# endif /* LC_ALL */ +# endif /* !LOCALE_ENVIRON_REQUIRED */ /* We try each locale in the list until we get one that works, or exhaust * the list. Normally the loop is executed just once. But if setting the @@ -1814,6 +1895,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * will execute the loop multiple times */ trial_locales[0] = setlocale_init; trial_locales_count = 1; + for (i= 0; i < trial_locales_count; i++) { const char * trial_locale = trial_locales[i]; @@ -1824,8 +1906,9 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * sense */ setlocale_failure = FALSE; -#ifdef SYSTEM_DEFAULT_LOCALE -# ifdef WIN32 +# ifdef SYSTEM_DEFAULT_LOCALE +# ifdef WIN32 + /* On Windows machines, an entry of "" after the 0th means to use * the system default locale, which we now proceed to get. */ if (strEQ(trial_locale, "")) { @@ -1833,10 +1916,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) /* Note that this may change the locale, but we are going to do * that anyway just below */ - system_default_locale = setlocale(LC_ALL, ""); + system_default_locale = do_setlocale_c(LC_ALL, ""); DEBUG_LOCALE_INIT(LC_ALL, "", system_default_locale); - /* Skip if invalid or it's already on the list of locales to + /* Skip if invalid or if it's already on the list of locales to * try */ if (! system_default_locale) { goto next_iteration; @@ -1849,12 +1932,13 @@ Perl_init_i18nl10n(pTHX_ int printwarn) trial_locale = system_default_locale; } -# endif /* WIN32 */ -#endif /* SYSTEM_DEFAULT_LOCALE */ +# endif /* WIN32 */ +# endif /* SYSTEM_DEFAULT_LOCALE */ } -#ifdef LC_ALL - sl_result = my_setlocale(LC_ALL, trial_locale); +# ifdef LC_ALL + + sl_result = do_setlocale_c(LC_ALL, trial_locale); DEBUG_LOCALE_INIT(LC_ALL, trial_locale, sl_result); if (! sl_result) { setlocale_failure = TRUE; @@ -1865,52 +1949,64 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * setlocales below just return their category's current values. * This adequately handles the case in NetBSD where LC_COLLATE may * not be defined for a locale, and setting it individually will - * fail, whereas setting LC_ALL suceeds, leaving LC_COLLATE set to + * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to * the POSIX locale. */ trial_locale = NULL; } -#endif /* LC_ALL */ + +# endif /* LC_ALL */ if (!setlocale_failure) { -#ifdef USE_LOCALE_CTYPE + +# ifdef USE_LOCALE_CTYPE + Safefree(curctype); - curctype = my_setlocale(LC_CTYPE, trial_locale); + curctype = do_setlocale_c(LC_CTYPE, trial_locale); DEBUG_LOCALE_INIT(LC_CTYPE, trial_locale, curctype); if (! curctype) setlocale_failure = TRUE; else curctype = savepv(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE + +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE + Safefree(curcoll); - curcoll = my_setlocale(LC_COLLATE, trial_locale); + curcoll = do_setlocale_c(LC_COLLATE, trial_locale); DEBUG_LOCALE_INIT(LC_COLLATE, trial_locale, curcoll); if (! curcoll) setlocale_failure = TRUE; else curcoll = savepv(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC + +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + Safefree(curnum); - curnum = my_setlocale(LC_NUMERIC, trial_locale); + curnum = do_setlocale_c(LC_NUMERIC, trial_locale); DEBUG_LOCALE_INIT(LC_NUMERIC, trial_locale, curnum); if (! curnum) setlocale_failure = TRUE; else curnum = savepv(curnum); -#endif /* USE_LOCALE_NUMERIC */ -#ifdef USE_LOCALE_MESSAGES - sl_result = my_setlocale(LC_MESSAGES, trial_locale); + +# endif /* USE_LOCALE_NUMERIC */ +# ifdef USE_LOCALE_MESSAGES + + sl_result = do_setlocale_c(LC_MESSAGES, trial_locale); DEBUG_LOCALE_INIT(LC_MESSAGES, trial_locale, sl_result); if (! (sl_result)) setlocale_failure = TRUE; -#endif /* USE_LOCALE_MESSAGES */ -#ifdef USE_LOCALE_MONETARY - sl_result = my_setlocale(LC_MONETARY, trial_locale); + +# endif /* USE_LOCALE_MESSAGES */ +# ifdef USE_LOCALE_MONETARY + + sl_result = do_setlocale_c(LC_MONETARY, trial_locale); DEBUG_LOCALE_INIT(LC_MONETARY, trial_locale, sl_result); if (! (sl_result)) setlocale_failure = TRUE; -#endif /* USE_LOCALE_MONETARY */ + +# endif /* USE_LOCALE_MONETARY */ if (! setlocale_failure) { /* Success */ break; @@ -1924,41 +2020,50 @@ Perl_init_i18nl10n(pTHX_ int printwarn) unsigned int j; if (locwarn) { /* Output failure info only on the first one */ -#ifdef LC_ALL + +# ifdef LC_ALL PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed.\n"); -#else /* !LC_ALL */ +# else /* !LC_ALL */ PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed for the categories:\n\t"); -# ifdef USE_LOCALE_CTYPE + +# ifdef USE_LOCALE_CTYPE + if (! curctype) PerlIO_printf(Perl_error_log, "LC_CTYPE "); -# endif /* USE_LOCALE_CTYPE */ -# ifdef USE_LOCALE_COLLATE + +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE if (! curcoll) PerlIO_printf(Perl_error_log, "LC_COLLATE "); -# endif /* USE_LOCALE_COLLATE */ -# ifdef USE_LOCALE_NUMERIC + +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + if (! curnum) PerlIO_printf(Perl_error_log, "LC_NUMERIC "); -# endif /* USE_LOCALE_NUMERIC */ + +# endif /* USE_LOCALE_NUMERIC */ + PerlIO_printf(Perl_error_log, "and possibly others\n"); -#endif /* LC_ALL */ +# endif /* LC_ALL */ PerlIO_printf(Perl_error_log, "perl: warning: Please check that your locale settings:\n"); -#ifdef __GLIBC__ +# ifdef __GLIBC__ + PerlIO_printf(Perl_error_log, "\tLANGUAGE = %c%s%c,\n", language ? '"' : '(', language ? language : "unset", language ? '"' : ')'); -#endif +# endif PerlIO_printf(Perl_error_log, "\tLC_ALL = %c%s%c,\n", @@ -1966,7 +2071,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) lc_all ? lc_all : "unset", lc_all ? '"' : ')'); -#if defined(USE_ENVIRON_ARRAY) +# if defined(USE_ENVIRON_ARRAY) + { char **e; @@ -1990,10 +2096,13 @@ Perl_init_i18nl10n(pTHX_ int printwarn) } } } -#else + +# else + PerlIO_printf(Perl_error_log, "\t(possibly more locale environment variables)\n"); -#endif + +# endif PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n", @@ -2040,7 +2149,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) } done_lang: -#if defined(WIN32) && defined(LC_ALL) +# if defined(WIN32) && defined(LC_ALL) + /* For Windows, we also try the system default locale before "C". * (If there exists a Windows without LC_ALL we skip this because * it gets too complicated. For those, the "C" is the next @@ -2048,7 +2158,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * the array, but the code at the loop above knows to treat it * differently when not the 0th */ trial_locales[trial_locales_count++] = ""; -#endif + +# endif for (j = 0; j < trial_locales_count; j++) { if (strEQ("C", trial_locales[j])) { @@ -2060,9 +2171,11 @@ Perl_init_i18nl10n(pTHX_ int printwarn) done_C: ; } /* end of first time through the loop */ -#ifdef WIN32 +# ifdef WIN32 + next_iteration: ; -#endif + +# endif } /* end of looping through the trial locales */ @@ -2081,21 +2194,29 @@ Perl_init_i18nl10n(pTHX_ int printwarn) msg = "Failed to fall back to"; /* To continue, we should use whatever values we've got */ -#ifdef USE_LOCALE_CTYPE + +# ifdef USE_LOCALE_CTYPE + Safefree(curctype); - curctype = savepv(setlocale(LC_CTYPE, NULL)); + curctype = savepv(do_setlocale_c(LC_CTYPE, NULL)); DEBUG_LOCALE_INIT(LC_CTYPE, NULL, curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE + +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE + Safefree(curcoll); - curcoll = savepv(setlocale(LC_COLLATE, NULL)); + curcoll = savepv(do_setlocale_c(LC_COLLATE, NULL)); DEBUG_LOCALE_INIT(LC_COLLATE, NULL, curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC + +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + Safefree(curnum); - curnum = savepv(setlocale(LC_NUMERIC, NULL)); + curnum = savepv(do_setlocale_c(LC_NUMERIC, NULL)); DEBUG_LOCALE_INIT(LC_NUMERIC, NULL, curnum); -#endif /* USE_LOCALE_NUMERIC */ + +# endif /* USE_LOCALE_NUMERIC */ + } if (locwarn) { @@ -2105,14 +2226,18 @@ Perl_init_i18nl10n(pTHX_ int printwarn) description = "the standard locale"; name = "C"; } -#ifdef SYSTEM_DEFAULT_LOCALE + +# ifdef SYSTEM_DEFAULT_LOCALE + else if (strEQ(trial_locales[i], "")) { description = "the system default locale"; if (system_default_locale) { name = system_default_locale; } } -#endif /* SYSTEM_DEFAULT_LOCALE */ + +# endif /* SYSTEM_DEFAULT_LOCALE */ + else { description = "a fallback locale"; name = trial_locales[i]; @@ -2128,19 +2253,23 @@ Perl_init_i18nl10n(pTHX_ int printwarn) } } /* End of tried to fallback */ -#ifdef USE_LOCALE_CTYPE +# ifdef USE_LOCALE_CTYPE + new_ctype(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE + new_collate(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + new_numeric(curnum); -#endif /* USE_LOCALE_NUMERIC */ -#if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE) +# endif /* USE_LOCALE_NUMERIC */ +# if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE) + /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE * locale is UTF-8. If PL_utf8locale and PL_unicode (set by -C or by * $ENV{PERL_UNICODE}) are true, perl.c:S_parse_body() will turn on the @@ -2157,32 +2286,39 @@ Perl_init_i18nl10n(pTHX_ int printwarn) if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) PL_utf8cache = -1; } -#endif -#ifdef USE_LOCALE_CTYPE +# endif +# ifdef USE_LOCALE_CTYPE + Safefree(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE + +# endif /* USE_LOCALE_CTYPE */ +# ifdef USE_LOCALE_COLLATE + Safefree(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC + +# endif /* USE_LOCALE_COLLATE */ +# ifdef USE_LOCALE_NUMERIC + Safefree(curnum); -#endif /* USE_LOCALE_NUMERIC */ -#ifdef __GLIBC__ +# endif /* USE_LOCALE_NUMERIC */ + +# ifdef __GLIBC__ + Safefree(language); -#endif + +# endif Safefree(lc_all); Safefree(lang); -#else /* !USE_LOCALE */ - PERL_UNUSED_ARG(printwarn); #endif /* USE_LOCALE */ - #ifdef DEBUGGING + /* So won't continue to output stuff */ DEBUG_INITIALIZATION_set(FALSE); + #endif return ok; @@ -2583,10 +2719,14 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, * length 1 strings, as we can't be sure that it's a real slope * change */ if (length_in_chars > 1 && new_m > PL_collxfrm_mult) { -#ifdef DEBUGGING + +# ifdef DEBUGGING + STRLEN old_m = PL_collxfrm_mult; STRLEN old_b = PL_collxfrm_base; -#endif + +# endif + PL_collxfrm_mult = new_m; PL_collxfrm_base = 1; /* +1 For trailing NUL */ computed_guess = PL_collxfrm_base @@ -2645,7 +2785,8 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, xAlloc += (xAlloc / 4) + 1; PL_strxfrm_is_behaved = FALSE; -#ifdef DEBUGGING +# ifdef DEBUGGING + if (DEBUG_Lv_TEST || debug_initialization) { PerlIO_printf(Perl_debug_log, "_mem_collxfrm required more space than previously calculated" @@ -2653,7 +2794,9 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, PL_collation_name, (int) COLLXFRM_HDR_LEN, xAlloc - COLLXFRM_HDR_LEN); } -#endif + +# endif + } Renew(xbuf, xAlloc, char); @@ -2667,7 +2810,8 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, } -#ifdef DEBUGGING +# ifdef DEBUGGING + if (DEBUG_Lv_TEST || debug_initialization) { print_collxfrm_input_and_return(s, s + len, xlen, utf8); @@ -2676,7 +2820,8 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN, *xlen, 1)); } -#endif + +# endif /* Free up unneeded space; retain ehough for trailing NUL */ Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char); @@ -2693,15 +2838,19 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, Safefree(s); } *xlen = 0; -#ifdef DEBUGGING + +# ifdef DEBUGGING + if (DEBUG_Lv_TEST || debug_initialization) { print_collxfrm_input_and_return(s, s + len, NULL, utf8); } -#endif + +# endif + return NULL; } -#ifdef DEBUGGING +# ifdef DEBUGGING STATIC void S_print_collxfrm_input_and_return(pTHX_ @@ -2763,8 +2912,7 @@ S_print_bytes_for_locale(pTHX_ } } -#endif /* #ifdef DEBUGGING */ - +# endif /* #ifdef DEBUGGING */ #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE @@ -2783,12 +2931,14 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) char *save_input_locale = NULL; STRLEN final_pos; -#ifdef LC_ALL +# ifdef LC_ALL + assert(category != LC_ALL); -#endif + +# endif /* First dispose of the trivial cases */ - save_input_locale = setlocale(category, NULL); + save_input_locale = do_setlocale_r(category, NULL); if (! save_input_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not find current locale for category %d\n", @@ -2804,7 +2954,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) return FALSE; } -#if defined(USE_LOCALE_CTYPE) \ +# if defined(USE_LOCALE_CTYPE) \ && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET))) { /* Next try nl_langinfo or MB_CUR_MAX if available */ @@ -2815,7 +2965,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) if (category != LC_CTYPE) { /* These work only on LC_CTYPE */ /* Get the current LC_CTYPE locale */ - save_ctype_locale = setlocale(LC_CTYPE, NULL); + save_ctype_locale = do_setlocale_c(LC_CTYPE, NULL); if (! save_ctype_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not find current locale for LC_CTYPE\n")); @@ -2831,7 +2981,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_ctype_locale); save_ctype_locale = NULL; } - else if (! setlocale(LC_CTYPE, save_input_locale)) { + else if (! do_setlocale_c(LC_CTYPE, save_input_locale)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not change LC_CTYPE locale to %s\n", save_input_locale)); @@ -2847,15 +2997,20 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) * information is desired. This means that nl_langinfo() and MB_CUR_MAX * should give the correct results */ -# if defined(HAS_NL_LANGINFO) && defined(CODESET) +# if defined(HAS_NL_LANGINFO) && defined(CODESET) + /* The task is easiest if has this POSIX 2001 function */ + { - char *codeset = nl_langinfo(CODESET); - if (codeset && strNE(codeset, "")) { - codeset = savepv(codeset); + const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE); + /* FALSE => already in dest locale */ + + DEBUG_L(PerlIO_printf(Perl_debug_log, + "\tnllanginfo returned CODESET '%s'\n", codeset)); + if (codeset && strNE(codeset, "")) { /* If we switched LC_CTYPE, switch back */ if (save_ctype_locale) { - setlocale(LC_CTYPE, save_ctype_locale); + do_setlocale_c(LC_CTYPE, save_ctype_locale); Safefree(save_ctype_locale); } @@ -2865,14 +3020,13 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) DEBUG_L(PerlIO_printf(Perl_debug_log, "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n", codeset, is_utf8)); - Safefree(codeset); Safefree(save_input_locale); return is_utf8; } } -# endif -# ifdef MB_CUR_MAX +# endif +# ifdef MB_CUR_MAX /* Here, either we don't have nl_langinfo, or it didn't return a * codeset. Try MB_CUR_MAX */ @@ -2889,7 +3043,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_input_locale); -# ifdef HAS_MBTOWC +# ifdef HAS_MBTOWC /* ... But, most system that have MB_CUR_MAX will also have mbtowc(), * since they are both in the C99 standard. We can feed a known byte @@ -2910,21 +3064,24 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8)), errno)); } } -# endif + +# endif /* If we switched LC_CTYPE, switch back */ if (save_ctype_locale) { - setlocale(LC_CTYPE, save_ctype_locale); + do_setlocale_c(LC_CTYPE, save_ctype_locale); Safefree(save_ctype_locale); } return is_utf8; -# endif + +# endif + } cant_use_nllanginfo: -#else /* nl_langinfo should work if available, so don't bother compiling this +# else /* nl_langinfo should work if available, so don't bother compiling this fallback code. The final fallback of looking at the name is compiled, and will be executed if nl_langinfo fails */ @@ -2935,8 +3092,9 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) * too, as the odds of a non-UTF8 string being valid UTF-8 are quite small * */ -#ifdef HAS_LOCALECONV -# ifdef USE_LOCALE_MONETARY +# ifdef HAS_LOCALECONV +# ifdef USE_LOCALE_MONETARY + { char *save_monetary_locale = NULL; bool only_ascii = FALSE; @@ -2948,7 +3106,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) if (category != LC_MONETARY) { - save_monetary_locale = setlocale(LC_MONETARY, NULL); + save_monetary_locale = do_setlocale_c(LC_MONETARY, NULL); if (! save_monetary_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not find current locale for LC_MONETARY\n")); @@ -2960,7 +3118,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_monetary_locale); save_monetary_locale = NULL; } - else if (! setlocale(LC_MONETARY, save_input_locale)) { + else if (! do_setlocale_c(LC_MONETARY, save_input_locale)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not change LC_MONETARY locale to %s\n", save_input_locale)); @@ -2986,7 +3144,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) /* If we changed it, restore LC_MONETARY to its original locale */ if (save_monetary_locale) { - setlocale(LC_MONETARY, save_monetary_locale); + do_setlocale_c(LC_MONETARY, save_monetary_locale); Safefree(save_monetary_locale); } @@ -3003,10 +3161,10 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) } cant_use_monetary: -# endif /* USE_LOCALE_MONETARY */ -#endif /* HAS_LOCALECONV */ +# endif /* USE_LOCALE_MONETARY */ +# endif /* HAS_LOCALECONV */ -#if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME) +# if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME) /* Still haven't found a non-ASCII string to disambiguate UTF-8 or not. Try * the names of the months and weekdays, timezone, and am/pm indicator */ @@ -3025,7 +3183,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) if (category != LC_TIME) { - save_time_locale = setlocale(LC_TIME, NULL); + save_time_locale = do_setlocale_c(LC_TIME, NULL); if (! save_time_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not find current locale for LC_TIME\n")); @@ -3037,7 +3195,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_time_locale); save_time_locale = NULL; } - else if (! setlocale(LC_TIME, save_input_locale)) { + else if (! do_setlocale_c(LC_TIME, save_input_locale)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not change LC_TIME locale to %s\n", save_input_locale)); @@ -3076,7 +3234,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) * false otherwise. But first, restore LC_TIME to its original * locale if we changed it */ if (save_time_locale) { - setlocale(LC_TIME, save_time_locale); + do_setlocale_c(LC_TIME, save_time_locale); Safefree(save_time_locale); } @@ -3091,16 +3249,16 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) * ASCII. Go on to the next test. If we changed it, restore LC_TIME * to its original locale */ if (save_time_locale) { - setlocale(LC_TIME, save_time_locale); + do_setlocale_c(LC_TIME, save_time_locale); Safefree(save_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)); } cant_use_time: -#endif +# endif -#if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST) ... 279 lines suppressed ... -- Perl5 Master Repository
