# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
#endif
+
+/* Returns the Unix errno portion; ignoring any others. This is a macro here
+ * instead of putting it into perl.h, because unclear to khw what should be
+ * done generally. */
+#define GET_ERRNO saved_errno
+
/* strlen() of a literal string constant. We might want this more general,
* but using it in just this file for now. A problem with more generality is
* the compiler warnings about comparing unlike signs */
* that tofold() is tolc() since fold case is not a concept in POSIX,
*
* 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
+ * Perl_setlocale or POSIX::setlocale, which call this function. Therefore
+ * this function should be called directly only from this file and from
* POSIX::setlocale() */
dVAR;
);
}
+# ifdef HAS_NL_LANGINFO
+
+ Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
+ /* parameter FALSE is a don't care here */
+ my_nl_langinfo(PERL_CODESET, FALSE));
+
+# endif
+
Perl_sv_catpvf(aTHX_ PL_warn_locale, "\n");
/* If we are actually in the scope of the locale or are debugging,
}
result = setlocale(category, locale);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
- setlocale_debug_string(category, locale, result)));
+ DEBUG_L(STMT_START {
+ dSAVE_ERRNO;
+ PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
+ setlocale_debug_string(category, locale, result));
+ RESTORE_ERRNO;
+ } STMT_END);
if (! override_LC_ALL) {
return result;
}
result = setlocale(LC_ALL, NULL);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
+ DEBUG_L(STMT_START {
+ dSAVE_ERRNO;
+ 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));
+ RESTORE_ERRNO;
+ } STMT_END);
return result;
}
#endif
-char *
-Perl_setlocale(int category, const char * locale)
+/*
+
+=head1 Locale-related functions and macros
+
+=for apidoc Perl_setlocale
+
+This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
+taking the same parameters, and returning the same information, except that it
+returns the correct underlying C<LC_NUMERIC> locale, instead of C<C> always, as
+perl keeps that locale category as C<C>, changing it briefly during the
+operations where the underlying one is required.
+
+The other reason it isn't completely a drop-in replacement is that it is
+declared to return S<C<const char *>>, whereas the system setlocale omits the
+C<const>. (If it were being written today, plain setlocale would be declared
+const, since it is illegal to change the information it returns; doing so leads
+to segfaults.)
+
+C<Perl_setlocale> should not be used to change the locale except on systems
+where the predefined variable C<${^SAFE_LOCALES}> is 1.
+
+The return points to a per-thread static buffer, which is overwritten the next
+time C<Perl_setlocale> is called from the same thread.
+
+=cut
+
+*/
+
+const char *
+Perl_setlocale(const int category, const char * locale)
{
/* This wraps POSIX::setlocale() */
- char * retval;
- char * newlocale;
+ const char * retval;
+ const char * newlocale;
+ dSAVEDERRNO;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
dTHX;
#ifdef USE_LOCALE_NUMERIC
* results. All other categories don't require special handling */
if (locale == NULL) {
if (category == LC_NUMERIC) {
- return savepv(PL_numeric_name);
+
+ /* We don't have to copy this return value, as it is a per-thread
+ * variable, and won't change until a future setlocale */
+ return PL_numeric_name;
}
# ifdef LC_ALL
- else if (category == LC_ALL && ! PL_numeric_underlying) {
-
- SET_NUMERIC_UNDERLYING();
+ else if (category == LC_ALL) {
+ STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
}
# endif
#endif
- /* Save retval since subsequent setlocale() calls may overwrite it. */
- retval = savepv(do_setlocale_r(category, locale));
+ retval = do_setlocale_r(category, locale);
+ SAVE_ERRNO;
+
+#if defined(USE_LOCALE_NUMERIC) && defined(LC_ALL)
+
+ if (locale == NULL && category == LC_ALL) {
+ RESTORE_LC_NUMERIC();
+ }
+
+#endif
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();
- }
+ RESTORE_ERRNO;
+
+ if (! retval) {
return NULL;
}
- /* If locale == NULL, we are just querying the state, but may have switched
- * to NUMERIC_UNDERLYING. Switch back before returning. */
+ save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
+ retval = PL_setlocale_buf;
+
+ /* If locale == NULL, we are just querying the state */
if (locale == NULL) {
- SET_NUMERIC_STANDARD();
return retval;
}
return retval;
-
}
PERL_STATIC_INLINE const char *
/*
-=head1 Locale-related functions and macros
-
=for apidoc Perl_langinfo
This is an (almost ยช) drop-in replacement for the system C<L<nl_langinfo(3)>>,
C<strftime()> versions have additional capabilities; C<""> is returned for
those not available on your system.
+It is important to note that on such systems, this calls C<localeconv>, and so
+overwrites the static buffer returned from previous explicit calls to that
+function. Thus, if the program doesn't use or save the information from an
+explicit C<localeconv> call (which good practice suggests should be done
+anyway), use of this function can break it.
+
The details for those items which may differ from what this emulation returns
and what a native C<nl_langinfo()> would return are:
/* Standard UTF-8 needs at least 4 bytes to represent the maximum
* Unicode code point. */
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\tMB_CUR_MAX=%d\n",
- (int) MB_CUR_MAX));
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "%s: %d: MB_CUR_MAX=%d\n",
+ __FILE__, __LINE__, (int) MB_CUR_MAX));
if ((unsigned) MB_CUR_MAX < STRLENs(MAX_UNICODE_UTF8)) {
is_utf8 = FALSE;
restore_switched_locale(LC_CTYPE, original_ctype_locale);
const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE);
/* FALSE => already in dest locale */
- DEBUG_L(PerlIO_printf(Perl_debug_log,
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"\tnllanginfo returned CODESET '%s'\n", codeset));
if (codeset && strNE(codeset, "")) {
{
wchar_t wc;
int len;
+ dSAVEDERRNO;
# if defined(HAS_MBRTOWC) && defined(USE_ITHREADS)
memset(&ps, 0, sizeof(ps));;
PERL_UNUSED_RESULT(mbrtowc(&wc, NULL, 0, &ps)); /* Reset any shift
state */
- errno = 0;
+ SETERRNO(0, 0);
len = mbrtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8), &ps);
+ SAVE_ERRNO;
# else
+ LOCALE_LOCK;
PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
- errno = 0;
+ SETERRNO(0, 0);
len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
+ SAVE_ERRNO;
+ LOCALE_UNLOCK;
# endif
- DEBUG_L(PerlIO_printf(Perl_debug_log,
+ RESTORE_ERRNO;
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"\treturn from mbtowc; len=%d; code_point=%x; errno=%d\n",
- len, (unsigned int) wc, errno));
+ len, (unsigned int) wc, GET_ERRNO));
is_utf8 = cBOOL( len == STRLENs(REPLACEMENT_CHARACTER_UTF8)
&& wc == (wchar_t) UNICODE_REPLACEMENT);
/* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
* otherwise assume the locale is UTF-8 if and only if the symbol
* is non-ascii UTF-8. */
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
save_input_locale, is_utf8));
goto finish_and_return;
}
* locale if we changed it */
restore_switched_locale(LC_TIME, original_time_locale);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
save_input_locale,
is_utf8_string((U8 *) formatted_time, 0)));
is_utf8 = is_utf8_string((U8 *) formatted_time, 0);
* ASCII. Go on to the next test. If we changed it, restore LC_TIME
* to its original locale */
restore_switched_locale(LC_TIME, original_time_locale);
- DEBUG_L(PerlIO_printf(Perl_debug_log, "All time-related words for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "All time-related words for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
}
# endif
/* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
* any non-ascii means it is one; otherwise we assume it isn't */
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
save_input_locale,
is_utf8));
goto finish_and_return;
# ifdef DEBUGGING
+ if (DEBUG_Lv_TEST) {
+ const char * s = PL_locale_utf8ness;
+
+ /* Audit the structure */
+ while (s < PL_locale_utf8ness + strlen(PL_locale_utf8ness)) {
+ const char *e;
+
+ if (*s != UTF8NESS_SEP[0]) {
+ Perl_croak(aTHX_
+ "panic: %s: %d: Corrupt utf8ness_cache: missing"
+ " separator %.*s<-- HERE %s\n",
+ __FILE__, __LINE__,
+ (int) (s - PL_locale_utf8ness), PL_locale_utf8ness,
+ s);
+ }
+ s++;
+ e = strchr(s, UTF8NESS_PREFIX[0]);
+ if (! e) {
+ Perl_croak(aTHX_
+ "panic: %s: %d: Corrupt utf8ness_cache: missing"
+ " separator %.*s<-- HERE %s\n",
+ __FILE__, __LINE__,
+ (int) (e - PL_locale_utf8ness), PL_locale_utf8ness,
+ e);
+ }
+ e++;
+ if (*e != '0' && *e != '1') {
+ Perl_croak(aTHX_
+ "panic: %s: %d: Corrupt utf8ness_cache: utf8ness"
+ " must be [01] %.*s<-- HERE %s\n",
+ __FILE__, __LINE__,
+ (int) (e + 1 - PL_locale_utf8ness),
+ PL_locale_utf8ness, e + 1);
+ }
+ if (ninstr(PL_locale_utf8ness, s, s-1, e)) {
+ Perl_croak(aTHX_
+ "panic: %s: %d: Corrupt utf8ness_cache: entry"
+ " has duplicate %.*s<-- HERE %s\n",
+ __FILE__, __LINE__,
+ (int) (e - PL_locale_utf8ness), PL_locale_utf8ness,
+ e);
+ }
+ s = e + 1;
+ }
+ }
+
if (DEBUG_Lv_TEST || debug_initialization) {
+
PerlIO_printf(Perl_debug_log,
"PL_locale_utf8ness is now %s; returning %d\n",
PL_locale_utf8ness, is_utf8);
https://perl5.git.perl.org / perl5.git / blobdiff