sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
else
PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
- if (! is_ascii_string((U8 *) lc->decimal_point, 0)
+ if (! is_invariant_string((U8 *) lc->decimal_point, 0)
&& is_utf8_string((U8 *) lc->decimal_point, 0)
&& _is_cur_LC_category_utf8(LC_NUMERIC))
{
* dot.
*
* This sets several interpreter-level variables:
- * PL_numeric_name The default locale's name: a copy of 'newnum'
+ * PL_numeric_name The underlying locale's name: a copy of 'newnum'
* PL_numeric_local A boolean indicating if the toggled state is such
* that the current locale is the program's underlying
* locale
Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
}
else {
+ /* Assume enough space for every character being bad. 4 spaces each
+ * for the 94 printable characters that are output like "'x' "; and 5
+ * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
+ * NUL */
+ char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ];
+
+ bool check_for_problems = ckWARN_d(WARN_LOCALE); /* No warnings means
+ no check */
+ bool multi_byte_locale = FALSE; /* Assume is a single-byte locale
+ to start */
+ unsigned int bad_count = 0; /* Count of bad characters */
+
for (i = 0; i < 256; i++) {
if (isUPPER_LC((U8) i))
PL_fold_locale[i] = (U8) toLOWER_LC((U8) i);
PL_fold_locale[i] = (U8) toUPPER_LC((U8) i);
else
PL_fold_locale[i] = (U8) i;
+
+ /* If checking for locale problems, see if the native ASCII-range
+ * printables plus \n and \t are in their expected categories in
+ * the new locale. If not, this could mean big trouble, upending
+ * Perl's and most programs' assumptions, like having a
+ * metacharacter with special meaning become a \w. Fortunately,
+ * it's very rare to find locales that aren't supersets of ASCII
+ * 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
+ && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
+ {
+ if ((isALPHANUMERIC_A(i) && ! isALPHANUMERIC_LC(i))
+ || (isPUNCT_A(i) && ! isPUNCT_LC(i))
+ || (isBLANK_A(i) && ! isBLANK_LC(i))
+ || (i == '\n' && ! isCNTRL_LC(i)))
+ {
+ if (bad_count) { /* Separate multiple entries with a
+ blank */
+ bad_chars_list[bad_count++] = ' ';
+ }
+ bad_chars_list[bad_count++] = '\'';
+ if (isPRINT_A(i)) {
+ bad_chars_list[bad_count++] = (char) i;
+ }
+ else {
+ bad_chars_list[bad_count++] = '\\';
+ if (i == '\n') {
+ bad_chars_list[bad_count++] = 'n';
+ }
+ else {
+ assert(i == '\t');
+ bad_chars_list[bad_count++] = 't';
+ }
+ }
+ bad_chars_list[bad_count++] = '\'';
+ bad_chars_list[bad_count] = '\0';
+ }
+ }
+ }
+
+#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
+ * problems. */
+ if (check_for_problems && MB_CUR_MAX > 1) {
+ multi_byte_locale = TRUE;
+ }
+#endif
+
+ if (bad_count || multi_byte_locale) {
+
+ /* We have to save 'newctype' because the setlocale() just below
+ * may destroy it. The next setlocale() further down should
+ * restore it properly so that the intermediate change here is
+ * transparent to this function's caller */
+ const char * const badlocale = savepv(newctype);
+
+ setlocale(LC_CTYPE, "C");
+ Perl_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Locale '%s' may not work well.%s%s%s\n",
+ badlocale,
+ (multi_byte_locale)
+ ? " Some characters in it are not recognized by"
+ " Perl."
+ : "",
+ (bad_count)
+ ? "\nThe following characters (and maybe others)"
+ " may not have the same meaning as the Perl"
+ " program expects:\n"
+ : "",
+ (bad_count)
+ ? bad_chars_list
+ : ""
+ );
+ setlocale(LC_CTYPE, badlocale);
}
}
char *p;
const bool locwarn = (printwarn > 1 ||
(printwarn &&
- (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) ||
+ grok_atou(p, NULL))));
bool done = FALSE;
#ifdef WIN32
/* In some systems you can find out the system default locale
/* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
* otherwise. 'category' may not be LC_ALL. If the platform doesn't have
* nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
- * could give the wrong result. It errs on the side of not being a UTF-8
- * locale. */
+ * could give the wrong result. The result will very likely be correct for
+ * languages that have commonly used non-ASCII characters, but for notably
+ * English, it comes down to if the locale's name ends in something like
+ * "UTF-8". It errs on the side of not being a UTF-8 locale. */
char *save_input_locale = NULL;
STRLEN final_pos;
* result */
if (is_utf8) {
wchar_t wc;
- GCC_DIAG_IGNORE(-Wunused-result);
- (void) mbtowc(&wc, NULL, 0); /* Reset any shift state */
- GCC_DIAG_RESTORE;
+ PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
errno = 0;
if ((size_t)mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8))
!= strlen(HYPHEN_UTF8)
|| wc != (wchar_t) 0x2010)
{
is_utf8 = FALSE;
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\thyphen=U+%x\n", wc));
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "\thyphen=U+%x\n", (unsigned int)wc));
DEBUG_L(PerlIO_printf(Perl_debug_log,
"\treturn from mbtowc=%d; errno=%d; ?UTF8 locale=0\n",
mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8)), errno));
* currency symbol to see if it disambiguates things. Often that will be
* in the native script, and if the symbol isn't in UTF-8, we know that the
* locale isn't. If it is non-ASCII UTF-8, we infer that the locale is
- * too. */
+ * too, as the odds of a non-UTF8 string being valid UTF-8 are quite small
+ * */
#ifdef HAS_LOCALECONV
# ifdef USE_LOCALE_MONETARY
lc = localeconv();
if (! lc
|| ! lc->currency_symbol
- || is_ascii_string((U8 *) lc->currency_symbol, 0))
+ || is_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;
/* Here the current LC_TIME is set to the locale of the category
* whose information is desired. Look at all the days of the week and
- * month names, and the timezone and am/pm indicator for non-ASCII
+ * month names, and the timezone and am/pm indicator for UTF-8 variant
* characters. The first such a one found will tell us if the locale
* is UTF-8 or not */
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_ascii_string((U8 *) formatted_time, 0)) {
+ if (! formatted_time || is_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_ascii_string((U8 *) errmsg, 0)) {
+ if (! is_invariant_string((U8 *) errmsg, 0)) {
non_ascii = TRUE;
is_utf8 = is_utf8_string((U8 *) errmsg, 0);
break;
#endif /* the code that is compiled when no nl_langinfo */
+#ifndef EBCDIC /* On os390, even if the name ends with "UTF-8', it isn't a
+ UTF-8 locale */
/* As a last resort, look at the locale name to see if it matches
* qr/UTF -? * 8 /ix, or some other common locale names. This "name", the
* return of setlocale(), is actually defined to be opaque, so we can't
while ((name += strcspn(name, "Uu") + 1)
<= save_input_locale + final_pos - 2)
{
- if (toFOLD(*(name)) != 't'
- || toFOLD(*(name + 1)) != 'f')
+ if (!isALPHA_FOLD_NE(*name, 't')
+ || isALPHA_FOLD_NE(*(name + 1), 'f'))
{
continue;
}
"Locale %s doesn't end with UTF-8 in name\n",
save_input_locale));
}
+#endif
#ifdef WIN32
/* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
}
/*
+
+=head1 Locale-related functions and macros
+
+=for apidoc sync_locale
+
+Changing the program's locale should be avoided by XS code. Nevertheless,
+certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
+happens, Perl needs to be told that the locale has changed. Use this function
+to do so, before returning to Perl.
+
+=cut
+*/
+
+void
+Perl_sync_locale(pTHX)
+{
+
+#ifdef USE_LOCALE_CTYPE
+ new_ctype(setlocale(LC_CTYPE, NULL));
+#endif /* USE_LOCALE_CTYPE */
+
+#ifdef USE_LOCALE_COLLATE
+ new_collate(setlocale(LC_COLLATE, NULL));
+#endif
+
+#ifdef USE_LOCALE_NUMERIC
+ set_numeric_local(); /* Switch from "C" to underlying LC_NUMERIC */
+ new_numeric(setlocale(LC_NUMERIC, NULL));
+#endif /* USE_LOCALE_NUMERIC */
+
+}
+
+
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
https://perl5.git.perl.org / perl5.git / blobdiff