X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bbc981342c254b86d5bc82e5175169b68f0e59ce..2e6807b5b9d6bff0efdfbbed7b7731e04ea21273:/locale.c?ds=sidebyside diff --git a/locale.c b/locale.c index d1ea74c..0bf8057 100644 --- a/locale.c +++ b/locale.c @@ -29,7 +29,9 @@ * 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 * are used to toggle between the current locale and the C locale depending on - * the desired behavior of those functions at the moment. + * the desired behavior of those functions at the moment. And, LC_MESSAGES is + * switched to the C locale for outputting the message unless within the scope + * of 'use locale'. */ #include "EXTERN.h" @@ -117,10 +119,13 @@ Perl_set_numeric_radix(pTHX) else PL_numeric_radix_sv = NULL; - DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is %s\n", + DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n", (PL_numeric_radix_sv) - ? lc->decimal_point - : "NULL")); + ? SvPVX(PL_numeric_radix_sv) + : "NULL", + (PL_numeric_radix_sv) + ? cBOOL(SvUTF8(PL_numeric_radix_sv)) + : 0)); # endif /* HAS_LOCALECONV */ #endif /* USE_LOCALE_NUMERIC */ @@ -187,13 +192,17 @@ Perl_new_numeric(pTHX_ const char *newnum) } save_newnum = stdize_locale(savepv(newnum)); + + PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum); + PL_numeric_local = TRUE; + if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) { Safefree(PL_numeric_name); PL_numeric_name = save_newnum; } - - PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum); - PL_numeric_local = TRUE; + else { + Safefree(save_newnum); + } /* Keep LC_NUMERIC in the C locale. This is for XS modules, so they don't * have to worry about the radix being a non-dot. (Core operations that @@ -350,7 +359,7 @@ Perl_new_ctype(pTHX_ const char *newctype) #ifdef MB_CUR_MAX /* We only handle single-byte locales (outside of UTF-8 ones; so if - * this locale requires than one byte, there are going to be + * this locale requires more than one byte, there are going to be * problems. */ if (check_for_problems && MB_CUR_MAX > 1 @@ -450,7 +459,21 @@ Perl_new_collate(pTHX_ const char *newcoll) * 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() */ + * 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 + * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()). That + * magic includes the collation index, and the transformation of the string + * by strxfrm(), q.v. That transformation is used when doing comparisons, + * instead of the string itself. If a string changes, the magic is + * cleared. The next time the locale changes, the index is incremented, + * and so we know during a comparison that the transformation is not + * necessarily still valid, and so is recomputed. Note that if the locale + * changes enough times, the index could wrap (a U32), and it is possible + * that a transformation would improperly be considered valid, leading to + * an unlikely bug */ if (! newcoll) { if (PL_collation_name) { @@ -464,6 +487,7 @@ Perl_new_collate(pTHX_ const char *newcoll) return; } + /* If this is not the same locale as currently, set the new one up */ if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { ++PL_collation_ix; Safefree(PL_collation_name); @@ -471,6 +495,32 @@ Perl_new_collate(pTHX_ const char *newcoll) PL_collation_standard = isNAME_C_OR_POSIX(newcoll); { + /* A locale collation definition includes primary, secondary, + * tertiary, etc. weights for each character. To sort, the primary + * weights are used, and only if they compare equal, then the + * secondary weights are used, and only if they compare equal, then + * the tertiary, etc. strxfrm() works by taking the input string, + * say ABC, and creating an output string consisting of first the + * primary weights, A¹B¹C¹ followed by the secondary ones, A²B²C²; + * and then the tertiary, etc, yielding A¹B¹C¹A²B²C²A³B³C³.... + * Some characters may not have weights at every level. In our + * example, let's say B doesn't have a tertiary weight, and A + * doesn't have a secondary weight. The constructed string is then + * going to be A¹B¹C¹B²C²A³C³.... This has the desired + * characteristics that strcmp() will look at the secondary or + * tertiary weights only if the strings compare equal at all higher + * priority weights. The length of the transformed string is + * roughly a linear function of the input string. It's not exactly + * linear because some characters don't have weights at all levels, + * and there are some complications, so there is often per-string + * overhead. When we call strxfrm() we have to allocate some + * memory to hold the transformed string. The calculations below + * try to find constants for this locale 'm' and 'b' so that m*x + + * b equals how much space we need given the size of the input + * string in 'x'. If we calculate too small, we increase the size + * as needed, and call strxfrm() again, but it is better to get it + * right the first time to avoid wasted expensive string + * transformations. */ /* 2: at most so many chars ('a', 'b'). */ /* 50: surely no system expands a char more. */ #define XFRMBUFSIZE (2 * 50) @@ -1217,6 +1267,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * differences. First, it handles embedded NULs. Second, it allocates * a bit more memory than needed for the transformed data itself. * The real transformed data begins at offset sizeof(collationix). + * *xlen is set to the length of that, and doesn't include the collation index + * size. * Please see sv_collxfrm() to see how this is used. */ @@ -1233,23 +1285,36 @@ Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; Newx(xbuf, xAlloc, char); - if (! xbuf) + if (UNLIKELY(! xbuf)) goto bad; + /* Store the collation id */ *(U32*)xbuf = PL_collation_ix; xout = sizeof(PL_collation_ix); + + /* Then the transformation of the input. We loop until successful, or we + * give up */ for (xin = 0; xin < len; ) { Size_t xused; for (;;) { xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); - if (xused >= PERL_INT_MAX) - goto bad; + + /* If the transformed string occupies less space than we told + * strxfrm() was available, it means it successfully transformed + * the whole string. */ if ((STRLEN)xused < xAlloc - xout) break; + + if (UNLIKELY(xused >= PERL_INT_MAX)) + goto bad; + + /* Otherwise it should be that the transformation stopped in the + * middle because it ran out of space. Malloc more, and try again. + * */ xAlloc = (2 * xAlloc) + 1; Renew(xbuf, xAlloc, char); - if (! xbuf) + if (UNLIKELY(! xbuf)) goto bad; } @@ -1800,13 +1865,21 @@ Perl__is_in_locale_category(pTHX_ const bool compiling, const int category) char * Perl_my_strerror(pTHX_ const int errnum) { + dVAR; /* Uses C locale for the error text unless within scope of 'use locale' for * LC_MESSAGES */ #ifdef USE_LOCALE_MESSAGES if (! IN_LC(LC_MESSAGES)) { - char * save_locale = setlocale(LC_MESSAGES, NULL); + char * save_locale; + + /* We have a critical section to prevent another thread from changing + * the locale out from under us (or zapping the buffer returned from + * setlocale() ) */ + LOCALE_LOCK; + + save_locale = setlocale(LC_MESSAGES, NULL); if (! isNAME_C_OR_POSIX(save_locale)) { char *errstr; @@ -1821,8 +1894,13 @@ Perl_my_strerror(pTHX_ const int errnum) { setlocale(LC_MESSAGES, save_locale); Safefree(save_locale); + + LOCALE_UNLOCK; + return errstr; } + + LOCALE_UNLOCK; } #endif @@ -1876,78 +1954,75 @@ Perl__setlocale_debug_string(const int category, /* category number, /* Returns a pointer to a NUL-terminated string in static storage with * added text about the info passed in. This is not thread safe and will * be overwritten by the next call, so this should be used just to - * formulate a string to immediately print or savepv() on. - * - * Buffer overflow checking is done only after the fact (via an assert), - * because this is used only in DEBUGGING, and an attacker would have to - * control the start up of perl with the correct environment variable or - * command line option. */ + * formulate a string to immediately print or savepv() on. */ - static char ret[128] = ""; + /* initialise to a non-null value to keep it out of BSS and so keep + * -DPERL_GLOBAL_STRUCT_PRIVATE happy */ + static char ret[128] = "x"; - strcpy(ret, "setlocale("); + my_strlcpy(ret, "setlocale(", sizeof(ret)); switch (category) { default: - sprintf(ret, "%s? %d", ret, category); + my_snprintf(ret, sizeof(ret), "%s? %d", ret, category); break; # ifdef LC_ALL case LC_ALL: - strcat(ret, "LC_ALL"); + my_strlcat(ret, "LC_ALL", sizeof(ret)); break; # endif # ifdef LC_CTYPE case LC_CTYPE: - strcat(ret, "LC_CTYPE"); + my_strlcat(ret, "LC_CTYPE", sizeof(ret)); break; # endif # ifdef LC_NUMERIC case LC_NUMERIC: - strcat(ret, "LC_NUMERIC"); + my_strlcat(ret, "LC_NUMERIC", sizeof(ret)); break; # endif # ifdef LC_COLLATE case LC_COLLATE: - strcat(ret, "LC_COLLATE"); + my_strlcat(ret, "LC_COLLATE", sizeof(ret)); break; # endif # ifdef LC_TIME case LC_TIME: - strcat(ret, "LC_TIME"); + my_strlcat(ret, "LC_TIME", sizeof(ret)); break; # endif # ifdef LC_MONETARY case LC_MONETARY: - strcat(ret, "LC_MONETARY"); + my_strlcat(ret, "LC_MONETARY", sizeof(ret)); break; # endif # ifdef LC_MESSAGES case LC_MESSAGES: - strcat(ret, "LC_MESSAGES"); + my_strlcat(ret, "LC_MESSAGES", sizeof(ret)); break; # endif } - strcat(ret, ", "); + my_strlcat(ret, ", ", sizeof(ret)); if (locale) { - strcat(ret, "\""); - strcat(ret, locale); - strcat(ret, "\""); + my_strlcat(ret, "\"", sizeof(ret)); + my_strlcat(ret, locale, sizeof(ret)); + my_strlcat(ret, "\"", sizeof(ret)); } else { - strcat(ret, "NULL"); + my_strlcat(ret, "NULL", sizeof(ret)); } - strcat(ret, ") returned "); + my_strlcat(ret, ") returned ", sizeof(ret)); if (retval) { - strcat(ret, "\""); - strcat(ret, retval); - strcat(ret, "\""); + my_strlcat(ret, "\"", sizeof(ret)); + my_strlcat(ret, retval, sizeof(ret)); + my_strlcat(ret, "\"", sizeof(ret)); } else { - strcat(ret, "NULL"); + my_strlcat(ret, "NULL", sizeof(ret)); } assert(strlen(ret) < sizeof(ret));