#endif
-void
-Perl_set_numeric_radix(pTHX)
+STATIC void
+S_set_numeric_radix(pTHX)
{
#ifdef USE_LOCALE_NUMERIC
# ifdef HAS_LOCALECONV
/*
* Set up for a new ctype locale.
*/
-void
-Perl_new_ctype(pTHX_ const char *newctype)
+STATIC void
+S_new_ctype(pTHX_ const char *newctype)
{
#ifdef USE_LOCALE_CTYPE
/* 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. */
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: check_for_problems=%d, MB_CUR_MAX=%d\n",
+ __FILE__, __LINE__, check_for_problems, (int) MB_CUR_MAX));
+
if (check_for_problems && MB_CUR_MAX > 1
/* Some platforms return MB_CUR_MAX > 1 for even the "C"
: ""
);
/* If we are actually in the scope of the locale or are debugging,
- * 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.
- * */
+ * 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
/* 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;
+ }
}
}
}
}
-void
-Perl_new_collate(pTHX_ const char *newcoll)
+STATIC void
+S_new_collate(pTHX_ const char *newcoll)
{
#ifdef USE_LOCALE_COLLATE
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
#endif /* USE_LOCALE_COLLATE */
}
-#ifdef WIN32
+#ifndef WIN32 /* No wrapper except on Windows */
-char *
-Perl_my_setlocale(pTHX_ int category, const char* locale)
+#define my_setlocale(a,b) setlocale(a,b)
+
+#else /* WIN32 */
+
+STATIC char *
+S_my_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
result = setlocale(category, locale);
DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(category, locale, result)));
+ setlocale_debug_string(category, locale, result)));
if (! override_LC_ALL) {
return result;
setlocale(LC_TIME, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_TIME, result, "not captured")));
+ setlocale_debug_string(LC_TIME, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_CTYPE
setlocale(LC_CTYPE, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_CTYPE, result, "not captured")));
+ setlocale_debug_string(LC_CTYPE, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_COLLATE
setlocale(LC_COLLATE, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_COLLATE, result, "not captured")));
+ setlocale_debug_string(LC_COLLATE, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_MONETARY
setlocale(LC_MONETARY, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_MONETARY, result, "not captured")));
+ setlocale_debug_string(LC_MONETARY, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_NUMERIC
setlocale(LC_NUMERIC, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_NUMERIC, result, "not captured")));
+ setlocale_debug_string(LC_NUMERIC, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_MESSAGES
setlocale(LC_MESSAGES, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_MESSAGES, result, "not captured")));
+ setlocale_debug_string(LC_MESSAGES, result, "not captured")));
}
# endif
result = setlocale(LC_ALL, NULL);
DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_ALL, NULL, result)));
+ setlocale_debug_string(LC_ALL, NULL, result)));
return result;
}
#endif
+char *
+Perl_setlocale(int category, const char * locale)
+{
+ /* This wraps POSIX::setlocale() */
+
+ char * retval;
+ dTHX;
+
+
+#ifdef USE_LOCALE_NUMERIC
+
+ /* A NULL locale means only query what the current one is. We
+ * have the LC_NUMERIC name saved, because we are normally switched
+ * into the C locale for it. Switch back so an LC_ALL query will yield
+ * the correct results; all other categories don't require special
+ * handling */
+ if (locale == NULL) {
+ if (category == LC_NUMERIC) {
+ return savepv(PL_numeric_name);
+ }
+
+# ifdef LC_ALL
+
+ else if (category == LC_ALL) {
+ SET_NUMERIC_UNDERLYING();
+ }
+
+# endif
+
+ }
+
+#endif
+
+ retval = my_setlocale(category, locale);
+
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ setlocale_debug_string(category, locale, retval)));
+ if (! retval) {
+ /* Should never happen that a query would return an error, but be
+ * sure and reset to C locale */
+ if (locale == 0) {
+ SET_NUMERIC_STANDARD();
+ }
+ return NULL;
+ }
+
+ /* Save retval since subsequent setlocale() calls may overwrite it. */
+ retval = savepv(retval);
+
+ /* If locale == NULL, we are just querying the state, but may have switched
+ * to NUMERIC_UNDERLYING. Switch back before returning. */
+ if (locale == NULL) {
+ 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
+
+# endif
+
+ newctype = retval;
+ new_ctype(newctype);
+ }
+
+#endif /* USE_LOCALE_CTYPE */
+
+#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 */
+
+#ifdef USE_LOCALE_NUMERIC
+
+ if ( category == LC_NUMERIC
+
+# ifdef LC_ALL
+
+ || category == LC_ALL
+
+# endif
+
+ )
+ {
+ char *newnum;
+
+# ifdef LC_ALL
+
+ 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
+
+ newnum = retval;
+ new_numeric(newnum);
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+
+ }
+
+ return retval;
+
+}
/*
* Initialize locale awareness.
#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) { \
PerlIO_printf(Perl_debug_log, \
"%s:%d: %s\n", \
__FILE__, __LINE__, \
- _setlocale_debug_string(category, \
+ setlocale_debug_string(category, \
locale, \
result)); \
} \
* 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. */
- if (s_strlen < len) {
+ if (s_strlen < len) { /* Only execute if there is an embedded NUL */
char * e = s + len;
char * sans_nuls;
- STRLEN cur_min_char_len;
STRLEN sans_nuls_len;
STRLEN sans_nuls_pos;
int try_non_controls;
-
- /* If we don't know what control character sorts lowest for this
- * locale, find it */
- if (*PL_strxfrm_min_char == '\0') {
+ 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"));
/* Unlikely, but it may be that no control will work to replace
- * NUL, in which case we instead look for any character */
+ * 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++)
char * x; /* j's xfrm plus collation index */
STRLEN x_len; /* length of 'x' */
STRLEN trial_len = 1;
+ char cur_source[] = { '\0', '\0' };
- /* 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 (! try_non_controls && ! isCNTRL_L1(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;
- }
- }
- else if (! try_non_controls && ! isCNTRL_LC(j)) {
+ /* Skip non-controls the first time through the loop. The
+ * controls in a UTF-8 locale are the L1 ones */
+ if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
+ ? ! isCNTRL_L1(j)
+ : ! isCNTRL_LC(j))
+ {
continue;
}
+ /* Create a 1-char string of the current code point */
+ cur_source[0] = (char) j;
+
/* Then transform it */
x = _mem_collxfrm(cur_source, trial_len, &x_len,
- PL_in_utf8_COLLATE_locale);
+ 0 /* The string is not in UTF-8 */);
- /* Ignore any character that didn't successfully transform
+ /* Ignore any character that didn't successfully transform.
* */
if (! x) {
continue;
|| 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];
+ PL_strxfrm_NUL_replacement = j;
cur_min_x = x;
-#ifdef DEBUGGING
- cur_min_cp = j;
-#endif
}
else {
Safefree(x);
}
- } /* end of loop through all bytes */
+ } /* end of loop through all 255 characters */
+ /* Stop looking if found */
if (cur_min_x) {
break;
}
* 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,
DEBUG_L(PerlIO_printf(Perl_debug_log,
"_mem_collxfrm: Replacing embedded NULs in locale %s with "
- "0x%02X\n", PL_collation_name, cur_min_cp));
+ "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);
- sans_nuls_len = (len * cur_min_char_len) + 1;
+ sans_nuls_len = (len * this_replacement_len) + 1;
Newx(sans_nuls, sans_nuls_len, char);
*sans_nuls = '\0';
sans_nuls_pos = 0;
/* Do the actual replacement */
sans_nuls_pos = my_strlcat(sans_nuls + sans_nuls_pos,
- PL_strxfrm_min_char,
+ this_replacement_char,
sans_nuls_len);
/* Move past the input NUL */
/* 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) {
for (j = 1; j < 256; j++) {
char * x;
STRLEN x_len;
+ char cur_source[] = { '\0', '\0' };
- /* Create a 1-char string of the current code point. */
- char cur_source[] = { (char) j, '\0' };
+ /* Create a 1-char string of the current code point */
+ cur_source[0] = (char) j;
/* Then transform it */
x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
{
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
#ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- 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]);
- }
- PerlIO_printf(Perl_debug_log, "\n");
+ PerlIO_printf(Perl_debug_log, "%s\n",
+ _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
+ *xlen, 1));
}
#endif
#ifdef DEBUGGING
-void
+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[%d]: returning ",
- PL_collation_ix);
+ PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
+ (UV)PL_collation_ix);
if (xlen) {
- PerlIO_printf(Perl_debug_log, "%"UVuf"", (UV) *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);
+ print_bytes_for_locale(s, e, is_utf8);
+
+ PerlIO_printf(Perl_debug_log, "'\n");
+}
+
+STATIC void
+S_print_bytes_for_locale(pTHX_
+ const char * const s,
+ const char * const e,
+ const bool is_utf8)
+{
+ const char * t = s;
+ bool prev_was_printable = TRUE;
+ bool first_time = TRUE;
+
+ PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
while (t < e) {
UV cp = (is_utf8)
if (! first_time) {
PerlIO_printf(Perl_debug_log, " ");
}
- PerlIO_printf(Perl_debug_log, "%02"UVXf"", cp);
+ 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 */
dVAR;
# ifdef USE_THREAD_SAFE_LOCALE
- locale_t save_locale;
+ locale_t save_locale = NULL;
# else
- char * save_locale;
+ char * save_locale = NULL;
bool locale_is_C = FALSE;
/* We have a critical section to prevent another thread from changing the
# endif
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "my_strerror called with errnum %d\n", errnum));
if (! within_locale_scope) {
errno = 0;
# ifdef USE_THREAD_SAFE_LOCALE /* Use the thread-safe locale functions */
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "Not within locale scope, about to call"
+ " uselocale(0x%p)\n", PL_C_locale_obj));
save_locale = uselocale(PL_C_locale_obj);
if (! save_locale) {
DEBUG_L(PerlIO_printf(Perl_debug_log,
- "uselocale failed, errno=%d\n", errno));
+ "uselocale failed, errno=%d\n", errno));
+ }
+ else {
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "uselocale returned 0x%p\n", save_locale));
}
# else /* Not thread-safe build */
# endif
} /* end of ! within_locale_scope */
+ else {
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
+ __FILE__, __LINE__));
+ }
#endif
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "Any locale change has been done; about to call Strerror\n"));
errstr = Strerror(errnum);
if (errstr) {
+
+#ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST) {
+ PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
+ print_bytes_for_locale(errstr, errstr + strlen(errstr), 0);
+ PerlIO_printf(Perl_debug_log, "'\n");
+ }
+
+#endif
+
errstr = savepv(errstr);
SAVEFREEPV(errstr);
}
# ifdef USE_THREAD_SAFE_LOCALE
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s: %d: not within locale scope, restoring the locale\n",
+ __FILE__, __LINE__));
if (save_locale && ! uselocale(save_locale)) {
DEBUG_L(PerlIO_printf(Perl_debug_log,
"uselocale restore failed, errno=%d\n", errno));
#if defined(DEBUGGING) && defined(USE_LOCALE)
-char *
-Perl__setlocale_debug_string(const int category, /* category number,
+STATIC char *
+S_setlocale_debug_string(const int category, /* category number,
like LC_ALL */
const char* const locale, /* locale name */
https://perl5.git.perl.org / perl5.git / blobdiff