sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
else
PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
- if (! is_invariant_string((U8 *) lc->decimal_point, 0)
+ if (! is_utf8_invariant_string((U8 *) lc->decimal_point, 0)
&& is_utf8_string((U8 *) lc->decimal_point, 0)
&& _is_cur_LC_category_utf8(LC_NUMERIC))
{
* NUL */
char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ];
- bool check_for_problems = ckWARN_d(WARN_LOCALE); /* No warnings means
- no check */
+ /* Don't check for problems if we are suppressing the warnings */
+ bool check_for_problems = ckWARN_d(WARN_LOCALE)
+ || UNLIKELY(DEBUG_L_TEST);
bool multi_byte_locale = FALSE; /* Assume is a single-byte locale
to start */
unsigned int bad_count = 0; /* Count of bad characters */
? bad_chars_list
: ""
);
- /* If we are actually in the scope of the locale, output the
- * message now. Otherwise we save it to be output at the first
- * operation using this locale, if that actually happens. Most
- * programs don't use locales, so they are immune to bad ones */
- if (IN_LC(LC_CTYPE)) {
+ /* If we are actually in the scope of the locale or are debugging,
+ * output the message now. If not in that scope, we save the
+ * message to be output at the first operation using this locale,
+ * if that actually happens. Most programs don't use locales, so
+ * they are immune to bad ones. */
+ if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
/* We have to save 'newctype' because the setlocale() just
* below may destroy it. The next setlocale() further down
/* The '0' below suppresses a bogus gcc compiler warning */
Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale), 0);
+
setlocale(LC_CTYPE, badlocale);
Safefree(badlocale);
- SvREFCNT_dec_NN(PL_warn_locale);
- PL_warn_locale = NULL;
+
+ if (IN_LC(LC_CTYPE)) {
+ SvREFCNT_dec_NN(PL_warn_locale);
+ PL_warn_locale = NULL;
+ }
}
}
}
PL_collxfrm_base = 0;
PL_collxfrm_mult = 2;
PL_in_utf8_COLLATE_locale = FALSE;
- *PL_strxfrm_min_char = '\0';
+ PL_strxfrm_NUL_replacement = '\0';
PL_strxfrm_max_cp = 0;
return;
}
}
PL_in_utf8_COLLATE_locale = _is_cur_LC_category_utf8(LC_COLLATE);
- *PL_strxfrm_min_char = '\0';
+ PL_strxfrm_NUL_replacement = '\0';
PL_strxfrm_max_cp = 0;
/* A locale collation definition includes primary, secondary, tertiary,
* This has the desired effect that strcmp() will look at the secondary
* or tertiary weights only if the strings compare equal at all higher
* priority weights. The spaces shown here, like in
- * "A¹B¹C¹ * A²B²C² "
+ * "A¹B¹C¹ A²B²C² "
* are not just for readability. In the general case, these must
* actually be bytes, which we will call here 'separator weights'; and
* they must be smaller than any other weight value, but since these
#ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
- "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%"UVuf", "
- "x_len_longer=%"UVuf","
- " collate multipler=%"UVuf", collate base=%"UVuf"\n",
+ "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, "
+ "x_len_longer=%zu,"
+ " collate multipler=%zu, collate base=%zu\n",
__FILE__, __LINE__,
PL_in_utf8_COLLATE_locale,
x_len_shorter, x_len_longer,
#endif
#ifdef DEBUGGING
- DEBUG_INITIALIZATION_set((PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))
- ? TRUE
- : FALSE);
+ DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
# define DEBUG_LOCALE_INIT(category, locale, result) \
STMT_START { \
if (debug_initialization) { \
: NULL;
sl_result = my_setlocale(LC_MESSAGES, locale_param);
DEBUG_LOCALE_INIT(LC_MESSAGES, locale_param, sl_result);
- if (! sl_result)
+ if (! sl_result) {
setlocale_failure = TRUE;
}
# endif /* USE_LOCALE_MESSAGES */
{
char **e;
for (e = environ; *e; e++) {
- if (strnEQ(*e, "LC_", 3)
- && strnNE(*e, "LC_ALL=", 7)
+ if (strEQs(*e, "LC_")
+ && strNEs(*e, "LC_ALL=")
&& (p = strchr(*e, '=')))
PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
(int)(p - *e), *e, p + 1);
/* If this locale has defective collation, skip */
if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: locale's collation is defective\n"));
goto bad;
}
* This will give as good as possible results on strings that don't
* otherwise contain that character, but otherwise there may be
* less-than-perfect results with that character and NUL. This is
- * unavoidable unless we replace strxfrm with our own implementation.
- *
- * XXX This code may be overkill. khw wrote it before realizing that if
- * you change a NUL into some other character, that that may change the
- * strxfrm results if that character is part of a sequence with other
- * characters for weight calculations. To minimize the chances of this,
- * now the replacement is restricted to another control (likely to be
- * \001). But the full generality has been retained.
- *
- * This is one of the few places in the perl core, where we can use
- * standard functions like strlen() and strcat(). It's because we're
- * looking for NULs. */
- if (s_strlen < len) {
+ * unavoidable unless we replace strxfrm with our own implementation. */
+ if (s_strlen < len) { /* Only execute if there is an embedded NUL */
char * e = s + len;
char * sans_nuls;
- STRLEN cur_min_char_len;
-
- /* If we don't know what control character sorts lowest for this
- * locale, find it */
- if (*PL_strxfrm_min_char == '\0') {
+ STRLEN sans_nuls_len;
+ STRLEN sans_nuls_pos;
+ int try_non_controls;
+ char this_replacement_char[] = "?\0"; /* Room for a two-byte string,
+ making sure 2nd byte is NUL.
+ */
+ STRLEN this_replacement_len;
+
+ /* If we don't know what non-NUL control character sorts lowest for
+ * this locale, find it */
+ if (PL_strxfrm_NUL_replacement == '\0') {
int j;
-#ifdef DEBUGGING
- U8 cur_min_cp = 1; /* The code point that sorts lowest, so far */
-#endif
- char * cur_min_x = NULL; /* And its xfrm, (except it also
+ char * cur_min_x = NULL; /* The min_char's xfrm, (except it also
includes the collation index
prefixed. */
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
- /* Look through all legal code points (NUL isn't) */
- for (j = 1; j < 256; j++) {
- char * x; /* j's xfrm plus collation index */
- STRLEN x_len; /* length of 'x' */
- STRLEN trial_len = 1;
-
- /* Create a 1 byte string of the current code point, but with
- * room to be 2 bytes */
- char cur_source[] = { (char) j, '\0' , '\0' };
-
- if (PL_in_utf8_COLLATE_locale) {
- if (! isCNTRL_L1(j)) {
+
+ /* Unlikely, but it may be that no control will work to replace
+ * NUL, in which case we instead look for any character. Controls
+ * are preferred because collation order is, in general, context
+ * sensitive, with adjoining characters affecting the order, and
+ * controls are less likely to have such interactions, allowing the
+ * NUL-replacement to stand on its own. (Another way to look at it
+ * is to imagine what would happen if the NUL were replaced by a
+ * combining character; it wouldn't work out all that well.) */
+ for (try_non_controls = 0;
+ try_non_controls < 2;
+ try_non_controls++)
+ {
+ /* Look through all legal code points (NUL isn't) */
+ for (j = 1; j < 256; j++) {
+ char * x; /* j's xfrm plus collation index */
+ STRLEN x_len; /* length of 'x' */
+ STRLEN trial_len = 1;
+
+ /* Create a 1 byte string of the current code point */
+ char cur_source[] = { (char) j, '\0' };
+
+ if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
+ ? ! isCNTRL_L1(j)
+ : ! isCNTRL_LC(j))
+ {
continue;
}
- /* If needs to be 2 bytes, find them */
- if (! UVCHR_IS_INVARIANT(j)) {
- char * d = cur_source;
- append_utf8_from_native_byte((U8) j, (U8 **) &d);
- trial_len = 2;
+ /* Then transform it */
+ x = _mem_collxfrm(cur_source, trial_len, &x_len,
+ 0 /* The string is not in UTF-8 */);
+
+ /* Ignore any character that didn't successfully transform.
+ * */
+ if (! x) {
+ continue;
}
- }
- else if (! isCNTRL_LC(j)) {
- continue;
- }
- /* Then transform it */
- x = _mem_collxfrm(cur_source, trial_len, &x_len,
- PL_in_utf8_COLLATE_locale);
+ /* If this character's transformation is lower than
+ * the current lowest, this one becomes the lowest */
+ if ( cur_min_x == NULL
+ || strLT(x + COLLXFRM_HDR_LEN,
+ cur_min_x + COLLXFRM_HDR_LEN))
+ {
+ PL_strxfrm_NUL_replacement = j;
+ cur_min_x = x;
+ }
+ else {
+ Safefree(x);
+ }
+ } /* end of loop through all 255 characters */
- /* If something went wrong (which it shouldn't), just
- * ignore this code point */
- if ( x_len == 0
- || strlen(x + COLLXFRM_HDR_LEN) < x_len)
- {
- continue;
+ /* Stop looking if found */
+ if (cur_min_x) {
+ break;
}
- /* If this character's transformation is lower than
- * the current lowest, this one becomes the lowest */
- if ( cur_min_x == NULL
- || strLT(x + COLLXFRM_HDR_LEN,
- cur_min_x + COLLXFRM_HDR_LEN))
- {
- PL_strxfrm_min_char[0] = cur_source[0];
- PL_strxfrm_min_char[1] = cur_source[1];
- PL_strxfrm_min_char[2] = cur_source[2];
- cur_min_x = x;
-#ifdef DEBUGGING
- cur_min_cp = j;
-#endif
- }
- else {
- Safefree(x);
- }
- } /* end of loop through all bytes */
-
- /* Unlikely, but possible, if there aren't any controls in the
- * locale, arbitrarily use \001 */
- if (cur_min_x == NULL) {
- STRLEN x_len; /* temporary */
- cur_min_x = _mem_collxfrm("\001", 1, &x_len,
- PL_in_utf8_COLLATE_locale);
- /* cur_min_cp was already initialized to 1 */
+ /* Unlikely, but possible, if there aren't any controls that
+ * work in the locale, repeat the loop, looking for any
+ * character that works */
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: No control worked. Trying non-controls\n"));
+ } /* End of loop to try first the controls, then any char */
+
+ if (! cur_min_x) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't find any character to replace"
+ " embedded NULs in locale %s with", PL_collation_name));
+ goto bad;
}
DEBUG_L(PerlIO_printf(Perl_debug_log,
- "_mem_collxfrm: lowest collating non-NUL control in the "
- "0-255 range in locale %s is 0x%02X\n",
- PL_collation_name,
- cur_min_cp));
- if (DEBUG_Lv_TEST) {
- unsigned i;
- PerlIO_printf(Perl_debug_log, "Its xfrm is");
- for (i = 0; i < strlen(cur_min_x + COLLXFRM_HDR_LEN); i ++) {
- PerlIO_printf(Perl_debug_log, " %02x",
- (U8) *(cur_min_x + COLLXFRM_HDR_LEN + i));
- }
- PerlIO_printf(Perl_debug_log, "\n");
- }
+ "_mem_collxfrm: Replacing embedded NULs in locale %s with "
+ "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
Safefree(cur_min_x);
+ } /* End of determining the character that is to replace NULs */
+
+ /* If the replacement is variant under UTF-8, it must match the
+ * UTF8-ness as the original */
+ if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
+ this_replacement_char[0] =
+ UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
+ this_replacement_char[1] =
+ UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
+ this_replacement_len = 2;
+ }
+ else {
+ this_replacement_char[0] = PL_strxfrm_NUL_replacement;
+ /* this_replacement_char[1] = '\0' was done at initialization */
+ this_replacement_len = 1;
}
/* The worst case length for the replaced string would be if every
* character in it is NUL. Multiply that by the length of each
* replacement, and allow for a trailing NUL */
- cur_min_char_len = strlen(PL_strxfrm_min_char);
- Newx(sans_nuls, (len * cur_min_char_len) + 1, char);
+ sans_nuls_len = (len * this_replacement_len) + 1;
+ Newx(sans_nuls, sans_nuls_len, char);
*sans_nuls = '\0';
-
+ sans_nuls_pos = 0;
/* Replace each NUL with the lowest collating control. Loop until have
* exhausted all the NULs */
while (s + s_strlen < e) {
- strcat(sans_nuls, s);
+ sans_nuls_pos = my_strlcat(sans_nuls + sans_nuls_pos,
+ s,
+ sans_nuls_len);
/* Do the actual replacement */
- strcat(sans_nuls, PL_strxfrm_min_char);
+ sans_nuls_pos = my_strlcat(sans_nuls + sans_nuls_pos,
+ this_replacement_char,
+ sans_nuls_len);
/* Move past the input NUL */
s += s_strlen + 1;
}
/* And add anything that trails the final NUL */
- strcat(sans_nuls, s);
+ my_strlcat(sans_nuls + sans_nuls_pos, s, sans_nuls_len);
/* Switch so below we transform this modified string */
s = sans_nuls;
len = strlen(s);
- }
+ } /* End of replacing NULs */
/* Make sure the UTF8ness of the string and locale match */
if (utf8 != PL_in_utf8_COLLATE_locale) {
/* If something went wrong (which it shouldn't), just
* ignore this code point */
- if (x_len == 0) {
- Safefree(x);
+ if (! x) {
continue;
}
}
}
+ if (! cur_max_x) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't find any character to"
+ " replace above-Latin1 chars in locale %s with",
+ PL_collation_name));
+ goto bad;
+ }
+
DEBUG_L(PerlIO_printf(Perl_debug_log,
"_mem_collxfrm: highest 1-byte collating character"
" in locale %s is 0x%02X\n",
PL_collation_name,
PL_strxfrm_max_cp));
- if (DEBUG_Lv_TEST) {
- unsigned i;
- PerlIO_printf(Perl_debug_log, "Its xfrm is ");
- for (i = 0;
- i < strlen(cur_max_x + COLLXFRM_HDR_LEN);
- i++)
- {
- PerlIO_printf(Perl_debug_log, " %02x",
- (U8) cur_max_x[i + COLLXFRM_HDR_LEN]);
- }
- PerlIO_printf(Perl_debug_log, "\n");
- }
Safefree(cur_max_x);
}
{
STRLEN i;
STRLEN d= 0;
+ char * e = (char *) t + len;
for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
U8 cur_char = t[i];
if (UTF8_IS_INVARIANT(cur_char)) {
s[d++] = cur_char;
}
- else if (UTF8_IS_DOWNGRADEABLE_START(cur_char)) {
+ else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
}
else { /* Replace illegal cp with highest collating
+ PL_collxfrm_base
+ (PL_collxfrm_mult * length_in_chars);
Newx(xbuf, xAlloc, char);
- if (UNLIKELY(! xbuf))
+ if (UNLIKELY(! xbuf)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
goto bad;
+ }
/* Store the collation id */
*(U32*)xbuf = PL_collation_ix;
/* Then the transformation of the input. We loop until successful, or we
* give up */
for (;;) {
+
*xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
/* If the transformed string occupies less space than we told strxfrm()
* string. */
if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
+ /* Some systems include a trailing NUL in the returned length.
+ * Ignore it, using a loop in case multiple trailing NULs are
+ * returned. */
+ while ( (*xlen) > 0
+ && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
+ {
+ (*xlen)--;
+ }
+
/* If the first try didn't get it, it means our prediction was low.
* Modify the coefficients so that we predict a larger value in any
* future transformations */
: PL_collxfrm_mult;
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: initial size of %"UVuf" bytes for a length "
- "%"UVuf" string was insufficient, %"UVuf" needed\n",
+ "%s: %d: initial size of %zu bytes for a length "
+ "%zu string was insufficient, %zu needed\n",
__FILE__, __LINE__,
- (UV) computed_guess, (UV) length_in_chars, (UV) needed));
+ computed_guess, length_in_chars, needed));
/* If slope increased, use it, but discard this result for
* length 1 strings, as we can't be sure that it's a real slope
}
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: slope is now %"UVuf"; was %"UVuf", base "
- "is now %"UVuf"; was %"UVuf"\n",
+ "%s: %d: slope is now %zu; was %zu, base "
+ "is now %zu; was %zu\n",
__FILE__, __LINE__,
- (UV) PL_collxfrm_mult, (UV) old_m,
- (UV) PL_collxfrm_base, (UV) old_b));
+ PL_collxfrm_mult, old_m,
+ PL_collxfrm_base, old_b));
}
else { /* Slope didn't change, but 'b' did */
const STRLEN new_b = needed
- computed_guess
+ PL_collxfrm_base;
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: base is now %"UVuf"; was %"UVuf"\n",
+ "%s: %d: base is now %zu; was %zu\n",
__FILE__, __LINE__,
- (UV) new_b, (UV) PL_collxfrm_base));
+ new_b, PL_collxfrm_base));
PL_collxfrm_base = new_b;
}
}
break;
}
- if (UNLIKELY(*xlen >= PERL_INT_MAX))
+ if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
+ *xlen, PERL_INT_MAX));
goto bad;
+ }
/* A well-behaved strxfrm() returns exactly how much space it needs
- * (not including the trailing NUL) when it fails due to not enough
- * space being provided. Assume that this is the case unless it's been
- * proven otherwise */
+ * (usually not including the trailing NUL) when it fails due to not
+ * enough space being provided. Assume that this is the case unless
+ * it's been proven otherwise */
if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
}
* (Many versions of cygwin fit this. When the buffer size
* isn't sufficient, they return the input size instead of
* how much is needed.)
- * Increase the buffer size by a fixed percentage and try again. */
+ * Increase the buffer size by a fixed percentage and try again.
+ * */
xAlloc += (xAlloc / 4) + 1;
PL_strxfrm_is_behaved = FALSE;
if (DEBUG_Lv_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
"_mem_collxfrm required more space than previously calculated"
- " for locale %s, trying again with new guess=%d+%"UVuf"\n",
+ " for locale %s, trying again with new guess=%d+%zu\n",
PL_collation_name, (int) COLLXFRM_HDR_LEN,
- (UV) xAlloc - COLLXFRM_HDR_LEN);
+ xAlloc - COLLXFRM_HDR_LEN);
}
#endif
}
Renew(xbuf, xAlloc, char);
- if (UNLIKELY(! xbuf))
+ if (UNLIKELY(! xbuf)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
goto bad;
+ }
first_time = FALSE;
}
#ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- unsigned i;
- char * t = s;
- bool prev_was_printable = TRUE;
- bool first_time = TRUE;
- PerlIO_printf(Perl_debug_log,
- "_mem_collxfrm[%d]: returning %"UVuf" for locale %s string '",
- PL_collation_ix, *xlen, PL_collation_name);
- while (t < s + len ) {
- UV cp = (utf8)
- ? utf8_to_uvchr_buf((U8 *) t, s + len, NULL)
- : * (U8 *) t;
- if (isPRINT(cp)) {
- if (! prev_was_printable) {
- PerlIO_printf(Perl_debug_log, " ");
- }
- PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
- prev_was_printable = TRUE;
- }
- else {
- if (! first_time) {
- PerlIO_printf(Perl_debug_log, " ");
- }
- PerlIO_printf(Perl_debug_log, "%02"UVXf"", cp);
- prev_was_printable = FALSE;
- }
- t += (utf8) ? UTF8SKIP(t) : 1;
- first_time = FALSE;
- }
- PerlIO_printf(Perl_debug_log, "'\nIts xfrm is");
+ Size_t i;
+
+ print_collxfrm_input_and_return(s, s + len, xlen, utf8);
+ PerlIO_printf(Perl_debug_log, "Its xfrm is:");
for (i = COLLXFRM_HDR_LEN; i < *xlen + COLLXFRM_HDR_LEN; i++) {
PerlIO_printf(Perl_debug_log, " %02x", (U8) xbuf[i]);
}
*xlen = 0;
#ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%d] returning NULL\n",
- PL_collation_ix);
+ print_collxfrm_input_and_return(s, s + len, NULL, utf8);
}
#endif
return NULL;
}
+#ifdef DEBUGGING
+
+STATIC void
+S_print_collxfrm_input_and_return(pTHX_
+ const char * const s,
+ const char * const e,
+ const STRLEN * const xlen,
+ const bool is_utf8)
+{
+ const char * t = s;
+ bool prev_was_printable = TRUE;
+ bool first_time = TRUE;
+
+ PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
+
+ PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%u]: returning ",
+ PL_collation_ix);
+ if (xlen) {
+ PerlIO_printf(Perl_debug_log, "%" UVuf, (UV) *xlen);
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "NULL");
+ }
+ PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
+ PL_collation_name);
+
+ while (t < e) {
+ UV cp = (is_utf8)
+ ? utf8_to_uvchr_buf((U8 *) t, e, NULL)
+ : * (U8 *) t;
+ if (isPRINT(cp)) {
+ if (! prev_was_printable) {
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+ PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
+ prev_was_printable = TRUE;
+ }
+ else {
+ if (! first_time) {
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+ PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
+ prev_was_printable = FALSE;
+ }
+ t += (is_utf8) ? UTF8SKIP(t) : 1;
+ first_time = FALSE;
+ }
+
+ PerlIO_printf(Perl_debug_log, "'\n");
+}
+
+#endif /* #ifdef DEBUGGING */
+
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE
lc = localeconv();
if (! lc
|| ! lc->currency_symbol
- || is_invariant_string((U8 *) lc->currency_symbol, 0))
+ || is_utf8_invariant_string((U8 *) lc->currency_symbol, 0))
{
DEBUG_L(PerlIO_printf(Perl_debug_log, "Couldn't get currency symbol for %s, or contains only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
only_ascii = TRUE;
for (i = 0; i < 7 + 12; i++) { /* 7 days; 12 months */
formatted_time = my_strftime("%A %B %Z %p",
0, 0, hour, dom, month, 112, 0, 0, is_dst);
- if (! formatted_time || is_invariant_string((U8 *) formatted_time, 0)) {
+ if ( ! formatted_time
+ || is_utf8_invariant_string((U8 *) formatted_time, 0))
+ {
/* Here, we didn't find a non-ASCII. Try the next time through
* with the complemented dst and am/pm, and try with the next
break;
}
errmsg = savepv(errmsg);
- if (! is_invariant_string((U8 *) errmsg, 0)) {
+ if (! is_utf8_invariant_string((U8 *) errmsg, 0)) {
non_ascii = TRUE;
is_utf8 = is_utf8_string((U8 *) errmsg, 0);
break;
dVAR;
# ifdef USE_THREAD_SAFE_LOCALE
- locale_t save_locale;
+ locale_t save_locale = NULL;
# else
- char * save_locale;
- bool locale_is_C;
+ char * save_locale = NULL;
+ bool locale_is_C = FALSE;
/* We have a critical section to prevent another thread from changing the
* locale out from under us (or zapping the buffer returned from
# endif
if (! within_locale_scope) {
+ errno = 0;
# ifdef USE_THREAD_SAFE_LOCALE /* Use the thread-safe locale functions */
save_locale = uselocale(PL_C_locale_obj);
+ if (! save_locale) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "uselocale failed, errno=%d\n", errno));
+ }
# else /* Not thread-safe build */
save_locale = setlocale(LC_MESSAGES, NULL);
- locale_is_C = isNAME_C_OR_POSIX(save_locale);
+ if (! save_locale) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "setlocale failed, errno=%d\n", errno));
+ }
+ else {
+ locale_is_C = isNAME_C_OR_POSIX(save_locale);
- /* Switch to the C locale if not already in it */
- if (! locale_is_C) {
+ /* Switch to the C locale if not already in it */
+ if (! locale_is_C) {
- /* The setlocale() just below likely will zap 'save_locale', so
- * create a copy. */
- save_locale = savepv(save_locale);
- setlocale(LC_MESSAGES, "C");
+ /* The setlocale() just below likely will zap 'save_locale', so
+ * create a copy. */
+ save_locale = savepv(save_locale);
+ setlocale(LC_MESSAGES, "C");
+ }
}
# endif
#ifdef USE_LOCALE_MESSAGES
if (! within_locale_scope) {
+ errno = 0;
# ifdef USE_THREAD_SAFE_LOCALE
- uselocale(save_locale);
+ if (save_locale && ! uselocale(save_locale)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "uselocale restore failed, errno=%d\n", errno));
+ }
}
# else
- if (! locale_is_C) {
- setlocale(LC_MESSAGES, save_locale);
+ if (save_locale && ! locale_is_C) {
+ if (! setlocale(LC_MESSAGES, save_locale)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "setlocale restore failed, errno=%d\n", errno));
+ }
Safefree(save_locale);
}
}
/* 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";
-
+ static char ret[128] = "If you can read this, thank your buggy C"
+ " library strlcpy(), and change your hints file"
+ " to undef it";
my_strlcpy(ret, "setlocale(", sizeof(ret));
switch (category) {