* 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"
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 */
}
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
#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
* 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) {
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);
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)
* 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.
*/
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;
}
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;
setlocale(LC_MESSAGES, save_locale);
Safefree(save_locale);
+
+ LOCALE_UNLOCK;
+
return errstr;
}
+
+ LOCALE_UNLOCK;
}
#endif
/* 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));