# define LC_COLLATE_INDEX _DUMMY_CTYPE + 1
# define _DUMMY_COLLATE LC_COLLATE_INDEX
# else
-# define _DUMMY_COLLATE _DUMMY_COLLATE
+# define _DUMMY_COLLATE _DUMMY_CTYPE
# endif
# ifdef USE_LOCALE_TIME
# define LC_TIME_INDEX _DUMMY_COLLATE + 1
}
- assert(PL_C_locale_obj);
-
- /* Otherwise, we are switching locales. This will generally entail freeing
- * the current one's space (at the C library's discretion). We need to
- * stop using that locale before the switch. So switch to a known locale
- * object that we don't otherwise mess with. This returns the locale
- * object in effect at the time of the switch. */
- old_obj = uselocale(PL_C_locale_obj);
-
-# ifdef DEBUGGING
-
- if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
- }
-
-# endif
-
- if (! old_obj) {
-
-# ifdef DEBUGGING
-
- if (DEBUG_L_TEST || debug_initialization) {
- dSAVE_ERRNO;
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to C failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
- RESTORE_ERRNO;
- }
-
-# endif
-
- return NULL;
- }
-
-# ifdef DEBUGGING
-
- if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, PL_C_locale_obj);
- }
-
-# endif
-
- /* If we weren't in a thread safe locale, set so that newlocale() below
- which uses 'old_obj', uses an empty one. Same for our reserved C object.
- The latter is defensive coding, so that, even if there is some bug, we
- will never end up trying to modify either of these, as if passed to
- newlocale(), they can be. */
- if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
- old_obj = (locale_t) 0;
- }
-
- /* Create the new locale (it may actually modify the current one). */
+ /* Here, we are switching locales. */
# ifndef HAS_QUERYLOCALE
* other platforms do it differently, so we have to handle all cases
* ourselves */
+ unsigned int i;
const char * s = locale;
const char * e = locale + strlen(locale);
const char * p = s;
const char * name_start;
const char * name_end;
+ /* If the string that gives what to set doesn't include all categories,
+ * the omitted ones get set to "C". To get this behavior, first set
+ * all the individual categories to "C", and override the furnished
+ * ones below */
+ for (i = 0; i < LC_ALL_INDEX; i++) {
+ if (! emulate_setlocale(categories[i], "C", i, TRUE)) {
+ return NULL;
+ }
+ }
+
while (s < e) {
- unsigned int i;
/* Parse through the category */
while (isWORDCHAR(*p)) {
ready_to_set: ;
+ /* Here at the end of having to deal with the absence of querylocale().
+ * Some cases have already been fully handled by recursive calls to this
+ * function. But at this point, we haven't dealt with those, but are now
+ * prepared to, knowing what the locale name to set this category to is.
+ * This would have come for free if this system had had querylocale() */
+
# endif /* end of ! querylocale */
+ assert(PL_C_locale_obj);
+
+ /* Switching locales generally entails freeing the current one's space (at
+ * the C library's discretion). We need to stop using that locale before
+ * the switch. So switch to a known locale object that we don't otherwise
+ * mess with. This returns the locale object in effect at the time of the
+ * switch. */
+ old_obj = uselocale(PL_C_locale_obj);
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
+ }
+
+# endif
+
+ if (! old_obj) {
+
+# ifdef DEBUGGING
+
+ if (DEBUG_L_TEST || debug_initialization) {
+ dSAVE_ERRNO;
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to C failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
+ RESTORE_ERRNO;
+ }
+
+# endif
+
+ return NULL;
+ }
+
+# ifdef DEBUGGING
+
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, PL_C_locale_obj);
+ }
+
+# endif
+
+ /* If we weren't in a thread safe locale, set so that newlocale() below
+ which uses 'old_obj', uses an empty one. Same for our reserved C object.
+ The latter is defensive coding, so that, even if there is some bug, we
+ will never end up trying to modify either of these, as if passed to
+ newlocale(), they can be. */
+ if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
+ old_obj = (locale_t) 0;
+ }
+
/* Ready to create a new locale by modification of the exising one */
new_obj = newlocale(mask, locale, old_obj);
# ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p\n", __FILE__, __LINE__, new_obj);
+ PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p; should have freed %p\n", __FILE__, __LINE__, new_obj, old_obj);
}
# endif
}
#endif
+#ifdef USE_LOCALE
STATIC void
S_set_numeric_radix(pTHX_ const bool use_locale)
}
# endif
+#else
+
+ PERL_UNUSED_ARG(use_locale);
+
#endif /* USE_LOCALE_NUMERIC and can find the radix char */
}
* to our records (which could be wrong if some XS code has changed the
* locale behind our back) */
- do_setlocale_c(LC_NUMERIC, "C");
- PL_numeric_standard = TRUE;
- PL_numeric_underlying = PL_numeric_underlying_is_standard;
- set_numeric_radix(0);
-
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
- "LC_NUMERIC locale now is standard C\n");
+ "Setting LC_NUMERIC locale to standard C\n");
}
# endif
+
+ do_setlocale_c(LC_NUMERIC, "C");
+ PL_numeric_standard = TRUE;
+ PL_numeric_underlying = PL_numeric_underlying_is_standard;
+ set_numeric_radix(0);
+
#endif /* USE_LOCALE_NUMERIC */
}
* if toggling isn't necessary according to our records (which could be
* wrong if some XS code has changed the locale behind our back) */
- do_setlocale_c(LC_NUMERIC, PL_numeric_name);
- PL_numeric_standard = PL_numeric_underlying_is_standard;
- PL_numeric_underlying = TRUE;
- set_numeric_radix(! PL_numeric_standard);
-
# ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
- "LC_NUMERIC locale now is %s\n",
+ "Setting LC_NUMERIC locale to %s\n",
PL_numeric_name);
}
# endif
+
+ do_setlocale_c(LC_NUMERIC, PL_numeric_name);
+ PL_numeric_standard = PL_numeric_underlying_is_standard;
+ PL_numeric_underlying = TRUE;
+ set_numeric_radix(! PL_numeric_standard);
+
#endif /* USE_LOCALE_NUMERIC */
}
#ifndef USE_LOCALE_CTYPE
- PERL_ARGS_ASSERT_NEW_CTYPE;
PERL_UNUSED_ARG(newctype);
PERL_UNUSED_CONTEXT;
&& (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
{
bool is_bad = FALSE;
- char name[3] = { '\0' };
+ char name[4] = { '\0' };
/* Convert the name into a string */
- if (isPRINT_A(i)) {
+ if (isGRAPH_A(i)) {
name[0] = i;
name[1] = '\0';
}
else if (i == '\n') {
- my_strlcpy(name, "\n", sizeof(name));
+ my_strlcpy(name, "\\n", sizeof(name));
+ }
+ else if (i == '\t') {
+ my_strlcpy(name, "\\t", sizeof(name));
}
else {
- my_strlcpy(name, "\t", sizeof(name));
+ assert(i == ' ');
+ my_strlcpy(name, "' '", sizeof(name));
}
/* Check each possibe class */
}
+#endif
+
#ifdef WIN32
STATIC char *
{
/* This wraps POSIX::setlocale() */
+#ifdef NO_LOCALE
+
+ PERL_UNUSED_ARG(category);
+ PERL_UNUSED_ARG(locale);
+
+ return "C";
+
+#else
+
const char * retval;
const char * newlocale;
dSAVEDERRNO;
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
dTHX;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
#ifdef USE_LOCALE_NUMERIC
return retval;
+#endif
+
}
PERL_STATIC_INLINE const char *
dTHX;
const char * retval;
+#ifdef USE_LOCALE_NUMERIC
+
/* We only need to toggle into the underlying LC_NUMERIC locale for these
* two items, and only if not already there */
if (toggle && (( item != RADIXCHAR && item != THOUSEP)
|| PL_numeric_underlying))
- {
+
+#endif /* No toggling needed if not using LC_NUMERIC */
+
toggle = FALSE;
- }
#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
do_free = TRUE;
}
+# ifdef USE_LOCALE_NUMERIC
+
if (toggle) {
if (PL_underlying_numeric_obj) {
cur = PL_underlying_numeric_obj;
}
}
+# endif
+
/* We have to save it to a buffer, because the freelocale() just below
* can invalidate the internal one */
retval = save_to_buffer(nl_langinfo_l(item, cur),
/* Here everything past the dot is a digit. Treat it as a
* code page */
- (void) save_to_buffer("CP", &PL_langinfo_buf,
+ retval = save_to_buffer("CP", &PL_langinfo_buf,
&PL_langinfo_bufsize, 0);
offset = STRLENs("CP");
# endif
+# ifdef USE_LOCALE_NUMERIC
+
PL_numeric_radix_sv = newSVpvs(".");
+# endif
+
# if defined(USE_POSIX_2008_LOCALE) && ! defined(HAS_QUERYLOCALE)
/* Initialize our records. If we have POSIX 2008, we have LC_ALL */
PerlIO_printf(Perl_debug_log, "'\n");
}
+# endif /* DEBUGGING */
+#endif /* USE_LOCALE_COLLATE */
+#ifdef DEBUGGING
+
STATIC void
S_print_bytes_for_locale(pTHX_
const char * const s,
}
}
-# endif /* #ifdef DEBUGGING */
-#endif /* USE_LOCALE_COLLATE */
+#endif /* #ifdef DEBUGGING */
#ifdef USE_LOCALE
Safefree(original_locale);
}
+/* is_cur_LC_category_utf8 uses a small char buffer to avoid malloc/free */
+#define CUR_LC_BUFFER_SIZE 64
+
bool
Perl__is_cur_LC_category_utf8(pTHX_ int category)
{
the name in the cache */
char * delimited; /* The name plus the delimiters used to store
it in the cache */
+ char buffer[CUR_LC_BUFFER_SIZE]; /* small buffer */
char * name_pos; /* position of 'delimited' in the cache, or 0
if not there */
* utf8ness digit */
input_name_len_with_overhead = input_name_len + 3;
- /* Allocate and populate space for a copy of the name surrounded by the
- * delimiters */
- Newx(delimited, input_name_len_with_overhead, char);
+ if ( input_name_len_with_overhead <= CUR_LC_BUFFER_SIZE ) {
+ /* we can use the buffer, avoid a malloc */
+ delimited = buffer;
+ } else { /* need a malloc */
+ /* Allocate and populate space for a copy of the name surrounded by the
+ * delimiters */
+ Newx(delimited, input_name_len_with_overhead, char);
+ }
+
delimited[0] = UTF8NESS_SEP[0];
Copy(save_input_locale, delimited + 1, input_name_len, char);
delimited[input_name_len+1] = UTF8NESS_PREFIX[0];
utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
}
- Safefree(delimited);
+ /* free only when not using the buffer */
+ if ( delimited != buffer ) Safefree(delimited);
Safefree(save_input_locale);
return is_utf8;
}
&& wc == (wchar_t) UNICODE_REPLACEMENT);
}
+# endif
+
restore_switched_locale(LC_CTYPE, original_ctype_locale);
goto finish_and_return;
}
-# endif
# else
/* Here, we must have a C89 compiler that doesn't have mbtowc(). Next
is_utf8 = TRUE;
goto finish_and_return;
}
- }
# endif
+ }
# endif
/* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
# endif
- Safefree(delimited);
+ /* free only when not using the buffer */
+ if ( delimited != buffer ) Safefree(delimited);
Safefree(save_input_locale);
return is_utf8;
}
const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
- SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
- if (! categories || categories == &PL_sv_placeholder) {
+ SV *these_categories = cop_hints_fetch_pvs(cop, "locale", 0);
+ if (! these_categories || these_categories == &PL_sv_placeholder) {
return FALSE;
}
/* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
* a valid unsigned */
assert(category >= -1);
- return cBOOL(SvUV(categories) & (1U << (category + 1)));
+ return cBOOL(SvUV(these_categories) & (1U << (category + 1)));
}
char *
LOCALE_UNLOCK;
# endif /* End of doesn't have strerror_l */
-#endif /* End of does have locale messages */
-
-#ifdef DEBUGGING
+# ifdef DEBUGGING
if (DEBUG_Lv_TEST) {
PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
PerlIO_printf(Perl_debug_log, "'\n");
}
-#endif
+# endif
+#endif /* End of does have locale messages */
SAVEFREEPV(errstr);
return errstr;
bool
Perl_sync_locale()
{
+
+#ifndef USE_LOCALE
+
+ return TRUE;
+
+#else
+
const char * newlocale;
dTHX;
-#ifdef USE_POSIX_2008_LOCALE
+# ifdef USE_POSIX_2008_LOCALE
bool was_in_global_locale = FALSE;
locale_t cur_obj = uselocale((locale_t) 0);
* will affect the */
if (cur_obj == LC_GLOBAL_LOCALE) {
-# ifdef HAS_QUERY_LOCALE
+# ifdef HAS_QUERY_LOCALE
do_setlocale_c(LC_ALL, setlocale(LC_ALL, NULL));
-# else
+# else
unsigned int i;
do_setlocale_r(categories[i], setlocale(categories[i], NULL));
}
-# endif
+# endif
was_in_global_locale = TRUE;
}
-#else
+# else
bool was_in_global_locale = TRUE;
-#endif
-#ifdef USE_LOCALE_CTYPE
+# endif
+# ifdef USE_LOCALE_CTYPE
newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
new_ctype(newlocale);
Safefree(newlocale);
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
+# endif /* USE_LOCALE_CTYPE */
+# ifdef USE_LOCALE_COLLATE
newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
new_collate(newlocale);
Safefree(newlocale);
-#endif
-#ifdef USE_LOCALE_NUMERIC
+# endif
+# ifdef USE_LOCALE_NUMERIC
newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
new_numeric(newlocale);
Safefree(newlocale);
-#endif /* USE_LOCALE_NUMERIC */
+# endif /* USE_LOCALE_NUMERIC */
return was_in_global_locale;
+
+#endif
+
}
#if defined(DEBUGGING) && defined(USE_LOCALE)