3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * A Elbereth Gilthoniel,
13 * silivren penna míriel
14 * o menel aglar elenath!
15 * Na-chaered palan-díriel
16 * o galadhremmin ennorath,
17 * Fanuilos, le linnathon
18 * nef aear, si nef aearon!
20 * [p.238 of _The Lord of the Rings_, II/i: "Many Meetings"]
23 /* utility functions for handling locale-specific stuff like what
24 * character represents the decimal point.
26 * All C programs have an underlying locale. Perl code generally doesn't pay
27 * any attention to it except within the scope of a 'use locale'. For most
28 * categories, it accomplishes this by just using different operations if it is
29 * in such scope than if not. However, various libc functions called by Perl
30 * are affected by the LC_NUMERIC category, so there are macros in perl.h that
31 * are used to toggle between the current locale and the C locale depending on
32 * the desired behavior of those functions at the moment. And, LC_MESSAGES is
33 * switched to the C locale for outputting the message unless within the scope
36 * This code now has multi-thread-safe locale handling on systems that support
37 * that. This is completely transparent to most XS code. On earlier systems,
38 * it would be possible to emulate thread-safe locales, but this likely would
39 * involve a lot of locale switching, and would require XS code changes.
40 * Macros could be written so that the code wouldn't have to know which type of
41 * system is being used.
43 * Table-driven code is used for simplicity and clarity, as many operations
44 * differ only in which category is being worked on. However the system
45 * categories need not be small contiguous integers, so do not lend themselves
46 * to table lookup. Instead we have created our own equivalent values which
47 * are all small contiguous non-negative integers, and translation functions
48 * between the two sets. For category 'LC_foo', the name of our index is
49 * LC_foo_INDEX_. Various parallel tables, indexed by these, are used.
51 * Many of the macros and functions in this file have one of the suffixes '_c',
52 * '_r', or '_i'. khw found these useful in remembering what type of locale
53 * category to use as their parameter. '_r' takes an int category number as
54 * passed to setlocale(), like LC_ALL, LC_CTYPE, etc. The 'r' indicates that
55 * the value isn't known until runtime. '_c' also indicates such a category
56 * number, but its value is known at compile time. These are both converted
57 * into unsigned indexes into various tables of category information, where the
58 * real work is generally done. The tables are generated at compile-time based
59 * on platform characteristics and Configure options. They hide from the code
60 * many of the vagaries of the different locale implementations out there. You
61 * may have already guessed that '_i' indicates the parameter is such an
62 * unsigned index. Converting from '_r' to '_i' requires run-time lookup.
63 * '_c' is used to get cpp to do this at compile time. To avoid the runtime
64 * expense, the code is structured to use '_r' at the API level, and once
65 * converted, everything possible is done using the table indexes.
67 * On unthreaded perls, most operations expand out to just the basic
68 * setlocale() calls. The same is true on threaded perls on modern Windows
69 * systems where the same API, after set up, is used for thread-safe locale
70 * handling. On other systems, there is a completely different API, specified
71 * in POSIX 2008, to do thread-safe locales. On these systems, our
72 * emulate_setlocale_i() function is used to hide the different API from the
73 * outside. This makes it completely transparent to most XS code.
75 * A huge complicating factor is that the LC_NUMERIC category is normally held
76 * in the C locale, except during those relatively rare times when it needs to
77 * be in the underlying locale. There is a bunch of code to accomplish this,
78 * and to allow easy switches from one state to the other.
80 * z/OS (os390) is an outlier. Locales really don't work under threads when
81 * either the radix character isn't a dot, or attempts are made to change
82 * locales after the first thread is created. The reason is that IBM has made
83 * it thread-safe by refusing to change locales (returning failure if
84 * attempted) any time after an application has called pthread_create() to
85 * create another thread. The expectation is that an application will set up
86 * its locale information before the first fork, and be stable thereafter. But
87 * perl toggles LC_NUMERIC if the locale's radix character isn't a dot, as do
88 * the other toggles, which are less common.
91 /* If the environment says to, we can output debugging information during
92 * initialization. This is done before option parsing, and before any thread
93 * creation, so can be a file-level static. (Must come before #including
96 static int debug_initialization = 0;
97 # define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
98 # define DEBUG_LOCALE_INITIALIZATION_ debug_initialization
100 # define debug_initialization 0
101 # define DEBUG_INITIALIZATION_set(v)
104 #define DEBUG_PRE_STMTS dSAVE_ERRNO; \
105 PerlIO_printf(Perl_debug_log, "%s: %" LINE_Tf ": ", __FILE__, __LINE__);
106 #define DEBUG_POST_STMTS RESTORE_ERRNO;
109 #define PERL_IN_LOCALE_C
110 #include "perl_langinfo.h"
122 PERL_STATIC_INLINE const char *
123 S_mortalized_pv_copy(pTHX_ const char * const pv)
125 PERL_ARGS_ASSERT_MORTALIZED_PV_COPY;
127 /* Copies the input pv, and arranges for it to be freed at an unspecified
134 const char * copy = savepv(pv);
140 /* Returns the Unix errno portion; ignoring any others. This is a macro here
141 * instead of putting it into perl.h, because unclear to khw what should be
143 #define GET_ERRNO saved_errno
145 /* Default values come from the C locale */
146 static const char C_codeset[] = "ANSI_X3.4-1968";
147 static const char C_decimal_point[] = ".";
148 static const char C_thousands_sep[] = "";
150 /* Is the C string input 'name' "C" or "POSIX"? If so, and 'name' is the
151 * return of setlocale(), then this is extremely likely to be the C or POSIX
152 * locale. However, the output of setlocale() is documented to be opaque, but
153 * the odds are extremely small that it would return these two strings for some
154 * other locale. Note that VMS in these two locales includes many non-ASCII
155 * characters as controls and punctuation (below are hex bytes):
157 * punct: A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
158 * Oddly, none there are listed as alphas, though some represent alphabetics
159 * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
160 #define isNAME_C_OR_POSIX(name) \
162 && (( *(name) == 'C' && (*(name + 1)) == '\0') \
163 || strEQ((name), "POSIX")))
165 #if defined(HAS_NL_LANGINFO_L) || defined(HAS_NL_LANGINFO)
166 # define HAS_SOME_LANGINFO
168 #if defined(HAS_LOCALECONV) || defined(HAS_LOCALECONV_L)
169 # define HAS_SOME_LOCALECONV
172 #define my_langinfo_c(item, category, locale, retbufp, retbuf_sizep, utf8ness) \
173 my_langinfo_i(item, category##_INDEX_, locale, retbufp, \
174 retbuf_sizep, utf8ness)
178 /* This code keeps a LRU cache of the UTF-8ness of the locales it has so-far
179 * looked up. This is in the form of a C string: */
181 # define UTF8NESS_SEP "\v"
182 # define UTF8NESS_PREFIX "\f"
184 /* So, the string looks like:
186 * \vC\a0\vPOSIX\a0\vam_ET\a0\vaf_ZA.utf8\a1\ven_US.UTF-8\a1\0
188 * where the digit 0 after the \a indicates that the locale starting just
189 * after the preceding \v is not UTF-8, and the digit 1 mean it is. */
191 STATIC_ASSERT_DECL(STRLENs(UTF8NESS_SEP) == 1);
192 STATIC_ASSERT_DECL(STRLENs(UTF8NESS_PREFIX) == 1);
194 # define C_and_POSIX_utf8ness UTF8NESS_SEP "C" UTF8NESS_PREFIX "0" \
195 UTF8NESS_SEP "POSIX" UTF8NESS_PREFIX "0"
197 /* The cache is initialized to C_and_POSIX_utf8ness at start up. These are
198 * kept there always. The remining portion of the cache is LRU, with the
199 * oldest looked-up locale at the tail end */
202 # define setlocale_debug_string_c(category, locale, result) \
203 setlocale_debug_string_i(category##_INDEX_, locale, result)
204 # define setlocale_debug_string_r(category, locale, result) \
205 setlocale_debug_string_i(get_category_index(category, locale), \
209 # define toggle_locale_i(index, locale) \
210 S_toggle_locale_i(aTHX_ index, locale, __LINE__)
211 # define toggle_locale_c(cat, locale) toggle_locale_i(cat##_INDEX_, locale)
212 # define restore_toggled_locale_i(index, locale) \
213 S_restore_toggled_locale_i(aTHX_ index, locale, __LINE__)
214 # define restore_toggled_locale_c(cat, locale) \
215 restore_toggled_locale_i(cat##_INDEX_, locale)
217 /* Two parallel arrays indexed by our mapping of category numbers into small
218 * non-negative indexes; first the locale categories Perl uses on this system,
219 * used to do the inverse mapping. The second array is their names. These
220 * arrays are in mostly arbitrary order. */
222 STATIC const int categories[] = {
224 # ifdef USE_LOCALE_CTYPE
227 # ifdef USE_LOCALE_NUMERIC
230 # ifdef USE_LOCALE_COLLATE
233 # ifdef USE_LOCALE_TIME
236 # ifdef USE_LOCALE_MESSAGES
239 # ifdef USE_LOCALE_MONETARY
242 # ifdef USE_LOCALE_ADDRESS
245 # ifdef USE_LOCALE_IDENTIFICATION
248 # ifdef USE_LOCALE_MEASUREMENT
251 # ifdef USE_LOCALE_PAPER
254 # ifdef USE_LOCALE_TELEPHONE
257 # ifdef USE_LOCALE_SYNTAX
260 # ifdef USE_LOCALE_TOD
267 /* Placeholder as a precaution if code fails to check the return of
268 * get_category_index(), which returns this element to indicate an error */
272 /* The top-most real element is LC_ALL */
274 STATIC const char * const category_names[] = {
276 # ifdef USE_LOCALE_CTYPE
279 # ifdef USE_LOCALE_NUMERIC
282 # ifdef USE_LOCALE_COLLATE
285 # ifdef USE_LOCALE_TIME
288 # ifdef USE_LOCALE_MESSAGES
291 # ifdef USE_LOCALE_MONETARY
294 # ifdef USE_LOCALE_ADDRESS
297 # ifdef USE_LOCALE_IDENTIFICATION
300 # ifdef USE_LOCALE_MEASUREMENT
303 # ifdef USE_LOCALE_PAPER
306 # ifdef USE_LOCALE_TELEPHONE
309 # ifdef USE_LOCALE_SYNTAX
312 # ifdef USE_LOCALE_TOD
319 /* Placeholder as a precaution if code fails to check the return of
320 * get_category_index(), which returns this element to indicate an error */
324 /* A few categories require additional setup when they are changed. This table
325 * points to the functions that do that setup */
326 STATIC void (*update_functions[]) (pTHX_ const char *) = {
327 # ifdef USE_LOCALE_CTYPE
330 # ifdef USE_LOCALE_NUMERIC
333 # ifdef USE_LOCALE_COLLATE
336 # ifdef USE_LOCALE_TIME
339 # ifdef USE_LOCALE_MESSAGES
342 # ifdef USE_LOCALE_MONETARY
345 # ifdef USE_LOCALE_ADDRESS
348 # ifdef USE_LOCALE_IDENTIFICATION
351 # ifdef USE_LOCALE_MEASUREMENT
354 # ifdef USE_LOCALE_PAPER
357 # ifdef USE_LOCALE_TELEPHONE
360 # ifdef USE_LOCALE_SYNTAX
363 # ifdef USE_LOCALE_TOD
366 /* No harm done to have this even without an LC_ALL */
369 /* Placeholder as a precaution if code fails to check the return of
370 * get_category_index(), which returns this element to indicate an error */
376 /* On systems with LC_ALL, it is kept in the highest index position. (-2
377 * to account for the final unused placeholder element.) */
378 # define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 2)
381 /* On systems without LC_ALL, we pretend it is there, one beyond the real
382 * top element, hence in the unused placeholder element. */
383 # define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 1)
386 /* Pretending there is an LC_ALL element just above allows us to avoid most
387 * special cases. Most loops through these arrays in the code below are
388 * written like 'for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)'. They will work
389 * on either type of system. But the code must be written to not access the
390 * element at 'LC_ALL_INDEX_' except on platforms that have it. This can be
391 * checked for at compile time by using the #define LC_ALL_INDEX_ which is only
392 * defined if we do have LC_ALL. */
395 S_get_category_index(const int category, const char * locale)
397 /* Given a category, return the equivalent internal index we generally use
400 * 'locale' is for use in any generated diagnostics, and may be NULL
402 * Some sort of hash could be used instead of this loop, but the number of
403 * elements is so far at most 12 */
406 const char * conditional_warn_text = "; can't set it to ";
408 PERL_ARGS_ASSERT_GET_CATEGORY_INDEX;
411 for (i = 0; i <= LC_ALL_INDEX_; i++)
413 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)
416 if (category == categories[i]) {
418 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
419 "index of category %d (%s) is %d\n",
420 category, category_names[i], i));
425 /* Here, we don't know about this category, so can't handle it. */
429 conditional_warn_text = "";
432 /* diag_listed_as: Unknown locale category %d; can't set it to %s */
433 Perl_warner_nocontext(packWARN(WARN_LOCALE),
434 "Unknown locale category %d%s%s",
435 category, conditional_warn_text, locale);
439 SETERRNO(EINVAL, LIB_INVARG);
443 /* Return an out-of-bounds value */
444 return NOMINAL_LC_ALL_INDEX + 1;
448 S_category_name(const int category)
452 index = get_category_index(category, NULL);
454 if (index <= NOMINAL_LC_ALL_INDEX) {
455 return category_names[index];
458 return Perl_form_nocontext("%d (unknown)", category);
461 #endif /* ifdef USE_LOCALE */
464 Perl_force_locale_unlock()
467 #if defined(USE_LOCALE_THREADS)
470 # ifdef LOCALE_UNLOCK_
478 #ifdef USE_POSIX_2008_LOCALE
481 S_use_curlocale_scratch(pTHX)
483 /* This function is used to hide from the caller the case where the current
484 * locale_t object in POSIX 2008 is the global one, which is illegal in
485 * many of the P2008 API calls. This checks for that and, if necessary
486 * creates a proper P2008 object. Any prior object is deleted, as is any
487 * remaining object during global destruction. */
489 locale_t cur = uselocale((locale_t) 0);
491 if (cur != LC_GLOBAL_LOCALE) {
495 if (PL_scratch_locale_obj) {
496 freelocale(PL_scratch_locale_obj);
499 PL_scratch_locale_obj = duplocale(LC_GLOBAL_LOCALE);
500 return PL_scratch_locale_obj;
506 Perl_locale_panic(const char * msg,
507 const char * file_name,
513 PERL_ARGS_ASSERT_LOCALE_PANIC;
515 force_locale_unlock();
517 #ifdef USE_C_BACKTRACE
518 dump_c_backtrace(Perl_debug_log, 20, 1);
521 /* diag_listed_as: panic: %s */
522 Perl_croak(aTHX_ "%s: %d: panic: %s; errno=%d\n",
523 file_name, line, msg, errnum);
526 #define setlocale_failure_panic_c( \
527 cat, current, failed, caller_0_line, caller_1_line) \
528 setlocale_failure_panic_i(cat##_INDEX_, current, failed, \
529 caller_0_line, caller_1_line)
531 /* porcelain_setlocale() presents a consistent POSIX-compliant interface to
532 * setlocale(). Windows requres a customized base-level setlocale() */
534 # define porcelain_setlocale(cat, locale) win32_setlocale(cat, locale)
536 # define porcelain_setlocale(cat, locale) \
537 ((const char *) setlocale(cat, locale))
540 /* The next layer up is to catch vagaries and bugs in the libc setlocale return
543 # define stdized_setlocale(cat, locale) \
544 stdize_locale(cat, porcelain_setlocale(cat, locale), \
545 &PL_stdize_locale_buf, &PL_stdize_locale_bufsize, __LINE__)
547 # define stdized_setlocale(cat, locale) porcelain_setlocale(cat, locale)
550 /* The next many lines form a layer above the close-to-the-metal 'porcelain'
551 * and 'stdized' macros. They are used to present a uniform API to the rest of
552 * the code in this file in spite of the disparate underlying implementations.
555 #ifndef USE_POSIX_2008_LOCALE
557 /* For non-threaded perls (which we are not to use the POSIX 2008 API on), or a
558 * thread-safe Windows one in which threading is invisible to us, the added
559 * layer just calls the base-level functions. See the introductory comments in
560 * this file for the meaning of the suffixes '_c', '_r', '_i'. */
562 # define setlocale_r(cat, locale) stdized_setlocale(cat, locale)
563 # define setlocale_i(i, locale) setlocale_r(categories[i], locale)
564 # define setlocale_c(cat, locale) setlocale_r(cat, locale)
566 # define void_setlocale_i(i, locale) \
568 if (! porcelain_setlocale(categories[i], locale)) { \
569 setlocale_failure_panic_i(i, NULL, locale, __LINE__, 0); \
570 NOT_REACHED; /* NOTREACHED */ \
573 # define void_setlocale_c(cat, locale) \
574 void_setlocale_i(cat##_INDEX_, locale)
575 # define void_setlocale_r(cat, locale) \
576 void_setlocale_i(get_category_index(cat, locale), locale)
578 # define bool_setlocale_r(cat, locale) \
579 cBOOL(porcelain_setlocale(cat, locale))
580 # define bool_setlocale_i(i, locale) \
581 bool_setlocale_c(categories[i], locale)
582 # define bool_setlocale_c(cat, locale) bool_setlocale_r(cat, locale)
584 /* All the querylocale...() forms return a mortalized copy. If you need
585 * something stable across calls, you need to savepv() the result yourself */
587 # define querylocale_r(cat) mortalized_pv_copy(setlocale_r(cat, NULL))
588 # define querylocale_c(cat) querylocale_r(cat)
589 # define querylocale_i(i) querylocale_c(categories[i])
591 #else /* Below is defined(POSIX 2008) */
593 /* Here, there is a completely different API to get thread-safe locales. We
594 * emulate the setlocale() API with our own function(s). setlocale categories,
595 * like LC_NUMERIC, are not valid here for the POSIX 2008 API. Instead, there
596 * are equivalents, like LC_NUMERIC_MASK, which we use instead, converting to
597 * by using get_category_index() followed by table lookup. */
599 # define emulate_setlocale_c(cat, locale, recalc_LC_ALL, line) \
600 emulate_setlocale_i(cat##_INDEX_, locale, recalc_LC_ALL, line)
602 /* A wrapper for the macros below. */
603 # define common_emulate_setlocale(i, locale) \
604 emulate_setlocale_i(i, locale, YES_RECALC_LC_ALL, __LINE__)
606 # define setlocale_i(i, locale) common_emulate_setlocale(i, locale)
607 # define setlocale_c(cat, locale) setlocale_i(cat##_INDEX_, locale)
608 # define setlocale_r(cat, locale) \
609 setlocale_i(get_category_index(cat, locale), locale)
611 # define void_setlocale_i(i, locale) ((void) setlocale_i(i, locale))
612 # define void_setlocale_c(cat, locale) \
613 void_setlocale_i(cat##_INDEX_, locale)
614 # define void_setlocale_r(cat, locale) ((void) setlocale_r(cat, locale))
616 # define bool_setlocale_i(i, locale) cBOOL(setlocale_i(i, locale))
617 # define bool_setlocale_c(cat, locale) \
618 bool_setlocale_i(cat##_INDEX_, locale)
619 # define bool_setlocale_r(cat, locale) cBOOL(setlocale_r(cat, locale))
621 # define querylocale_i(i) mortalized_pv_copy(my_querylocale_i(i))
622 # define querylocale_c(cat) querylocale_i(cat##_INDEX_)
623 # define querylocale_r(cat) querylocale_i(get_category_index(cat,NULL))
625 # ifndef USE_QUERYLOCALE
626 # define USE_PL_CURLOCALES
628 # define isSINGLE_BIT_SET(mask) isPOWER_OF_2(mask)
630 /* This code used to think querylocale() was valid on LC_ALL. Make sure
631 * all instances of that have been removed */
632 # define QUERYLOCALE_ASSERT(index) \
633 __ASSERT_(isSINGLE_BIT_SET(category_masks[index]))
634 # if ! defined(HAS_QUERYLOCALE) && defined(_NL_LOCALE_NAME)
635 # define querylocale_l(index, locale_obj) \
636 (QUERYLOCALE_ASSERT(index) \
637 mortalized_pv_copy(nl_langinfo_l( \
638 _NL_LOCALE_NAME(categories[index]), locale_obj)))
640 # define querylocale_l(index, locale_obj) \
641 (QUERYLOCALE_ASSERT(index) \
642 mortalized_pv_copy(querylocale(category_masks[index], locale_obj)))
645 # if defined(__GLIBC__) && defined(USE_LOCALE_MESSAGES)
646 # define HAS_GLIBC_LC_MESSAGES_BUG
647 # include <libintl.h>
650 /* A fourth array, parallel to the ones above to map from category to its
652 STATIC const int category_masks[] = {
653 # ifdef USE_LOCALE_CTYPE
656 # ifdef USE_LOCALE_NUMERIC
659 # ifdef USE_LOCALE_COLLATE
662 # ifdef USE_LOCALE_TIME
665 # ifdef USE_LOCALE_MESSAGES
668 # ifdef USE_LOCALE_MONETARY
671 # ifdef USE_LOCALE_ADDRESS
674 # ifdef USE_LOCALE_IDENTIFICATION
675 LC_IDENTIFICATION_MASK,
677 # ifdef USE_LOCALE_MEASUREMENT
680 # ifdef USE_LOCALE_PAPER
683 # ifdef USE_LOCALE_TELEPHONE
686 # ifdef USE_LOCALE_SYNTAX
689 # ifdef USE_LOCALE_TOD
692 /* LC_ALL can't be turned off by a Configure
693 * option, and in Posix 2008, should always be
694 * here, so compile it in unconditionally.
695 * This could catch some glitches at compile
699 /* Placeholder as a precaution if code fails to check the return of
700 * get_category_index(), which returns this element to indicate an error */
704 # define my_querylocale_c(cat) my_querylocale_i(cat##_INDEX_)
707 S_my_querylocale_i(pTHX_ const unsigned int index)
709 /* This function returns the name of the locale category given by the input
710 * index into our parallel tables of them.
712 * POSIX 2008, for some sick reason, chose not to provide a method to find
713 * the category name of a locale, discarding a basic linguistic tenet that
714 * for any object, people will create a name for it. Some vendors have
715 * created a querylocale() function to do just that. This function is a
716 * lot simpler to implement on systems that have this. Otherwise, we have
717 * to keep track of what the locale has been set to, so that we can return
718 * its name so as to emulate setlocale(). It's also possible for C code in
719 * some library to change the locale without us knowing it, though as of
720 * September 2017, there are no occurrences in CPAN of uselocale(). Some
721 * libraries do use setlocale(), but that changes the global locale, and
722 * threads using per-thread locales will just ignore those changes. */
725 const locale_t cur_obj = uselocale((locale_t) 0);
728 PERL_ARGS_ASSERT_MY_QUERYLOCALE_I;
729 assert(index <= NOMINAL_LC_ALL_INDEX);
731 category = categories[index];
733 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "my_querylocale_i(%s) on %p\n",
734 category_names[index], cur_obj));
735 if (cur_obj == LC_GLOBAL_LOCALE) {
736 retval = porcelain_setlocale(category, NULL);
740 # ifdef USE_QUERYLOCALE
742 /* We don't currently keep records when there is querylocale(), so have
743 * to get it anew each time */
744 retval = (index == LC_ALL_INDEX_)
745 ? calculate_LC_ALL(cur_obj)
746 : querylocale_l(index, cur_obj);
750 /* But we do have up-to-date values when we keep our own records */
751 retval = PL_curlocales[index];
757 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
758 "my_querylocale_i(%s) returning '%s'\n",
759 category_names[index], retval));
763 # ifdef USE_PL_CURLOCALES
766 S_update_PL_curlocales_i(pTHX_
767 const unsigned int index,
768 const char * new_locale,
769 recalc_lc_all_t recalc_LC_ALL)
771 /* This is a helper function for emulate_setlocale_i(), mostly used to
772 * make that function easier to read. */
774 PERL_ARGS_ASSERT_UPDATE_PL_CURLOCALES_I;
775 assert(index <= NOMINAL_LC_ALL_INDEX);
777 if (index == LC_ALL_INDEX_) {
780 /* For LC_ALL, we change all individual categories to correspond */
781 /* PL_curlocales is a parallel array, so has same
782 * length as 'categories' */
783 for (i = 0; i < LC_ALL_INDEX_; i++) {
784 Safefree(PL_curlocales[i]);
785 PL_curlocales[i] = savepv(new_locale);
788 recalc_LC_ALL = YES_RECALC_LC_ALL;
792 /* Update the single category's record */
793 Safefree(PL_curlocales[index]);
794 PL_curlocales[index] = savepv(new_locale);
796 if (recalc_LC_ALL == RECALCULATE_LC_ALL_ON_FINAL_INTERATION) {
797 recalc_LC_ALL = (index == NOMINAL_LC_ALL_INDEX - 1)
799 : DONT_RECALC_LC_ALL;
803 if (recalc_LC_ALL == YES_RECALC_LC_ALL) {
804 Safefree(PL_curlocales[LC_ALL_INDEX_]);
805 PL_curlocales[LC_ALL_INDEX_] =
806 savepv(calculate_LC_ALL(PL_curlocales));
809 return PL_curlocales[index];
812 # endif /* Need PL_curlocales[] */
815 S_setlocale_from_aggregate_LC_ALL(pTHX_ const char * locale, const line_t line)
817 /* This function parses the value of the LC_ALL locale, assuming glibc
818 * syntax, and sets each individual category on the system to the proper
821 * This is likely to only ever be called from one place, so exists to make
822 * the calling function easier to read by moving this ancillary code out of
825 * The locale for each category is independent of the other categories.
826 * Often, they are all the same, but certainly not always. Perl, in fact,
827 * usually keeps LC_NUMERIC in the C locale, regardless of the underlying
828 * locale. LC_ALL has to be able to represent the case of when there are
829 * varying locales. Platforms have differing ways of representing this.
830 * Because of this, the code in this file goes to lengths to avoid the
831 * issue, generally looping over the component categories instead of
832 * referring to them in the aggregate, wherever possible. However, there
833 * are cases where we have to parse our own constructed aggregates, which use
834 * the glibc syntax. */
836 const char * locale_on_entry = querylocale_c(LC_ALL);
838 PERL_ARGS_ASSERT_SETLOCALE_FROM_AGGREGATE_LC_ALL;
840 /* If the string that gives what to set doesn't include all categories,
841 * the omitted ones get set to "C". To get this behavior, first set
842 * all the individual categories to "C", and override the furnished
843 * ones below. FALSE => No need to recalculate LC_ALL, as this is a
845 if (! emulate_setlocale_c(LC_ALL, "C", DONT_RECALC_LC_ALL, line)) {
846 setlocale_failure_panic_c(LC_ALL, locale_on_entry,
847 "C", __LINE__, line);
848 NOT_REACHED; /* NOTREACHED */
851 const char * s = locale;
852 const char * e = locale + strlen(locale);
856 /* Parse through the category */
857 while (isWORDCHAR(*p)) {
861 const char * category_end = p;
864 locale_panic_(Perl_form(aTHX_
865 "Unexpected character in locale category name '%02X", *(p-1)));
868 /* Parse through the locale name */
869 const char * name_start = p;
870 while (p < e && *p != ';') {
872 locale_panic_(Perl_form(aTHX_
873 "Unexpected character in locale name '%02X", *p));
878 const char * name_end = p;
880 /* Space past the semi-colon */
885 /* Find the index of the category name in our lists */
886 for (PERL_UINT_FAST8_T i = 0; i < LC_ALL_INDEX_; i++) {
888 /* Keep going if this index doesn't point to the category being
889 * parsed. The strnNE() avoids a Perl_form(), but would fail if
890 * ever a category name could be a substring of another one, e.g.,
891 * if there were a "LC_TIME_DATE" */
892 if strnNE(s, category_names[i], category_end - s) {
896 /* Here i points to the category being parsed. Now isolate the
897 * locale it is being changed to */
898 const char * individ_locale = Perl_form(aTHX_ "%.*s",
899 (int) (name_end - name_start), name_start);
901 /* And do the change. FALSE => Don't recalculate LC_ALL; we'll do
902 * it ourselves after the loop */
903 if (! emulate_setlocale_i(i, individ_locale,
904 DONT_RECALC_LC_ALL, line))
907 /* But if we have to back out, do fix up LC_ALL */
908 if (! emulate_setlocale_c(LC_ALL, locale_on_entry,
909 YES_RECALC_LC_ALL, line))
911 setlocale_failure_panic_i(i, individ_locale,
912 locale, __LINE__, line);
913 NOT_REACHED; /* NOTREACHED */
916 /* Reverting to the entry value succeeded, but the operation
917 * failed to go to the requested locale. */
921 /* Found and handled the desired category. Quit the inner loop to
922 * try the next category */
926 /* Finished with this category; iterate to the next one in the input */
930 # ifdef USE_PL_CURLOCALES
932 /* Here we have set all the individual categories. Update the LC_ALL entry
933 * as well. We can't just use the input 'locale' as the value may omit
934 * categories whose locale is 'C'. khw thinks it's better to store a
935 * complete LC_ALL. So calculate it. */
936 const char * retval = savepv(calculate_LC_ALL(PL_curlocales));
937 Safefree(PL_curlocales[LC_ALL_INDEX_]);
938 PL_curlocales[LC_ALL_INDEX_] = retval;
942 const char * retval = querylocale_c(LC_ALL);
949 # ifndef USE_QUERYLOCALE
952 S_find_locale_from_environment(pTHX_ const unsigned int index)
954 /* On systems without querylocale(), it is problematic getting the results
955 * of the POSIX 2008 equivalent of setlocale(category, "") (which gets the
956 * locale from the environment).
958 * To ensure that we know exactly what those values are, we do the setting
959 * ourselves, using the documented algorithm (assuming the documentation is
960 * correct) rather than use "" as the locale. This will lead to results
961 * that differ from native behavior if the native behavior differs from the
962 * standard documented value, but khw believes it is better to know what's
963 * going on, even if different from native, than to just guess.
965 * Another option would be, in a critical section, to save the global
966 * locale's current value, and do a straight setlocale(LC_ALL, ""). That
967 * would return our desired values, destroying the global locale's, which
968 * we would then restore. But that could cause races with any other thread
969 * that is using the global locale and isn't using the mutex. And, the
970 * only reason someone would have done that is because they are calling a
971 * library function, like in gtk, that calls setlocale(), and which can't
972 * be changed to use the mutex. That wouldn't be a problem if this were to
973 * be done before any threads had switched, say during perl construction
974 * time. But this code would still be needed for the general case. */
976 const char * default_name;
978 const char * locale_names[LC_ALL_INDEX_];
980 /* We rely on PerlEnv_getenv() returning a mortalized copy */
981 const char * const lc_all = PerlEnv_getenv("LC_ALL");
983 /* Use any "LC_ALL" environment variable, as it overrides everything
985 if (lc_all && strNE(lc_all, "")) {
989 /* Otherwise, we need to dig deeper. Unless overridden, the default is
990 * the LANG environment variable; "C" if it doesn't exist. */
991 default_name = PerlEnv_getenv("LANG");
992 if (! default_name || strEQ(default_name, "")) {
996 /* If setting an individual category, use its corresponding value found in
997 * the environment, if any; otherwise use the default we already
999 if (index != LC_ALL_INDEX_) {
1000 const char * const new_value = PerlEnv_getenv(category_names[index]);
1002 return (new_value && strNE(new_value, ""))
1007 /* Here, we are getting LC_ALL. Any categories that don't have a
1008 * corresponding environment variable set should be set to 'default_name'
1010 * Simply find the values for all categories, and call the function to
1011 * compute LC_ALL. */
1012 for (i = 0; i < LC_ALL_INDEX_; i++) {
1013 const char * const env_override = PerlEnv_getenv(category_names[i]);
1015 locale_names[i] = (env_override && strNE(env_override, ""))
1019 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1020 "find_locale_from_environment i=%d, name=%s, locale=%s\n",
1021 i, category_names[i], locale_names[i]));
1024 return calculate_LC_ALL(locale_names);
1030 S_emulate_setlocale_i(pTHX_
1032 /* Our internal index of the 'category' setlocale is
1034 const unsigned int index,
1036 const char * new_locale, /* The locale to set the category to */
1037 const recalc_lc_all_t recalc_LC_ALL, /* Explained below */
1038 const line_t line /* Called from this line number */
1041 PERL_ARGS_ASSERT_EMULATE_SETLOCALE_I;
1042 assert(index <= NOMINAL_LC_ALL_INDEX);
1044 /* This function effectively performs a setlocale() on just the current
1045 * thread; thus it is thread-safe. It does this by using the POSIX 2008
1046 * locale functions to emulate the behavior of setlocale(). Similar to
1047 * regular setlocale(), the return from this function points to memory that
1048 * can be overwritten by other system calls, so needs to be copied
1049 * immediately if you need to retain it. The difference here is that
1050 * system calls besides another setlocale() can overwrite it.
1052 * By doing this, most locale-sensitive functions become thread-safe. The
1053 * exceptions are mostly those that return a pointer to static memory.
1055 * This function may be called in a tight loop that iterates over all
1056 * categories. Because LC_ALL is not a "real" category, but merely the sum
1057 * of all the other ones, such loops don't include LC_ALL. On systems that
1058 * have querylocale() or similar, the current LC_ALL value is immediately
1059 * retrievable; on systems lacking that feature, we have to keep track of
1060 * LC_ALL ourselves. We could do that on each iteration, only to throw it
1061 * away on the next, but the calculation is more than a trivial amount of
1062 * work. Instead, the 'recalc_LC_ALL' parameter is set to
1063 * RECALCULATE_LC_ALL_ON_FINAL_INTERATION to only do the calculation once.
1064 * This function calls itself recursively in such a loop.
1066 * When not in such a loop, the parameter is set to the other enum values
1067 * DONT_RECALC_LC_ALL or YES_RECALC_LC_ALL. */
1069 int mask = category_masks[index];
1070 const locale_t entry_obj = uselocale((locale_t) 0);
1071 const char * locale_on_entry = querylocale_i(index);
1073 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1074 "emulate_setlocale_i input=%d (%s), mask=0x%x,"
1075 " new locale=\"%s\", current locale=\"%s\","
1076 "index=%d, object=%p\n",
1077 categories[index], category_name(categories[index]), mask,
1078 ((new_locale == NULL) ? "(nil)" : new_locale),
1079 locale_on_entry, index, entry_obj));
1081 /* Return the already-calculated info if just querying what the existing
1083 if (new_locale == NULL) {
1084 return locale_on_entry;
1087 /* Here, trying to change the locale, but it is a no-op if the new boss is
1088 * the same as the old boss. Except this routine is called when converting
1089 * from the global locale, so in that case we will create a per-thread
1090 * locale below (with the current values). Bitter experience also
1091 * indicates that newlocale() can free up the basis locale memory if we
1092 * call it with the new and old being the same. */
1093 if ( entry_obj != LC_GLOBAL_LOCALE
1095 && strEQ(new_locale, locale_on_entry))
1097 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1098 "(%" LINE_Tf "): emulate_setlocale_i"
1099 " no-op to change to what it already was\n",
1102 # ifdef USE_PL_CURLOCALES
1104 /* On the final iteration of a loop that needs to recalculate LC_ALL, do
1105 * so. If no iteration changed anything, LC_ALL also doesn't change,
1106 * but khw believes the complexity needed to keep track of that isn't
1108 if (UNLIKELY( recalc_LC_ALL == RECALCULATE_LC_ALL_ON_FINAL_INTERATION
1109 && index == NOMINAL_LC_ALL_INDEX - 1))
1111 Safefree(PL_curlocales[LC_ALL_INDEX_]);
1112 PL_curlocales[LC_ALL_INDEX_] =
1113 savepv(calculate_LC_ALL(PL_curlocales));
1118 return locale_on_entry;
1121 # ifndef USE_QUERYLOCALE
1123 /* Without a querylocale() mechanism, we have to figure out ourselves what
1124 * happens with setting a locale to "" */
1125 if (strEQ(new_locale, "")) {
1126 new_locale = find_locale_from_environment(index);
1131 /* So far, it has worked that a semi-colon in the locale name means that
1132 * the category is LC_ALL and it subsumes categories which don't all have
1133 * the same locale. This is the glibc syntax. */
1134 if (strchr(new_locale, ';')) {
1135 assert(index == LC_ALL_INDEX_);
1136 return setlocale_from_aggregate_LC_ALL(new_locale, line);
1139 # ifdef HAS_GLIBC_LC_MESSAGES_BUG
1141 /* For this bug, if the LC_MESSAGES locale changes, we have to do an
1142 * expensive workaround. Save the current value so we can later determine
1144 const char * old_messages_locale = NULL;
1145 if ( (index == LC_MESSAGES_INDEX_ || index == LC_ALL_INDEX_)
1146 && LIKELY(PL_phase != PERL_PHASE_CONSTRUCT))
1148 old_messages_locale = querylocale_c(LC_MESSAGES);
1153 assert(PL_C_locale_obj);
1155 /* Now ready to switch to the input 'new_locale' */
1157 /* Switching locales generally entails freeing the current one's space (at
1158 * the C library's discretion), hence we can't be using that locale at the
1159 * time of the switch (this wasn't obvious to khw from the man pages). So
1160 * switch to a known locale object that we don't otherwise mess with. */
1161 if (! uselocale(PL_C_locale_obj)) {
1163 /* Not being able to change to the C locale is severe; don't keep
1165 setlocale_failure_panic_i(index, locale_on_entry, "C", __LINE__, line);
1166 NOT_REACHED; /* NOTREACHED */
1169 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1170 "(%" LINE_Tf "): emulate_setlocale_i now using C"
1171 " object=%p\n", line, PL_C_locale_obj));
1175 /* We created a (never changing) object at start-up for LC_ALL being in the
1176 * C locale. If this call is to switch to LC_ALL=>C, simply use that
1177 * object. But in fact, we already have switched to it just above, in
1178 * preparation for the general case. Since we're already there, no need to
1179 * do further switching. */
1180 if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(new_locale)) {
1181 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "(%" LINE_Tf "):"
1182 " emulate_setlocale_i will stay"
1183 " in C object\n", line));
1184 new_obj = PL_C_locale_obj;
1186 /* And free the old object if it isn't a special one */
1187 if (entry_obj != LC_GLOBAL_LOCALE && entry_obj != PL_C_locale_obj) {
1188 freelocale(entry_obj);
1191 else { /* Here is the general case, not to LC_ALL=>C */
1192 locale_t basis_obj = entry_obj;
1194 /* Specially handle two objects */
1195 if (basis_obj == LC_GLOBAL_LOCALE || basis_obj == PL_C_locale_obj) {
1197 /* For these two objects, we make duplicates to hand to newlocale()
1198 * below. For LC_GLOBAL_LOCALE, this is because newlocale()
1199 * doesn't necessarily accept it as input (the results are
1200 * undefined). For PL_C_locale_obj, it is so that it never gets
1201 * modified, as otherwise newlocale() is free to do so */
1202 basis_obj = duplocale(entry_obj);
1204 locale_panic_(Perl_form(aTHX_ "(%" LINE_Tf "): duplocale failed",
1206 NOT_REACHED; /* NOTREACHED */
1209 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1210 "(%" LINE_Tf "): emulate_setlocale_i"
1211 " created %p by duping the input\n",
1215 /* Ready to create a new locale by modification of the exising one */
1216 new_obj = newlocale(mask, new_locale, basis_obj);
1219 DEBUG_L(PerlIO_printf(Perl_debug_log,
1220 " (%" LINE_Tf "): emulate_setlocale_i"
1221 " creating new object from %p failed:"
1223 line, basis_obj, GET_ERRNO));
1225 /* Failed. Likely this is because the proposed new locale isn't
1226 * valid on this system. But we earlier switched to the LC_ALL=>C
1227 * locale in anticipation of it succeeding, Now have to switch
1228 * back to the state upon entry */
1229 if (! uselocale(entry_obj)) {
1230 setlocale_failure_panic_i(index, "switching back to",
1231 locale_on_entry, __LINE__, line);
1232 NOT_REACHED; /* NOTREACHED */
1235 # ifdef USE_PL_CURLOCALES
1237 if (entry_obj == LC_GLOBAL_LOCALE) {
1238 /* Here, we are back in the global locale. We may never have
1239 * set PL_curlocales. If the locale change had succeeded, the
1240 * code would have then set them up, but since it didn't, do so
1241 * here. khw isn't sure if this prevents some issues or not,
1242 * but tis is defensive coding. The system setlocale() returns
1243 * the desired information. This will calculate LC_ALL's entry
1244 * only on the final iteration */
1245 for (PERL_UINT_FAST8_T i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
1246 update_PL_curlocales_i(i,
1247 porcelain_setlocale(categories[i], NULL),
1248 RECALCULATE_LC_ALL_ON_FINAL_INTERATION);
1256 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1257 "(%" LINE_Tf "): emulate_setlocale_i created %p"
1258 " while freeing %p\n", line, new_obj, basis_obj));
1260 /* Here, successfully created an object representing the desired
1261 * locale; now switch into it */
1262 if (! uselocale(new_obj)) {
1263 freelocale(new_obj);
1264 locale_panic_(Perl_form(aTHX_ "(%" LINE_Tf "): emulate_setlocale_i"
1265 " switching into new locale failed",
1270 /* Here, we are using 'new_obj' which matches the input 'new_locale'. */
1271 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1272 "(%" LINE_Tf "): emulate_setlocale_i now using %p\n", line, new_obj));
1274 /* We are done, except for updating our records (if the system doesn't keep
1275 * them) and in the case of locale "", we don't actually know what the
1276 * locale that got switched to is, as it came from the environment. So
1277 * have to find it */
1279 # ifdef USE_QUERYLOCALE
1281 if (strEQ(new_locale, "")) {
1282 new_locale = querylocale_i(index);
1285 PERL_UNUSED_ARG(recalc_LC_ALL);
1289 new_locale = update_PL_curlocales_i(index, new_locale, recalc_LC_ALL);
1292 # ifdef HAS_GLIBC_LC_MESSAGES_BUG
1294 /* Invalidate the glibc cache of loaded translations if the locale has changed,
1295 * see [perl #134264] */
1296 if (old_messages_locale) {
1297 if (strNE(old_messages_locale, my_querylocale_c(LC_MESSAGES))) {
1298 textdomain(textdomain(NULL));
1307 #endif /* End of the various implementations of the setlocale and
1308 querylocale macros used in the remainder of this program */
1312 /* So far, the locale strings returned by modern 2008-compliant systems have
1316 S_stdize_locale(pTHX_ const int category,
1317 const char *input_locale,
1320 const line_t caller_line)
1322 /* The return value of setlocale() is opaque, but is required to be usable
1323 * as input to a future setlocale() to create the same state.
1324 * Unfortunately not all systems are compliant. But most often they are of
1325 * a very restricted set of forms that this file has been coded to expect.
1327 * There are some outliers, though, that this function tries to tame:
1329 * 1) A new-line. This function chomps any \n characters
1330 * 2) foo=bar. 'bar' is what is generally meant, and the foo= part is
1331 * stripped. This form is legal for LC_ALL. When found in
1332 * that category group, the function calls itself
1333 * recursively on each possible component category to make
1334 * sure the individual categories are ok.
1336 * If no changes to the input were made, it is returned; otherwise the
1337 * changed version is stored into memory at *buf, with *buf_size set to its
1338 * new value, and *buf is returned.
1341 const char * first_bad;
1342 const char * retval;
1344 PERL_ARGS_ASSERT_STDIZE_LOCALE;
1346 if (input_locale == NULL) {
1350 first_bad = strpbrk(input_locale, "=\n");
1352 /* Most likely, there isn't a problem with the input */
1353 if (LIKELY(! first_bad)) {
1354 return input_locale;
1359 /* But if there is, and the category is LC_ALL, we have to look at each
1360 * component category */
1361 if (category == LC_ALL) {
1362 const char * individ_locales[LC_ALL_INDEX_];
1363 bool made_changes = FALSE;
1366 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
1367 Size_t this_size = 0;
1368 individ_locales[i] = stdize_locale(categories[i],
1369 porcelain_setlocale(categories[i],
1371 &individ_locales[i],
1375 /* If the size didn't change, it means this category did not have
1376 * to be adjusted, and individ_locales[i] points to the buffer
1377 * returned by porcelain_setlocale(); we have to copy that before
1378 * it's called again in the next iteration */
1379 if (this_size == 0) {
1380 individ_locales[i] = savepv(individ_locales[i]);
1383 made_changes = TRUE;
1387 /* If all the individual categories were ok as-is, this was a false
1388 * alarm. We must have seen an '=' which was a legal occurrence in
1389 * this combination locale */
1390 if (! made_changes) {
1391 retval = input_locale; /* The input can be returned unchanged */
1394 retval = save_to_buffer(querylocale_c(LC_ALL), buf, buf_size);
1397 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
1398 Safefree(individ_locales[i]);
1404 # else /* else no LC_ALL */
1406 PERL_UNUSED_ARG(category);
1407 PERL_UNUSED_ARG(caller_line);
1411 /* Here, there was a problem in an individual category. This means that at
1412 * least one adjustment will be necessary. Create a modifiable copy */
1413 retval = save_to_buffer(input_locale, buf, buf_size);
1415 if (*first_bad != '=') {
1417 /* Translate the found position into terms of the copy */
1418 first_bad = retval + (first_bad - input_locale);
1422 /* It is unlikely that the return is so screwed-up that it contains
1423 * multiple equals signs, but handle that case by stripping all of
1425 const char * final_equals = strrchr(retval, '=');
1427 /* The length passed here causes the move to include the terminating
1429 Move(final_equals + 1, retval, strlen(final_equals), char);
1431 /* See if there are additional problems; if not, we're good to return.
1433 first_bad = strpbrk(retval, "\n");
1440 /* Here, the problem must be a \n. Get rid of it and what follows.
1441 * (Originally, only a trailing \n was stripped. Unsure what to do if not
1443 *((char *) first_bad) = '\0';
1447 #if defined(USE_POSIX_2008_LOCALE)
1452 # ifdef USE_QUERYLOCALE
1453 S_calculate_LC_ALL(pTHX_ const locale_t cur_obj)
1455 S_calculate_LC_ALL(pTHX_ const char ** individ_locales)
1459 /* For POSIX 2008, we have to figure out LC_ALL ourselves when needed.
1460 * querylocale(), on systems that have it, doesn't tend to work for LC_ALL.
1461 * So we have to construct the answer ourselves based on the passed in
1462 * data, which is either a locale_t object, for systems with querylocale(),
1463 * or an array we keep updated to the proper values, otherwise.
1465 * This returns a mortalized string containing the locale name(s) of
1468 * If all individual categories are the same locale, we can just set LC_ALL
1469 * to that locale. But if not, we have to create an aggregation of all the
1470 * categories on the system. Platforms differ as to the syntax they use
1471 * for these non-uniform locales for LC_ALL. Some use a '/' or other
1472 * delimiter of the locales with a predetermined order of categories; a
1473 * Configure probe would be needed to tell us how to decipher those. glibc
1474 * uses a series of name=value pairs, like
1475 * LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
1476 * The syntax we use for our aggregation doesn't much matter, as we take
1477 * care not to use the native setlocale() function on whatever style is
1478 * chosen. But, it would be possible for someone to call Perl_setlocale()
1479 * using a native style we don't understand. So far no one has complained.
1481 * For systems that have categories we don't know about, the algorithm
1482 * below won't know about those missing categories, leading to potential
1483 * bugs for code that looks at them. If there is an environment variable
1484 * that sets that category, we won't know to look for it, and so our use of
1485 * LANG or "C" improperly overrides it. On the other hand, if we don't do
1486 * what is done here, and there is no environment variable, the category's
1487 * locale should be set to LANG or "C". So there is no good solution. khw
1488 * thinks the best is to make sure we have a complete list of possible
1489 * categories, adding new ones as they show up on obscure platforms.
1493 Size_t names_len = 0;
1494 bool are_all_categories_the_same_locale = TRUE;
1495 char * aggregate_locale;
1496 char * previous_start = NULL;
1497 char * this_start = NULL;
1498 Size_t entry_len = 0;
1500 PERL_ARGS_ASSERT_CALCULATE_LC_ALL;
1502 /* First calculate the needed size for the string listing the categories
1503 * and their locales. */
1504 for (i = 0; i < LC_ALL_INDEX_; i++) {
1506 # ifdef USE_QUERYLOCALE
1507 const char * entry = querylocale_l(i, cur_obj);
1509 const char * entry = individ_locales[i];
1512 names_len += strlen(category_names[i])
1518 names_len++; /* Trailing '\0' */
1520 /* Allocate enough space for the aggregated string */
1521 SAVEFREEPV(Newxz(aggregate_locale, names_len, char));
1523 /* Then fill it in */
1524 for (i = 0; i < LC_ALL_INDEX_; i++) {
1527 # ifdef USE_QUERYLOCALE
1528 const char * entry = querylocale_l(i, cur_obj);
1530 const char * entry = individ_locales[i];
1533 new_len = my_strlcat(aggregate_locale, category_names[i], names_len);
1534 assert(new_len <= names_len);
1535 new_len = my_strlcat(aggregate_locale, "=", names_len);
1536 assert(new_len <= names_len);
1538 this_start = aggregate_locale + strlen(aggregate_locale);
1539 entry_len = strlen(entry);
1541 new_len = my_strlcat(aggregate_locale, entry, names_len);
1542 assert(new_len <= names_len);
1543 new_len = my_strlcat(aggregate_locale, ";", names_len);
1544 assert(new_len <= names_len);
1545 PERL_UNUSED_VAR(new_len); /* Only used in DEBUGGING */
1548 && are_all_categories_the_same_locale
1549 && memNE(previous_start, this_start, entry_len + 1))
1551 are_all_categories_the_same_locale = FALSE;
1554 previous_start = this_start;
1558 /* If they are all the same, just return any one of them */
1559 if (are_all_categories_the_same_locale) {
1560 aggregate_locale = this_start;
1561 aggregate_locale[entry_len] = '\0';
1564 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1565 "calculate_LC_ALL returning '%s'\n",
1568 return aggregate_locale;
1570 #endif /*defined(USE_POSIX_2008_LOCALE)*/
1573 S_setlocale_failure_panic_i(pTHX_
1574 const unsigned int cat_index,
1575 const char * current,
1576 const char * failed,
1577 const line_t caller_0_line,
1578 const line_t caller_1_line)
1581 const int cat = categories[cat_index];
1582 const char * name = category_names[cat_index];
1584 PERL_ARGS_ASSERT_SETLOCALE_FAILURE_PANIC_I;
1586 if (current == NULL) {
1587 current = querylocale_i(cat_index);
1590 Perl_locale_panic(Perl_form(aTHX_ "(%" LINE_Tf
1591 "): Can't change locale for %s(%d)"
1592 " from '%s' to '%s'",
1593 caller_1_line, name, cat,
1595 __FILE__, caller_0_line, GET_ERRNO);
1596 NOT_REACHED; /* NOTREACHED */
1599 /* Any of these will allow us to find the RADIX */
1600 # if defined(USE_LOCALE_NUMERIC) && ( defined(HAS_SOME_LANGINFO) \
1601 || defined(HAS_SOME_LOCALECONV) \
1602 || defined(HAS_SNPRINTF))
1603 # define CAN_CALCULATE_RADIX
1607 S_set_numeric_radix(pTHX_ const bool use_locale)
1609 /* If 'use_locale' is FALSE, set to use a dot for the radix character. If
1610 * TRUE, use the radix character derived from the current locale */
1612 # ifdef CAN_CALCULATE_RADIX
1614 utf8ness_t utf8ness = UTF8NESS_IMMATERIAL;
1616 const char * scratch_buffer = NULL;
1619 radix = C_decimal_point;
1622 radix = my_langinfo_c(RADIXCHAR, LC_NUMERIC,
1624 &scratch_buffer, NULL, &utf8ness);
1627 sv_setpv(PL_numeric_radix_sv, radix);
1628 Safefree(scratch_buffer);
1630 if (utf8ness == UTF8NESS_YES) {
1631 SvUTF8_on(PL_numeric_radix_sv);
1634 DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
1635 SvPVX(PL_numeric_radix_sv),
1636 cBOOL(SvUTF8(PL_numeric_radix_sv))));
1639 PERL_UNUSED_ARG(use_locale);
1641 # endif /* USE_LOCALE_NUMERIC and can find the radix char */
1646 S_new_numeric(pTHX_ const char *newnum)
1649 # ifndef USE_LOCALE_NUMERIC
1651 PERL_UNUSED_ARG(newnum);
1655 /* Called after each libc setlocale() call affecting LC_NUMERIC, to tell
1656 * core Perl this and that 'newnum' is the name of the new locale, and we
1657 * are switched into it. It installs this locale as the current underlying
1658 * default, and then switches to the C locale, if necessary, so that the
1659 * code that has traditionally expected the radix character to be a dot may
1660 * continue to do so.
1662 * The default locale and the C locale can be toggled between by use of the
1663 * set_numeric_underlying() and set_numeric_standard() functions, which
1664 * should probably not be called directly, but only via macros like
1665 * SET_NUMERIC_STANDARD() in perl.h.
1667 * The toggling is necessary mainly so that a non-dot radix decimal point
1668 * character can be input and output, while allowing internal calculations
1671 * This sets several interpreter-level variables:
1672 * PL_numeric_name The underlying locale's name: a copy of 'newnum'
1673 * PL_numeric_underlying A boolean indicating if the toggled state is such
1674 * that the current locale is the program's underlying
1676 * PL_numeric_standard An int indicating if the toggled state is such
1677 * that the current locale is the C locale or
1678 * indistinguishable from the C locale. If non-zero, it
1679 * is in C; if > 1, it means it may not be toggled away
1681 * PL_numeric_underlying_is_standard A bool kept by this function
1682 * indicating that the underlying locale and the standard
1683 * C locale are indistinguishable for the purposes of
1684 * LC_NUMERIC. This happens when both of the above two
1685 * variables are true at the same time. (Toggling is a
1686 * no-op under these circumstances.) This variable is
1687 * used to avoid having to recalculate.
1688 * PL_numeric_radix_sv Contains the string that code should use for the
1689 * decimal point. It is set to either a dot or the
1690 * program's underlying locale's radix character string,
1691 * depending on the situation.
1692 * PL_underlying_numeric_obj = (only on POSIX 2008 platforms) An object
1693 * with everything set up properly so as to avoid work on
1700 Safefree(PL_numeric_name);
1701 PL_numeric_name = savepv("C");
1702 PL_numeric_standard = TRUE;
1703 PL_numeric_underlying = TRUE;
1704 PL_numeric_underlying_is_standard = TRUE;
1708 save_newnum = savepv(newnum);
1709 PL_numeric_underlying = TRUE;
1710 PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
1712 # ifndef TS_W32_BROKEN_LOCALECONV
1714 /* If its name isn't C nor POSIX, it could still be indistinguishable from
1715 * them. But on broken Windows systems calling my_langinfo() for
1716 * THOUSEP can currently (but rarely) cause a race, so avoid doing that,
1717 * and just always change the locale if not C nor POSIX on those systems */
1718 if (! PL_numeric_standard) {
1719 const char * scratch_buffer = NULL;
1720 PL_numeric_standard = strEQ(C_decimal_point,
1721 my_langinfo_c(RADIXCHAR, LC_NUMERIC,
1723 &scratch_buffer, NULL, NULL));
1724 Safefree(scratch_buffer);
1725 scratch_buffer = NULL;
1727 PL_numeric_standard &= strEQ(C_thousands_sep,
1728 my_langinfo_c(THOUSEP, LC_NUMERIC,
1730 &scratch_buffer, NULL, NULL));
1731 Safefree(scratch_buffer);
1736 /* Save the new name if it isn't the same as the previous one, if any */
1737 if (strNE(PL_numeric_name, save_newnum)) {
1738 /* Save the locale name for future use */
1739 Safefree(PL_numeric_name);
1740 PL_numeric_name = save_newnum;
1743 Safefree(save_newnum);
1746 PL_numeric_underlying_is_standard = PL_numeric_standard;
1748 # ifdef USE_POSIX_2008_LOCALE
1750 /* We keep a special object for easy switching to */
1751 PL_underlying_numeric_obj = newlocale(LC_NUMERIC_MASK,
1753 PL_underlying_numeric_obj);
1757 DEBUG_L( PerlIO_printf(Perl_debug_log,
1758 "Called new_numeric with %s, PL_numeric_name=%s\n",
1759 newnum, PL_numeric_name));
1761 /* Keep LC_NUMERIC so that it has the C locale radix and thousands
1762 * separator. This is for XS modules, so they don't have to worry about
1763 * the radix being a non-dot. (Core operations that need the underlying
1764 * locale change to it temporarily). */
1765 if (PL_numeric_standard) {
1766 set_numeric_radix(0);
1769 set_numeric_standard();
1777 Perl_set_numeric_standard(pTHX)
1780 # ifdef USE_LOCALE_NUMERIC
1782 /* Unconditionally toggle the LC_NUMERIC locale to the current underlying
1785 * Most code should use the macro SET_NUMERIC_STANDARD() in perl.h
1786 * instead of calling this directly. The macro avoids calling this routine
1787 * if toggling isn't necessary according to our records (which could be
1788 * wrong if some XS code has changed the locale behind our back) */
1790 DEBUG_L(PerlIO_printf(Perl_debug_log,
1791 "Setting LC_NUMERIC locale to standard C\n"));
1793 void_setlocale_c(LC_NUMERIC, "C");
1794 PL_numeric_standard = TRUE;
1795 PL_numeric_underlying = PL_numeric_underlying_is_standard;
1796 set_numeric_radix(0);
1798 # endif /* USE_LOCALE_NUMERIC */
1803 Perl_set_numeric_underlying(pTHX)
1806 # ifdef USE_LOCALE_NUMERIC
1808 /* Unconditionally toggle the LC_NUMERIC locale to the current underlying
1811 * Most code should use the macro SET_NUMERIC_UNDERLYING() in perl.h
1812 * instead of calling this directly. The macro avoids calling this routine
1813 * if toggling isn't necessary according to our records (which could be
1814 * wrong if some XS code has changed the locale behind our back) */
1816 DEBUG_L(PerlIO_printf(Perl_debug_log, "Setting LC_NUMERIC locale to %s\n",
1819 void_setlocale_c(LC_NUMERIC, PL_numeric_name);
1820 PL_numeric_standard = PL_numeric_underlying_is_standard;
1821 PL_numeric_underlying = TRUE;
1822 set_numeric_radix(! PL_numeric_standard);
1824 # endif /* USE_LOCALE_NUMERIC */
1829 * Set up for a new ctype locale.
1832 S_new_ctype(pTHX_ const char *newctype)
1835 # ifndef USE_LOCALE_CTYPE
1837 PERL_UNUSED_ARG(newctype);
1838 PERL_UNUSED_CONTEXT;
1842 /* Called after each libc setlocale() call affecting LC_CTYPE, to tell
1843 * core Perl this and that 'newctype' is the name of the new locale.
1845 * This function sets up the folding arrays for all 256 bytes, assuming
1846 * that tofold() is tolc() since fold case is not a concept in POSIX,
1848 * Any code changing the locale (outside this file) should use
1849 * Perl_setlocale or POSIX::setlocale, which call this function. Therefore
1850 * this function should be called directly only from this file and from
1851 * POSIX::setlocale() */
1855 /* Don't check for problems if we are suppressing the warnings */
1856 bool check_for_problems = ckWARN_d(WARN_LOCALE) || UNLIKELY(DEBUG_L_TEST);
1857 bool maybe_utf8_turkic = FALSE;
1859 PERL_ARGS_ASSERT_NEW_CTYPE;
1861 DEBUG_L(PerlIO_printf(Perl_debug_log, "Entering new_ctype(%s)\n", newctype));
1863 /* We will replace any bad locale warning with 1) nothing if the new one is
1864 * ok; or 2) a new warning for the bad new locale */
1865 if (PL_warn_locale) {
1866 SvREFCNT_dec_NN(PL_warn_locale);
1867 PL_warn_locale = NULL;
1870 PL_in_utf8_CTYPE_locale = is_locale_utf8(newctype);
1872 /* A UTF-8 locale gets standard rules. But note that code still has to
1873 * handle this specially because of the three problematic code points */
1874 if (PL_in_utf8_CTYPE_locale) {
1875 Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
1877 /* UTF-8 locales can have special handling for 'I' and 'i' if they are
1878 * Turkic. Make sure these two are the only anomalies. (We don't
1879 * require towupper and towlower because they aren't in C89.) */
1881 # if defined(HAS_TOWUPPER) && defined (HAS_TOWLOWER)
1883 if (towupper('i') == 0x130 && towlower('I') == 0x131)
1887 if (toU8_UPPER_LC('i') == 'i' && toU8_LOWER_LC('I') == 'I')
1892 /* This is how we determine it really is Turkic */
1893 check_for_problems = TRUE;
1894 maybe_utf8_turkic = TRUE;
1898 /* We don't populate the other lists if a UTF-8 locale, but do check that
1899 * everything works as expected, unless checking turned off */
1900 if (check_for_problems || ! PL_in_utf8_CTYPE_locale) {
1901 /* Assume enough space for every character being bad. 4 spaces each
1902 * for the 94 printable characters that are output like "'x' "; and 5
1903 * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
1905 char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ] = { '\0' };
1906 bool multi_byte_locale = FALSE; /* Assume is a single-byte locale
1908 unsigned int bad_count = 0; /* Count of bad characters */
1910 for (i = 0; i < 256; i++) {
1911 if (! PL_in_utf8_CTYPE_locale) {
1912 if (isU8_UPPER_LC(i))
1913 PL_fold_locale[i] = (U8) toU8_LOWER_LC(i);
1914 else if (isU8_LOWER_LC(i))
1915 PL_fold_locale[i] = (U8) toU8_UPPER_LC(i);
1917 PL_fold_locale[i] = (U8) i;
1920 /* If checking for locale problems, see if the native ASCII-range
1921 * printables plus \n and \t are in their expected categories in
1922 * the new locale. If not, this could mean big trouble, upending
1923 * Perl's and most programs' assumptions, like having a
1924 * metacharacter with special meaning become a \w. Fortunately,
1925 * it's very rare to find locales that aren't supersets of ASCII
1926 * nowadays. It isn't a problem for most controls to be changed
1927 * into something else; we check only \n and \t, though perhaps \r
1928 * could be an issue as well. */
1929 if ( check_for_problems
1930 && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
1932 bool is_bad = FALSE;
1933 char name[4] = { '\0' };
1935 /* Convert the name into a string */
1940 else if (i == '\n') {
1941 my_strlcpy(name, "\\n", sizeof(name));
1943 else if (i == '\t') {
1944 my_strlcpy(name, "\\t", sizeof(name));
1948 my_strlcpy(name, "' '", sizeof(name));
1951 /* Check each possibe class */
1952 if (UNLIKELY(cBOOL(isU8_ALPHANUMERIC_LC(i)) != cBOOL(isALPHANUMERIC_A(i)))) {
1954 DEBUG_L(PerlIO_printf(Perl_debug_log,
1955 "isalnum('%s') unexpectedly is %x\n",
1956 name, cBOOL(isU8_ALPHANUMERIC_LC(i))));
1958 if (UNLIKELY(cBOOL(isU8_ALPHA_LC(i)) != cBOOL(isALPHA_A(i)))) {
1960 DEBUG_L(PerlIO_printf(Perl_debug_log,
1961 "isalpha('%s') unexpectedly is %x\n",
1962 name, cBOOL(isU8_ALPHA_LC(i))));
1964 if (UNLIKELY(cBOOL(isU8_DIGIT_LC(i)) != cBOOL(isDIGIT_A(i)))) {
1966 DEBUG_L(PerlIO_printf(Perl_debug_log,
1967 "isdigit('%s') unexpectedly is %x\n",
1968 name, cBOOL(isU8_DIGIT_LC(i))));
1970 if (UNLIKELY(cBOOL(isU8_GRAPH_LC(i)) != cBOOL(isGRAPH_A(i)))) {
1972 DEBUG_L(PerlIO_printf(Perl_debug_log,
1973 "isgraph('%s') unexpectedly is %x\n",
1974 name, cBOOL(isU8_GRAPH_LC(i))));
1976 if (UNLIKELY(cBOOL(isU8_LOWER_LC(i)) != cBOOL(isLOWER_A(i)))) {
1978 DEBUG_L(PerlIO_printf(Perl_debug_log,
1979 "islower('%s') unexpectedly is %x\n",
1980 name, cBOOL(isU8_LOWER_LC(i))));
1982 if (UNLIKELY(cBOOL(isU8_PRINT_LC(i)) != cBOOL(isPRINT_A(i)))) {
1984 DEBUG_L(PerlIO_printf(Perl_debug_log,
1985 "isprint('%s') unexpectedly is %x\n",
1986 name, cBOOL(isU8_PRINT_LC(i))));
1988 if (UNLIKELY(cBOOL(isU8_PUNCT_LC(i)) != cBOOL(isPUNCT_A(i)))) {
1990 DEBUG_L(PerlIO_printf(Perl_debug_log,
1991 "ispunct('%s') unexpectedly is %x\n",
1992 name, cBOOL(isU8_PUNCT_LC(i))));
1994 if (UNLIKELY(cBOOL(isU8_SPACE_LC(i)) != cBOOL(isSPACE_A(i)))) {
1996 DEBUG_L(PerlIO_printf(Perl_debug_log,
1997 "isspace('%s') unexpectedly is %x\n",
1998 name, cBOOL(isU8_SPACE_LC(i))));
2000 if (UNLIKELY(cBOOL(isU8_UPPER_LC(i)) != cBOOL(isUPPER_A(i)))) {
2002 DEBUG_L(PerlIO_printf(Perl_debug_log,
2003 "isupper('%s') unexpectedly is %x\n",
2004 name, cBOOL(isU8_UPPER_LC(i))));
2006 if (UNLIKELY(cBOOL(isU8_XDIGIT_LC(i))!= cBOOL(isXDIGIT_A(i)))) {
2008 DEBUG_L(PerlIO_printf(Perl_debug_log,
2009 "isxdigit('%s') unexpectedly is %x\n",
2010 name, cBOOL(isU8_XDIGIT_LC(i))));
2012 if (UNLIKELY(toU8_LOWER_LC(i) != (int) toLOWER_A(i))) {
2014 DEBUG_L(PerlIO_printf(Perl_debug_log,
2015 "tolower('%s')=0x%x instead of the expected 0x%x\n",
2016 name, toU8_LOWER_LC(i), (int) toLOWER_A(i)));
2018 if (UNLIKELY(toU8_UPPER_LC(i) != (int) toUPPER_A(i))) {
2020 DEBUG_L(PerlIO_printf(Perl_debug_log,
2021 "toupper('%s')=0x%x instead of the expected 0x%x\n",
2022 name, toU8_UPPER_LC(i), (int) toUPPER_A(i)));
2024 if (UNLIKELY((i == '\n' && ! isCNTRL_LC(i)))) {
2026 DEBUG_L(PerlIO_printf(Perl_debug_log,
2027 "'\\n' (=%02X) is not a control\n", (int) i));
2030 /* Add to the list; Separate multiple entries with a blank */
2033 my_strlcat(bad_chars_list, " ", sizeof(bad_chars_list));
2035 my_strlcat(bad_chars_list, name, sizeof(bad_chars_list));
2041 if (bad_count == 2 && maybe_utf8_turkic) {
2043 *bad_chars_list = '\0';
2044 PL_fold_locale['I'] = 'I';
2045 PL_fold_locale['i'] = 'i';
2046 PL_in_utf8_turkic_locale = TRUE;
2047 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s is turkic\n", newctype));
2050 PL_in_utf8_turkic_locale = FALSE;
2055 /* We only handle single-byte locales (outside of UTF-8 ones; so if
2056 * this locale requires more than one byte, there are going to be
2058 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2059 "check_for_problems=%d, MB_CUR_MAX=%d\n",
2060 check_for_problems, (int) MB_CUR_MAX));
2062 if ( check_for_problems && MB_CUR_MAX > 1
2063 && ! PL_in_utf8_CTYPE_locale
2065 /* Some platforms return MB_CUR_MAX > 1 for even the "C"
2066 * locale. Just assume that the implementation for them (plus
2067 * for POSIX) is correct and the > 1 value is spurious. (Since
2068 * these are specially handled to never be considered UTF-8
2069 * locales, as long as this is the only problem, everything
2070 * should work fine */
2071 && strNE(newctype, "C") && strNE(newctype, "POSIX"))
2073 multi_byte_locale = TRUE;
2078 /* If we found problems and we want them output, do so */
2079 if ( (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale))
2080 && (LIKELY(ckWARN_d(WARN_LOCALE)) || UNLIKELY(DEBUG_L_TEST)))
2082 if (UNLIKELY(bad_count) && PL_in_utf8_CTYPE_locale) {
2083 PL_warn_locale = Perl_newSVpvf(aTHX_
2084 "Locale '%s' contains (at least) the following characters"
2085 " which have\nunexpected meanings: %s\nThe Perl program"
2086 " will use the expected meanings",
2087 newctype, bad_chars_list);
2090 PL_warn_locale = Perl_newSVpvf(aTHX_
2091 "Locale '%s' may not work well.%s%s%s\n",
2094 ? " Some characters in it are not recognized by"
2098 ? "\nThe following characters (and maybe others)"
2099 " may not have the same meaning as the Perl"
2100 " program expects:\n"
2108 # ifdef HAS_SOME_LANGINFO
2110 const char * scratch_buffer = NULL;
2111 Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
2112 my_langinfo_c(CODESET, LC_CTYPE,
2114 &scratch_buffer, NULL,
2116 Safefree(scratch_buffer);
2120 Perl_sv_catpvf(aTHX_ PL_warn_locale, "\n");
2122 /* If we are actually in the scope of the locale or are debugging,
2123 * output the message now. If not in that scope, we save the
2124 * message to be output at the first operation using this locale,
2125 * if that actually happens. Most programs don't use locales, so
2126 * they are immune to bad ones. */
2127 if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
2129 /* The '0' below suppresses a bogus gcc compiler warning */
2130 Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale),
2133 if (IN_LC(LC_CTYPE)) {
2134 SvREFCNT_dec_NN(PL_warn_locale);
2135 PL_warn_locale = NULL;
2141 # endif /* USE_LOCALE_CTYPE */
2146 Perl__warn_problematic_locale()
2149 # ifdef USE_LOCALE_CTYPE
2153 /* Internal-to-core function that outputs the message in PL_warn_locale,
2154 * and then NULLS it. Should be called only through the macro
2155 * CHECK_AND_WARN_PROBLEMATIC_LOCALE_ */
2157 if (PL_warn_locale) {
2158 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2159 SvPVX(PL_warn_locale),
2160 0 /* dummy to avoid compiler warning */ );
2161 SvREFCNT_dec_NN(PL_warn_locale);
2162 PL_warn_locale = NULL;
2170 S_new_LC_ALL(pTHX_ const char *unused)
2174 /* LC_ALL updates all the things we care about. */
2176 PERL_UNUSED_ARG(unused);
2178 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
2179 if (update_functions[i]) {
2180 const char * this_locale = querylocale_i(i);
2181 update_functions[i](aTHX_ this_locale);
2187 S_new_collate(pTHX_ const char *newcoll)
2190 # ifndef USE_LOCALE_COLLATE
2192 PERL_UNUSED_ARG(newcoll);
2193 PERL_UNUSED_CONTEXT;
2197 /* Called after each libc setlocale() call affecting LC_COLLATE, to tell
2198 * core Perl this and that 'newcoll' is the name of the new locale.
2200 * The design of locale collation is that every locale change is given an
2201 * index 'PL_collation_ix'. The first time a string particpates in an
2202 * operation that requires collation while locale collation is active, it
2203 * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()). That
2204 * magic includes the collation index, and the transformation of the string
2205 * by strxfrm(), q.v. That transformation is used when doing comparisons,
2206 * instead of the string itself. If a string changes, the magic is
2207 * cleared. The next time the locale changes, the index is incremented,
2208 * and so we know during a comparison that the transformation is not
2209 * necessarily still valid, and so is recomputed. Note that if the locale
2210 * changes enough times, the index could wrap (a U32), and it is possible
2211 * that a transformation would improperly be considered valid, leading to
2212 * an unlikely bug */
2216 Safefree(PL_collation_name);
2217 PL_collation_name = NULL;
2218 PL_collation_standard = TRUE;
2219 is_standard_collation:
2220 PL_collxfrm_base = 0;
2221 PL_collxfrm_mult = 2;
2222 PL_in_utf8_COLLATE_locale = FALSE;
2223 PL_strxfrm_NUL_replacement = '\0';
2224 PL_strxfrm_max_cp = 0;
2228 /* If this is not the same locale as currently, set the new one up */
2229 if (strNE(PL_collation_name, newcoll)) {
2231 Safefree(PL_collation_name);
2232 PL_collation_name = savepv(newcoll);
2233 PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
2234 if (PL_collation_standard) {
2235 goto is_standard_collation;
2238 PL_in_utf8_COLLATE_locale = is_locale_utf8(newcoll);
2239 PL_strxfrm_NUL_replacement = '\0';
2240 PL_strxfrm_max_cp = 0;
2242 /* A locale collation definition includes primary, secondary, tertiary,
2243 * etc. weights for each character. To sort, the primary weights are
2244 * used, and only if they compare equal, then the secondary weights are
2245 * used, and only if they compare equal, then the tertiary, etc.
2247 * strxfrm() works by taking the input string, say ABC, and creating an
2248 * output transformed string consisting of first the primary weights,
2249 * A¹B¹C¹ followed by the secondary ones, A²B²C²; and then the
2250 * tertiary, etc, yielding A¹B¹C¹ A²B²C² A³B³C³ .... Some characters
2251 * may not have weights at every level. In our example, let's say B
2252 * doesn't have a tertiary weight, and A doesn't have a secondary
2253 * weight. The constructed string is then going to be
2254 * A¹B¹C¹ B²C² A³C³ ....
2255 * This has the desired effect that strcmp() will look at the secondary
2256 * or tertiary weights only if the strings compare equal at all higher
2257 * priority weights. The spaces shown here, like in
2259 * are not just for readability. In the general case, these must
2260 * actually be bytes, which we will call here 'separator weights'; and
2261 * they must be smaller than any other weight value, but since these
2262 * are C strings, only the terminating one can be a NUL (some
2263 * implementations may include a non-NUL separator weight just before
2264 * the NUL). Implementations tend to reserve 01 for the separator
2265 * weights. They are needed so that a shorter string's secondary
2266 * weights won't be misconstrued as primary weights of a longer string,
2267 * etc. By making them smaller than any other weight, the shorter
2268 * string will sort first. (Actually, if all secondary weights are
2269 * smaller than all primary ones, there is no need for a separator
2270 * weight between those two levels, etc.)
2272 * The length of the transformed string is roughly a linear function of
2273 * the input string. It's not exactly linear because some characters
2274 * don't have weights at all levels. When we call strxfrm() we have to
2275 * allocate some memory to hold the transformed string. The
2276 * calculations below try to find coefficients 'm' and 'b' for this
2277 * locale so that m*x + b equals how much space we need, given the size
2278 * of the input string in 'x'. If we calculate too small, we increase
2279 * the size as needed, and call strxfrm() again, but it is better to
2280 * get it right the first time to avoid wasted expensive string
2281 * transformations. */
2284 /* We use the string below to find how long the tranformation of it
2285 * is. Almost all locales are supersets of ASCII, or at least the
2286 * ASCII letters. We use all of them, half upper half lower,
2287 * because if we used fewer, we might hit just the ones that are
2288 * outliers in a particular locale. Most of the strings being
2289 * collated will contain a preponderance of letters, and even if
2290 * they are above-ASCII, they are likely to have the same number of
2291 * weight levels as the ASCII ones. It turns out that digits tend
2292 * to have fewer levels, and some punctuation has more, but those
2293 * are relatively sparse in text, and khw believes this gives a
2294 * reasonable result, but it could be changed if experience so
2296 const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
2297 char * x_longer; /* Transformed 'longer' */
2298 Size_t x_len_longer; /* Length of 'x_longer' */
2300 char * x_shorter; /* We also transform a substring of 'longer' */
2301 Size_t x_len_shorter;
2303 /* _mem_collxfrm() is used get the transformation (though here we
2304 * are interested only in its length). It is used because it has
2305 * the intelligence to handle all cases, but to work, it needs some
2306 * values of 'm' and 'b' to get it started. For the purposes of
2307 * this calculation we use a very conservative estimate of 'm' and
2308 * 'b'. This assumes a weight can be multiple bytes, enough to
2309 * hold any UV on the platform, and there are 5 levels, 4 weight
2310 * bytes, and a trailing NUL. */
2311 PL_collxfrm_base = 5;
2312 PL_collxfrm_mult = 5 * sizeof(UV);
2314 /* Find out how long the transformation really is */
2315 x_longer = _mem_collxfrm(longer,
2319 /* We avoid converting to UTF-8 in the
2320 * called function by telling it the
2321 * string is in UTF-8 if the locale is a
2322 * UTF-8 one. Since the string passed
2323 * here is invariant under UTF-8, we can
2324 * claim it's UTF-8 even though it isn't.
2326 PL_in_utf8_COLLATE_locale);
2329 /* Find out how long the transformation of a substring of 'longer'
2330 * is. Together the lengths of these transformations are
2331 * sufficient to calculate 'm' and 'b'. The substring is all of
2332 * 'longer' except the first character. This minimizes the chances
2333 * of being swayed by outliers */
2334 x_shorter = _mem_collxfrm(longer + 1,
2337 PL_in_utf8_COLLATE_locale);
2338 Safefree(x_shorter);
2340 /* If the results are nonsensical for this simple test, the whole
2341 * locale definition is suspect. Mark it so that locale collation
2342 * is not active at all for it. XXX Should we warn? */
2343 if ( x_len_shorter == 0
2344 || x_len_longer == 0
2345 || x_len_shorter >= x_len_longer)
2347 PL_collxfrm_mult = 0;
2348 PL_collxfrm_base = 0;
2351 SSize_t base; /* Temporary */
2353 /* We have both: m * strlen(longer) + b = x_len_longer
2354 * m * strlen(shorter) + b = x_len_shorter;
2355 * subtracting yields:
2356 * m * (strlen(longer) - strlen(shorter))
2357 * = x_len_longer - x_len_shorter
2358 * But we have set things up so that 'shorter' is 1 byte smaller
2359 * than 'longer'. Hence:
2360 * m = x_len_longer - x_len_shorter
2362 * But if something went wrong, make sure the multiplier is at
2365 if (x_len_longer > x_len_shorter) {
2366 PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
2369 PL_collxfrm_mult = 1;
2374 * but in case something has gone wrong, make sure it is
2376 base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
2381 /* Add 1 for the trailing NUL */
2382 PL_collxfrm_base = base + 1;
2385 DEBUG_L(PerlIO_printf(Perl_debug_log,
2386 "?UTF-8 locale=%d; x_len_shorter=%zu, "
2388 " collate multipler=%zu, collate base=%zu\n",
2389 PL_in_utf8_COLLATE_locale,
2390 x_len_shorter, x_len_longer,
2391 PL_collxfrm_mult, PL_collxfrm_base));
2395 # endif /* USE_LOCALE_COLLATE */
2399 #endif /* USE_LOCALE */
2404 Perl_Win_utf8_string_to_wstring(const char * utf8_string)
2408 int req_size = MultiByteToWideChar(CP_UTF8, 0, utf8_string, -1, NULL, 0);
2414 Newx(wstring, req_size, wchar_t);
2416 if (! MultiByteToWideChar(CP_UTF8, 0, utf8_string, -1, wstring, req_size))
2427 Perl_Win_wstring_to_utf8_string(const wchar_t * wstring)
2432 WideCharToMultiByte(CP_UTF8, 0, wstring, -1, NULL, 0, NULL, NULL);
2434 Newx(utf8_string, req_size, char);
2436 if (! WideCharToMultiByte(CP_UTF8, 0, wstring, -1, utf8_string,
2437 req_size, NULL, NULL))
2439 Safefree(utf8_string);
2447 #define USE_WSETLOCALE
2449 #ifdef USE_WSETLOCALE
2452 S_wrap_wsetlocale(pTHX_ int category, const char *locale) {
2453 wchar_t *wlocale = NULL;
2458 wlocale = Win_utf8_string_to_wstring(locale);
2467 wresult = _wsetlocale(category, wlocale);
2474 result = Win_wstring_to_utf8_string(wresult);
2475 SAVEFREEPV(result); /* is there something better we can do here? */
2483 S_win32_setlocale(pTHX_ int category, const char* locale)
2485 /* This, for Windows, emulates POSIX setlocale() behavior. There is no
2486 * difference between the two unless the input locale is "", which normally
2487 * means on Windows to get the machine default, which is set via the
2488 * computer's "Regional and Language Options" (or its current equivalent).
2489 * In POSIX, it instead means to find the locale from the user's
2490 * environment. This routine changes the Windows behavior to first look in
2491 * the environment, and, if anything is found, use that instead of going to
2492 * the machine default. If there is no environment override, the machine
2493 * default is used, by calling the real setlocale() with "".
2495 * The POSIX behavior is to use the LC_ALL variable if set; otherwise to
2496 * use the particular category's variable if set; otherwise to use the LANG
2499 bool override_LC_ALL = FALSE;
2503 if (locale && strEQ(locale, "")) {
2507 locale = PerlEnv_getenv("LC_ALL");
2509 if (category == LC_ALL) {
2510 override_LC_ALL = TRUE;
2516 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
2517 if (category == categories[i]) {
2518 locale = PerlEnv_getenv(category_names[i]);
2523 locale = PerlEnv_getenv("LANG");
2539 #ifdef USE_WSETLOCALE
2540 result = S_wrap_wsetlocale(aTHX_ category, locale);
2542 result = setlocale(category, locale);
2544 DEBUG_L(STMT_START {
2545 PerlIO_printf(Perl_debug_log, "%s\n",
2546 setlocale_debug_string_r(category, locale, result));
2549 if (! override_LC_ALL) {
2553 /* Here the input category was LC_ALL, and we have set it to what is in the
2554 * LANG variable or the system default if there is no LANG. But these have
2555 * lower priority than the other LC_foo variables, so override it for each
2556 * one that is set. (If they are set to "", it means to use the same thing
2557 * we just set LC_ALL to, so can skip) */
2559 for (i = 0; i < LC_ALL_INDEX_; i++) {
2560 result = PerlEnv_getenv(category_names[i]);
2561 if (result && strNE(result, "")) {
2562 #ifdef USE_WSETLOCALE
2563 S_wrap_wsetlocale(aTHX_ categories[i], result);
2565 setlocale(categories[i], result);
2567 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s\n",
2568 setlocale_debug_string_i(i, result, "not captured")));
2572 result = setlocale(LC_ALL, NULL);
2573 DEBUG_L(STMT_START {
2574 PerlIO_printf(Perl_debug_log, "%s\n",
2575 setlocale_debug_string_c(LC_ALL, NULL, result));
2584 =for apidoc Perl_setlocale
2586 This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
2587 taking the same parameters, and returning the same information, except that it
2588 returns the correct underlying C<LC_NUMERIC> locale. Regular C<setlocale> will
2589 instead return C<C> if the underlying locale has a non-dot decimal point
2590 character, or a non-empty thousands separator for displaying floating point
2591 numbers. This is because perl keeps that locale category such that it has a
2592 dot and empty separator, changing the locale briefly during the operations
2593 where the underlying one is required. C<Perl_setlocale> knows about this, and
2594 compensates; regular C<setlocale> doesn't.
2596 Another reason it isn't completely a drop-in replacement is that it is
2597 declared to return S<C<const char *>>, whereas the system setlocale omits the
2598 C<const> (presumably because its API was specified long ago, and can't be
2599 updated; it is illegal to change the information C<setlocale> returns; doing
2600 so leads to segfaults.)
2602 Finally, C<Perl_setlocale> works under all circumstances, whereas plain
2603 C<setlocale> can be completely ineffective on some platforms under some
2606 C<Perl_setlocale> should not be used to change the locale except on systems
2607 where the predefined variable C<${^SAFE_LOCALES}> is 1. On some such systems,
2608 the system C<setlocale()> is ineffective, returning the wrong information, and
2609 failing to actually change the locale. C<Perl_setlocale>, however works
2610 properly in all circumstances.
2612 The return points to a per-thread static buffer, which is overwritten the next
2613 time C<Perl_setlocale> is called from the same thread.
2619 #ifndef USE_LOCALE_NUMERIC
2620 # define affects_LC_NUMERIC(cat) 0
2621 #elif defined(LC_ALL)
2622 # define affects_LC_NUMERIC(cat) (cat == LC_NUMERIC || cat == LC_ALL)
2624 # define affects_LC_NUMERIC(cat) (cat == LC_NUMERIC)
2628 Perl_setlocale(const int category, const char * locale)
2630 /* This wraps POSIX::setlocale() */
2634 PERL_UNUSED_ARG(category);
2635 PERL_UNUSED_ARG(locale);
2641 const char * retval;
2644 DEBUG_L(PerlIO_printf(Perl_debug_log,
2645 "Entering Perl_setlocale(%d, \"%s\")\n",
2648 /* A NULL locale means only query what the current one is. */
2649 if (locale == NULL) {
2651 # ifndef USE_LOCALE_NUMERIC
2653 /* Without LC_NUMERIC, it's trivial; we just return the value */
2654 return save_to_buffer(querylocale_r(category),
2655 &PL_setlocale_buf, &PL_setlocale_bufsize);
2658 /* We have the LC_NUMERIC name saved, because we are normally switched
2659 * into the C locale (or equivalent) for it. */
2660 if (category == LC_NUMERIC) {
2661 DEBUG_L(PerlIO_printf(Perl_debug_log,
2662 "Perl_setlocale(LC_NUMERIC, NULL) returning stashed '%s'\n",
2665 /* We don't have to copy this return value, as it is a per-thread
2666 * variable, and won't change until a future setlocale */
2667 return PL_numeric_name;
2672 /* Without LC_ALL, just return the value */
2673 return save_to_buffer(querylocale_r(category),
2674 &PL_setlocale_buf, &PL_setlocale_bufsize);
2678 /* Here, LC_ALL is available on this platform. It's the one
2679 * complicating category (because it can contain a toggled LC_NUMERIC
2680 * value), for all the remaining ones (we took care of LC_NUMERIC
2681 * above), just return the value */
2682 if (category != LC_ALL) {
2683 return save_to_buffer(querylocale_r(category),
2684 &PL_setlocale_buf, &PL_setlocale_bufsize);
2687 bool toggled = FALSE;
2689 /* For an LC_ALL query, switch back to the underlying numeric locale
2690 * (if we aren't there already) so as to get the correct results. Our
2691 * records for all the other categories are valid without switching */
2692 if (! PL_numeric_underlying) {
2693 set_numeric_underlying();
2697 retval = querylocale_c(LC_ALL);
2700 set_numeric_standard();
2703 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",
2704 setlocale_debug_string_r(category, locale, retval)));
2706 return save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize);
2708 # endif /* Has LC_ALL */
2709 # endif /* Has LC_NUMERIC */
2711 } /* End of querying the current locale */
2714 /* Here, the input has a locale to change to. First find the current
2716 unsigned int cat_index = get_category_index(category, NULL);
2717 retval = querylocale_i(cat_index);
2719 /* If the new locale is the same as the current one, nothing is actually
2720 * being changed, so do nothing. */
2721 if ( strEQ(retval, locale)
2722 && ( ! affects_LC_NUMERIC(category)
2724 # ifdef USE_LOCALE_NUMERIC
2726 || strEQ(locale, PL_numeric_name)
2731 DEBUG_L(PerlIO_printf(Perl_debug_log,
2732 "Already in requested locale: no action taken\n"));
2733 return save_to_buffer(setlocale_i(cat_index, locale),
2734 &PL_setlocale_buf, &PL_setlocale_bufsize);
2737 /* Here, an actual change is being requested. Do it */
2738 retval = setlocale_i(cat_index, locale);
2740 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",
2741 setlocale_debug_string_i(cat_index, locale, "NULL")));
2745 retval = save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize);
2747 /* Now that have changed locales, we have to update our records to
2748 * correspond. Only certain categories have extra work to update. */
2749 if (update_functions[cat_index]) {
2750 update_functions[cat_index](aTHX_ retval);
2753 DEBUG_L(PerlIO_printf(Perl_debug_log, "returning '%s'\n", retval));
2764 S_save_to_buffer(const char * string, const char **buf, Size_t *buf_size)
2766 /* Copy the NUL-terminated 'string' to a buffer whose address before this
2767 * call began at *buf, and whose available length before this call was
2770 * If the length of 'string' is greater than the space available, the
2771 * buffer is grown accordingly, which may mean that it gets relocated.
2772 * *buf and *buf_size will be updated to reflect this.
2774 * Regardless, the function returns a pointer to where 'string' is now
2777 * 'string' may be NULL, which means no action gets taken, and NULL is
2780 * If *buf or 'buf_size' are NULL or *buf_size is 0, the buffer is assumed
2781 * empty, and memory is malloc'd. 'buf-size' being NULL is to be used
2782 * when this is a single use buffer, which will shortly be freed by the
2788 PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
2794 string_size = strlen(string) + 1;
2796 if (buf_size == NULL) {
2797 Newx(*buf, string_size, char);
2799 else if (*buf_size == 0) {
2800 Newx(*buf, string_size, char);
2801 *buf_size = string_size;
2803 else if (string_size > *buf_size) {
2804 Renew(*buf, string_size, char);
2805 *buf_size = string_size;
2810 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2811 "Copying '%s' to %p\n",
2812 ((is_utf8_string((U8 *) string, 0))
2814 :_byte_dump_string((U8 *) string, strlen(string), 0)),
2818 Copy(string, *buf, string_size, char);
2823 S_get_locale_string_utf8ness_i(pTHX_ const char * locale,
2824 const unsigned cat_index,
2825 const char * string,
2826 const locale_utf8ness_t known_utf8)
2828 /* Return to indicate if 'string' in the locale given by the input
2829 * arguments should be considered UTF-8 or not.
2831 * If the input 'locale' is not NULL, use that for the locale; otherwise
2832 * use the current locale for the category specified by 'cat_index'.
2836 const U8 * first_variant = NULL;
2838 PERL_ARGS_ASSERT_GET_LOCALE_STRING_UTF8NESS_I;
2839 assert(cat_index <= NOMINAL_LC_ALL_INDEX);
2841 if (string == NULL) {
2845 if (IN_BYTES) { /* respect 'use bytes' */
2849 len = strlen(string);
2851 /* UTF8ness is immaterial if the representation doesn't vary */
2852 if (is_utf8_invariant_string_loc((U8 *) string, len, &first_variant)) {
2853 return UTF8NESS_IMMATERIAL;
2856 /* Can't be UTF-8 if invalid */
2857 if (! is_utf8_string((U8 *) first_variant,
2858 len - ((char *) first_variant - string)))
2863 /* Here and below, we know the string is legal UTF-8, containing at least
2864 * one character requiring a sequence of two or more bytes. It is quite
2865 * likely to be UTF-8. But it pays to be paranoid and do further checking.
2867 * If we already know the UTF-8ness of the locale, then we immediately know
2868 * what the string is */
2869 if (UNLIKELY(known_utf8 != LOCALE_UTF8NESS_UNKNOWN)) {
2870 if (known_utf8 == LOCALE_IS_UTF8) {
2871 return UTF8NESS_YES;
2878 # if defined(HAS_SOME_LANGINFO) || defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
2880 /* Here, we have available the libc functions that can be used to
2881 * accurately determine the UTF8ness of the underlying locale. If it is a
2882 * UTF-8 locale, the string is UTF-8; otherwise it was coincidental that
2883 * the string is legal UTF-8
2885 * However, if the perl is compiled to not pay attention to the category
2886 * being passed in, you might think that that locale is essentially always
2887 * the C locale, so it would make sense to say it isn't UTF-8. But to get
2888 * here, the string has to contain characters unknown in the C locale. And
2889 * in fact, Windows boxes are compiled without LC_MESSAGES, as their
2890 * message catalog isn't really a part of the locale system. But those
2891 * messages really could be UTF-8, and given that the odds are rather small
2892 * of something not being UTF-8 but being syntactically valid UTF-8, khw
2893 * has decided to call such strings as UTF-8. */
2895 if (locale == NULL) {
2896 locale = querylocale_i(cat_index);
2898 if (is_locale_utf8(locale)) {
2899 return UTF8NESS_YES;
2906 /* Here, we have a valid UTF-8 string containing non-ASCII characters, and
2907 * don't have access to functions to check if the locale is UTF-8 or not.
2908 * Assume that it is. khw tried adding a check that the string is entirely
2909 * in a single Unicode script, but discovered the strftime() timezone is
2910 * user-settable through the environment, which may be in a different
2911 * script than the locale-expected value. */
2912 PERL_UNUSED_ARG(locale);
2913 PERL_UNUSED_ARG(cat_index);
2915 return UTF8NESS_YES;
2921 #endif /* USE_LOCALE */
2924 Perl_mbtowc_(pTHX_ const wchar_t * pwc, const char * s, const Size_t len)
2927 #if ! defined(HAS_MBRTOWC) && ! defined(HAS_MBTOWC)
2929 PERL_UNUSED_ARG(pwc);
2931 PERL_UNUSED_ARG(len);
2934 #else /* Below we have some form of mbtowc() */
2935 # if defined(HAS_MBRTOWC) \
2936 && (defined(USE_LOCALE_THREADS) || ! defined(HAS_MBTOWC))
2937 # define USE_MBRTOWC
2944 if (s == NULL) { /* Initialize the shift state to all zeros in
2947 # if defined(USE_MBRTOWC)
2949 memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
2956 retval = mbtowc(NULL, NULL, 0);
2964 # if defined(USE_MBRTOWC)
2967 retval = (SSize_t) mbrtowc((wchar_t *) pwc, s, len, &PL_mbrtowc_ps);
2971 /* Locking prevents races, but locales can be switched out without locking,
2972 * so this isn't a cure all */
2975 retval = mbtowc((wchar_t *) pwc, s, len);
2987 =for apidoc Perl_localeconv
2989 This is a thread-safe version of the libc L<localeconv(3)>. It is the same as
2990 L<POSIX::localeconv|POSIX/localeconv> (returning a hash of the C<localeconv()>
2991 fields), but directly callable from XS code.
2997 Perl_localeconv(pTHX)
3000 #if ! defined(HAS_SOME_LOCALECONV) \
3001 || (! defined(USE_LOCALE_MONETARY) && ! defined(USE_LOCALE_NUMERIC))
3007 return my_localeconv(0, LOCALE_UTF8NESS_UNKNOWN);
3013 #if defined(HAS_SOME_LOCALECONV) \
3014 && (defined(USE_LOCALE_MONETARY) || defined(USE_LOCALE_NUMERIC))
3017 S_my_localeconv(pTHX_ const int item, const locale_utf8ness_t locale_is_utf8)
3020 locale_utf8ness_t numeric_locale_is_utf8 = LOCALE_UTF8NESS_UNKNOWN;
3021 locale_utf8ness_t monetary_locale_is_utf8 = LOCALE_UTF8NESS_UNKNOWN;
3022 HV * (*copy_localeconv)(pTHX_ const struct lconv *,
3024 const locale_utf8ness_t,
3025 const locale_utf8ness_t);
3027 /* A thread-safe locale_conv(). The locking mechanisms vary greatly
3028 * depending on platform capabilities. They all share this common set up
3029 * code for the function, and then conditional compilations choose one of
3030 * several terminations.
3032 * There are two use cases:
3033 * 1) Called from POSIX::locale_conv(). This returns lconv() copied to
3034 * a hash, based on the current underlying locale.
3035 * 2) Certain items that nl_langinfo() provides are also derivable from
3036 * the return of localeconv(). Windows notably doesn't have
3037 * nl_langinfo(), so on that, and actually any platform lacking it,
3038 * my_localeconv() is used to emulate it for those particular items.
3039 * The code to do this is compiled only on such platforms. Rather than
3040 * going to the expense of creating a full hash when only one item is
3041 * needed, just the desired item is returned, in an SV cast to an HV.
3043 * There is a helper function to accomplish each of the two tasks. The
3044 * function pointer just below is set to the appropriate one, and is called
3045 * from each of the various implementations, in the middle of whatever
3046 * necessary locking/locale swapping have been done. */
3048 # ifdef HAS_SOME_LANGINFO
3050 PERL_UNUSED_ARG(item);
3051 PERL_UNUSED_ARG(locale_is_utf8);
3053 # ifdef USE_LOCALE_NUMERIC
3055 /* When there is a nl_langinfo, we will only be called for localeconv
3056 * numeric purposes. */
3057 const bool is_localeconv_call = true;
3063 /* Note we use this sentinel; this works because this only gets compiled
3064 * when our perl_langinfo.h is used, and that uses negative numbers for all
3066 const bool is_localeconv_call = (item == 0);
3067 if (is_localeconv_call)
3072 copy_localeconv = S_populate_localeconv;
3074 # ifdef USE_LOCALE_NUMERIC
3076 /* Get the UTF8ness of the locales now to avoid repeating this for each
3077 * string returned by localeconv() */
3078 numeric_locale_is_utf8 = (is_locale_utf8(PL_numeric_name))
3083 # ifdef USE_LOCALE_MONETARY
3085 monetary_locale_is_utf8 = (is_locale_utf8(querylocale_c(LC_MONETARY)))
3093 # ifndef HAS_SOME_LANGINFO
3096 copy_localeconv = S_get_nl_item_from_localeconv;
3097 numeric_locale_is_utf8 = locale_is_utf8;
3102 PERL_ARGS_ASSERT_MY_LOCALECONV;
3103 /*--------------------------------------------------------------------------*/
3104 /* Here, we are done with the common beginning of all the implementations of
3105 * my_localeconv(). Below are the various terminations of the function (except
3106 * the closing '}'. They are separated out because the preprocessor directives
3107 * were making the simple logic hard to follow. Each implementation ends with
3108 * the same few lines. khw decided to keep those separate because he thought
3109 * it was clearer to the reader.
3111 * The first distinct termination (of the above common code) are the
3112 * implementations when we have locale_conv_l() and can use it. These are the
3113 * simplest cases, without any locking needed. */
3114 # if defined(USE_POSIX_2008_LOCALE) && defined(HAS_LOCALECONV_L)
3116 /* And there are two sub-cases: First (by far the most common) is where we
3117 * are compiled to pay attention to LC_NUMERIC */
3118 # ifdef USE_LOCALE_NUMERIC
3120 const locale_t cur = use_curlocale_scratch();
3121 locale_t with_numeric = duplocale(cur);
3123 /* Just create a new locale object with what we've got, but using the
3124 * underlying LC_NUMERIC locale */
3125 with_numeric = newlocale(LC_NUMERIC_MASK, PL_numeric_name, with_numeric);
3127 retval = copy_localeconv(aTHX_ localeconv_l(with_numeric),
3129 numeric_locale_is_utf8,
3130 monetary_locale_is_utf8);
3131 freelocale(with_numeric);
3135 /*--------------------------------------------------------------------------*/
3136 # else /* Below not paying attention to LC_NUMERIC */
3138 const locale_t cur = use_curlocale_scratch();
3140 retval = copy_localeconv(aTHX_ localeconv_l(cur),
3142 numeric_locale_is_utf8,
3143 monetary_locale_is_utf8);
3146 # endif /* Above, using lconv_l(); below plain lconv() */
3147 /*--------------------------------------------------------------------------*/
3148 # elif ! defined(TS_W32_BROKEN_LOCALECONV) /* Next is regular lconv() */
3150 /* There are so many locks because localeconv() deals with two
3151 * categories, and returns in a single global static buffer. Some
3152 * locks might be no-ops on this platform, but not others. We need to
3153 * lock if any one isn't a no-op. */
3155 # ifdef USE_LOCALE_NUMERIC
3158 const char * orig_switched_locale = NULL;
3160 /* When called internally, are already switched into the proper numeric
3161 * locale; otherwise must toggle to it */
3162 if (is_localeconv_call) {
3163 orig_switched_locale = toggle_locale_c(LC_NUMERIC, PL_numeric_name);
3169 retval = copy_localeconv(aTHX_ localeconv(),
3171 numeric_locale_is_utf8,
3172 monetary_locale_is_utf8);
3175 # ifdef USE_LOCALE_NUMERIC
3177 if (orig_switched_locale) {
3178 restore_toggled_locale_c(LC_NUMERIC, orig_switched_locale);
3186 /*--------------------------------------------------------------------------*/
3187 # else /* defined(TS_W32_BROKEN_LOCALECONV) */
3189 /* Last is a workaround for the broken localeconv() on Windows with
3190 * thread-safe locales prior to VS 15. It looks at the global locale
3191 * instead of the thread one. As a work-around, we toggle to the global
3192 * locale; populate the return; then toggle back. We have to use LC_ALL
3193 * instead of the individual categories because of another bug in Windows.
3195 * This introduces a potential race with any other thread that has also
3196 * converted to use the global locale, and doesn't protect its locale calls
3197 * with mutexes. khw can't think of any reason for a thread to do so on
3198 * Windows, as the locale API is the same regardless of thread-safety, except
3199 * if the code is ported from working on another platform where there might
3200 * be some reason to do this. But this is typically due to some
3201 * alien-to-Perl library that thinks it owns locale setting. Such a
3202 * library usn't likely to exist on Windows, so such an application is
3203 * unlikely to be run on Windows
3205 bool restore_per_thread = FALSE;
3207 # ifdef USE_LOCALE_NUMERIC
3209 const char * orig_switched_locale = NULL;
3213 /* When called internally, are already switched into the proper numeric
3214 * locale; otherwise must toggle to it */
3215 if (is_localeconv_call) {
3216 orig_switched_locale = toggle_locale_c(LC_NUMERIC, PL_numeric_name);
3221 /* Save the per-thread locale state */
3222 const char * save_thread = querylocale_c(LC_ALL);
3224 /* Change to the global locale, and note if we already were there */
3225 if (_configthreadlocale(_DISABLE_PER_THREAD_LOCALE)
3226 != _DISABLE_PER_THREAD_LOCALE)
3228 restore_per_thread = TRUE;
3231 /* Save the state of the global locale; then convert to our desired
3233 const char * save_global = querylocale_c(LC_ALL);
3234 void_setlocale_c(LC_ALL, save_thread);
3236 /* Safely stash the desired data */
3238 retval = copy_localeconv(aTHX_ localeconv(),
3240 numeric_locale_is_utf8,
3241 monetary_locale_is_utf8);
3244 /* Restore the global locale's prior state */
3245 void_setlocale_c(LC_ALL, save_global);
3247 /* And back to per-thread locales */
3248 if (restore_per_thread) {
3249 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
3252 /* Restore the per-thread locale state */
3253 void_setlocale_c(LC_ALL, save_thread);
3255 # ifdef USE_LOCALE_NUMERIC
3257 if (orig_switched_locale) {
3258 restore_toggled_locale_c(LC_NUMERIC, orig_switched_locale);
3267 /*--------------------------------------------------------------------------*/
3271 S_populate_localeconv(pTHX_ const struct lconv *lcbuf,
3273 const locale_utf8ness_t numeric_locale_is_utf8,
3274 const locale_utf8ness_t monetary_locale_is_utf8)
3276 /* This returns a mortalized hash containing all the elements returned by
3277 * localeconv(). It is used by Perl_localeconv() and POSIX::localeconv()
3279 PERL_UNUSED_ARG(unused);
3281 struct lconv_offset {
3287 {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)},
3289 # define LCONV_ENTRY(name) \
3290 {STRINGIFY(name), STRUCT_OFFSET(struct lconv, name)}
3292 /* Set up structures containing the documented fields. One structure for
3293 * LC_NUMERIC-controlled strings; one for LC_MONETARY ones, and a final one
3294 * of just numerics. */
3295 # ifdef USE_LOCALE_NUMERIC
3297 static const struct lconv_offset lconv_numeric_strings[] = {
3298 LCONV_ENTRY(decimal_point),
3299 LCONV_ENTRY(thousands_sep),
3300 # ifndef NO_LOCALECONV_GROUPING
3301 LCONV_ENTRY(grouping),
3307 # ifdef USE_LOCALE_MONETARY
3309 static const struct lconv_offset lconv_monetary_strings[] = {
3310 LCONV_ENTRY(int_curr_symbol),
3311 LCONV_ENTRY(currency_symbol),
3312 LCONV_ENTRY(mon_decimal_point),
3313 # ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
3314 LCONV_ENTRY(mon_thousands_sep),
3316 # ifndef NO_LOCALECONV_MON_GROUPING
3317 LCONV_ENTRY(mon_grouping),
3319 LCONV_ENTRY(positive_sign),
3320 LCONV_ENTRY(negative_sign),
3326 static const struct lconv_offset lconv_integers[] = {
3327 # ifdef USE_LOCALE_MONETARY
3328 LCONV_ENTRY(int_frac_digits),
3329 LCONV_ENTRY(frac_digits),
3330 LCONV_ENTRY(p_cs_precedes),
3331 LCONV_ENTRY(p_sep_by_space),
3332 LCONV_ENTRY(n_cs_precedes),
3333 LCONV_ENTRY(n_sep_by_space),
3334 LCONV_ENTRY(p_sign_posn),
3335 LCONV_ENTRY(n_sign_posn),
3336 # ifdef HAS_LC_MONETARY_2008
3337 LCONV_ENTRY(int_p_cs_precedes),
3338 LCONV_ENTRY(int_p_sep_by_space),
3339 LCONV_ENTRY(int_n_cs_precedes),
3340 LCONV_ENTRY(int_n_sep_by_space),
3341 LCONV_ENTRY(int_p_sign_posn),
3342 LCONV_ENTRY(int_n_sign_posn),
3348 static const unsigned category_indices[] = {
3349 # ifdef USE_LOCALE_NUMERIC
3352 # ifdef USE_LOCALE_MONETARY
3355 (unsigned) -1 /* Just so the previous element can always end with a
3356 comma => subtract 1 below for the max loop index */
3359 const char *ptr = (const char *) lcbuf;
3360 const struct lconv_offset *integers = lconv_integers;
3362 HV * retval = newHV();
3363 sv_2mortal((SV*)retval);
3365 PERL_ARGS_ASSERT_POPULATE_LOCALECONV;
3367 /* For each enabled category ... */
3368 for (PERL_UINT_FAST8_T i = 0; i < C_ARRAY_LENGTH(category_indices) - 1; i++) {
3369 const unsigned cat_index = category_indices[i];
3370 locale_utf8ness_t locale_is_utf8 = LOCALE_UTF8NESS_UNKNOWN;
3373 /* ( = NULL silences a compiler warning; would segfault if it could
3374 * actually happen.) */
3375 const struct lconv_offset *strings = NULL;
3377 # ifdef USE_LOCALE_NUMERIC
3378 if (cat_index == LC_NUMERIC_INDEX_) {
3379 locale_is_utf8 = numeric_locale_is_utf8;
3380 strings = lconv_numeric_strings;
3383 PERL_UNUSED_ARG(numeric_locale_is_utf8);
3385 # ifdef USE_LOCALE_MONETARY
3386 if (cat_index == LC_MONETARY_INDEX_) {
3387 locale_is_utf8 = monetary_locale_is_utf8;
3388 strings = lconv_monetary_strings;
3391 PERL_UNUSED_ARG(monetary_locale_is_utf8);
3394 assert(locale_is_utf8 != LOCALE_UTF8NESS_UNKNOWN);
3396 /* Iterate over the strings structure for this category */
3397 locale = querylocale_i(cat_index);
3399 while (strings->name) {
3400 const char *value = *((const char **)(ptr + strings->offset));
3401 if (value && *value) {
3402 bool is_utf8 = /* Only make UTF-8 if required to */
3403 (UTF8NESS_YES == (get_locale_string_utf8ness_i(locale,
3407 (void) hv_store(retval,
3409 strlen(strings->name),
3410 newSVpvn_utf8(value, strlen(value), is_utf8),
3418 while (integers->name) {
3419 const char value = *((const char *)(ptr + integers->offset));
3421 if (value != CHAR_MAX)
3422 (void) hv_store(retval, integers->name,
3423 strlen(integers->name), newSViv(value), 0);
3430 # ifndef HAS_SOME_LANGINFO
3433 S_get_nl_item_from_localeconv(pTHX_ const struct lconv *lcbuf,
3435 const locale_utf8ness_t unused1,
3436 const locale_utf8ness_t unused2)
3438 /* This is a helper function for my_localeconv(), which is called from
3439 * my_langinfo() to emulate the libc nl_langinfo() function on platforms
3440 * that don't have it available.
3442 * This function acts as an extension to my_langinfo(), the intermediate
3443 * my_localeconv() call is to set up the locks and switch into the proper
3444 * locale. That logic exists for other reasons, and by doing it this way,
3445 * it doesn't have to be duplicated.
3447 * This function extracts the current value of 'item' in the current locale
3448 * using the localconv() result also passed in, via 'lcbuf'. The other
3449 * parameter is unused, a placeholder so the signature of this function
3450 * matches another that does need it, and so the two functions can be
3451 * referred to by a single function pointer, to simplify the code below */
3453 const char * prefix = "";
3454 const char * temp = NULL;
3456 PERL_ARGS_ASSERT_GET_NL_ITEM_FROM_LOCALECONV;
3457 PERL_UNUSED_ARG(unused1);
3458 PERL_UNUSED_ARG(unused2);
3462 temp = lcbuf->currency_symbol;
3464 if (lcbuf->p_cs_precedes) {
3466 /* khw couldn't find any documentation that CHAR_MAX is the signal,
3467 * but cygwin uses it thusly */
3468 if (lcbuf->p_cs_precedes == CHAR_MAX) {
3482 temp = lcbuf->decimal_point;
3486 temp = lcbuf->thousands_sep;
3490 locale_panic_(Perl_form(aTHX_
3491 "Unexpected item passed to populate_localeconv: %d", item));
3494 return (HV *) Perl_newSVpvf(aTHX_ "%s%s", prefix, temp);
3497 # endif /* ! Has some form of langinfo() */
3498 #endif /* Has some form of localeconv() and paying attn to a category it
3501 #ifndef HAS_SOME_LANGINFO
3503 typedef int nl_item; /* Substitute 'int' for emulated nl_langinfo() */
3509 =for apidoc Perl_langinfo
3510 =for apidoc_item Perl_langinfo8
3512 C<Perl_langinfo> is an (almost) drop-in replacement for the system
3513 C<L<nl_langinfo(3)>>, taking the same C<item> parameter values, and returning
3514 the same information. But it is more thread-safe than regular
3515 C<nl_langinfo()>, and hides the quirks of Perl's locale handling from your
3516 code, and can be used on systems that lack a native C<nl_langinfo>.
3518 However, you should instead use the improved version of this:
3519 L</Perl_langinfo8>, which behaves identically except for an additional
3520 parameter, a pointer to a variable declared as L</C<utf8ness_t>>, into which it
3521 returns to you how you should treat the returned string with regards to it
3522 being encoded in UTF-8 or not.
3524 Concerning the differences between these and plain C<nl_langinfo()>:
3530 C<Perl_langinfo8> has an extra parameter, described above. Besides this, the
3531 other reasons they aren't quite a drop-in replacement is actually an advantage.
3532 The C<const>ness of the return allows the compiler to catch attempts to write
3533 into the returned buffer, which is illegal and could cause run-time crashes.
3537 They deliver the correct results for the C<RADIXCHAR> and C<THOUSEP> items,
3538 without you having to write extra code. The reason for the extra code would be
3539 because these are from the C<LC_NUMERIC> locale category, which is normally
3540 kept set by Perl so that the radix is a dot, and the separator is the empty
3541 string, no matter what the underlying locale is supposed to be, and so to get
3542 the expected results, you have to temporarily toggle into the underlying
3543 locale, and later toggle back. (You could use plain C<nl_langinfo> and
3544 C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this but then you wouldn't get
3545 the other advantages of C<Perl_langinfo()>; not keeping C<LC_NUMERIC> in the C
3546 (or equivalent) locale would break a lot of CPAN, which is expecting the radix
3547 (decimal point) character to be a dot.)
3551 The system function they replace can have its static return buffer trashed,
3552 not only by a subsequent call to that function, but by a C<freelocale>,
3553 C<setlocale>, or other locale change. The returned buffer of these functions
3554 is not changed until the next call to one or the other, so the buffer is never
3559 The return buffer is per-thread, so it also is never overwritten by a call to
3560 these functions from another thread; unlike the function it replaces.
3564 But most importantly, they work on systems that don't have C<nl_langinfo>, such
3565 as Windows, hence making your code more portable. Of the fifty-some possible
3566 items specified by the POSIX 2008 standard,
3567 L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
3568 only one is completely unimplemented, though on non-Windows platforms, another
3569 significant one is not fully implemented). They use various techniques to
3570 recover the other items, including calling C<L<localeconv(3)>>, and
3571 C<L<strftime(3)>>, both of which are specified in C89, so should be always be
3572 available. Later C<strftime()> versions have additional capabilities; C<""> is
3573 returned for any item not available on your system.
3575 It is important to note that, when called with an item that is recovered by
3576 using C<localeconv>, the buffer from any previous explicit call to
3577 C<L<localeconv(3)>> will be overwritten. But you shouldn't be using
3578 C<localeconv> anyway because it is is very much not thread-safe, and suffers
3579 from the same problems outlined in item 'b.' above for the fields it returns that
3580 are controlled by the LC_NUMERIC locale category. Instead, avoid all of those
3581 problems by calling L</Perl_localeconv>, which is thread-safe; or by using the
3582 methods given in L<perlcall> to call
3583 L<C<POSIX::localeconv()>|POSIX/localeconv>, which is also thread-safe.
3587 The details for those items which may deviate from what this emulation returns
3588 and what a native C<nl_langinfo()> would return are specified in
3591 When using C<Perl_langinfo8> (or plain C<Perl_langinfo>) on systems that don't
3592 have a native C<nl_langinfo()>, you must
3594 #include "perl_langinfo.h"
3596 before the C<perl.h> C<#include>. You can replace your C<langinfo.h>
3597 C<#include> with this one. (Doing it this way keeps out the symbols that plain
3598 C<langinfo.h> would try to import into the namespace for code that doesn't need
3606 Perl_langinfo(const nl_item item)
3608 return Perl_langinfo8(item, NULL);
3612 Perl_langinfo8(const nl_item item, utf8ness_t * utf8ness)
3617 PERL_ARGS_ASSERT_PERL_LANGINFO8;
3619 if (utf8ness) { /* Assume for now */
3620 *utf8ness = UTF8NESS_IMMATERIAL;
3623 /* Find the locale category that controls the input 'item'. If we are not
3624 * paying attention to that category, instead return a default value. Also
3625 * return the default value if there is no way for us to figure out the
3626 * correct value. If we have some form of nl_langinfo(), we can always
3627 * figure it out, but lacking that, there may be alternative methods that
3628 * can be used to recover most of the possible items. Some of those
3629 * methods need libc functions, which may or may not be available. If
3630 * unavailable, we can't compute the correct value, so must here return the
3636 #ifdef USE_LOCALE_CTYPE
3638 cat_index = LC_CTYPE_INDEX_;
3644 #if defined(USE_LOCALE_MESSAGES) && defined(HAS_SOME_LANGINFO)
3646 case YESEXPR: case YESSTR: case NOEXPR: case NOSTR:
3647 cat_index = LC_MESSAGES_INDEX_;
3650 case YESEXPR: return "^[+1yY]";
3651 case YESSTR: return "yes";
3652 case NOEXPR: return "^[-0nN]";
3653 case NOSTR: return "no";
3658 #if defined(USE_LOCALE_MONETARY) \
3659 && (defined(HAS_SOME_LANGINFO) || defined(HAS_SOME_LOCALECONV))
3661 cat_index = LC_MONETARY_INDEX_;
3669 #ifdef CAN_CALCULATE_RADIX
3671 cat_index = LC_NUMERIC_INDEX_;
3674 return C_decimal_point;
3679 #if defined(USE_LOCALE_NUMERIC) \
3680 && (defined(HAS_SOME_LANGINFO) || defined(HAS_SOME_LOCALECONV))
3682 cat_index = LC_NUMERIC_INDEX_;
3685 return C_thousands_sep;
3688 /* The other possible items are all in LC_TIME. */
3689 #ifdef USE_LOCALE_TIME
3692 cat_index = LC_TIME_INDEX_;
3696 #if ! defined(USE_LOCALE_TIME) || ! defined(HAS_SOME_LANGINFO)
3698 /* If not using LC_TIME, hard code the rest. Or, if there is no
3699 * nl_langinfo(), we use strftime() as an alternative, and it is missing
3700 * functionality to get every single one, so hard-code those */
3702 case ERA: return ""; /* Unimplemented; for use with strftime() %E
3705 /* These formats are defined by C89, so we assume that strftime supports
3706 * them, and so are returned unconditionally; they may not be what the
3707 * locale actually says, but should give good enough results for someone
3708 * using them as formats (as opposed to trying to parse them to figure
3709 * out what the locale says). The other format items are actually tested
3710 * to verify they work on the platform */
3711 case D_FMT: return "%x";
3712 case T_FMT: return "%X";
3713 case D_T_FMT: return "%c";
3715 # if defined(WIN32) || ! defined(USE_LOCALE_TIME)
3717 /* strftime() on Windows doesn't have the POSIX (beyond C89) extensions
3718 * that would allow it to recover these */
3719 case ERA_D_FMT: return "%x";
3720 case ERA_T_FMT: return "%X";
3721 case ERA_D_T_FMT: return "%c";
3722 case ALT_DIGITS: return "0";
3725 # ifndef USE_LOCALE_TIME
3727 case T_FMT_AMPM: return "%r";
3728 case ABDAY_1: return "Sun";
3729 case ABDAY_2: return "Mon";
3730 case ABDAY_3: return "Tue";
3731 case ABDAY_4: return "Wed";
3732 case ABDAY_5: return "Thu";
3733 case ABDAY_6: return "Fri";
3734 case ABDAY_7: return "Sat";
3735 case AM_STR: return "AM";
3736 case PM_STR: return "PM";
3737 case ABMON_1: return "Jan";
3738 case ABMON_2: return "Feb";
3739 case ABMON_3: return "Mar";
3740 case ABMON_4: return "Apr";
3741 case ABMON_5: return "May";
3742 case ABMON_6: return "Jun";
3743 case ABMON_7: return "Jul";
3744 case ABMON_8: return "Aug";
3745 case ABMON_9: return "Sep";
3746 case ABMON_10: return "Oct";
3747 case ABMON_11: return "Nov";
3748 case ABMON_12: return "Dec";
3749 case DAY_1: return "Sunday";
3750 case DAY_2: return "Monday";
3751 case DAY_3: return "Tuesday";
3752 case DAY_4: return "Wednesday";
3753 case DAY_5: return "Thursday";
3754 case DAY_6: return "Friday";
3755 case DAY_7: return "Saturday";
3756 case MON_1: return "January";
3757 case MON_2: return "February";
3758 case MON_3: return "March";
3759 case MON_4: return "April";
3760 case MON_5: return "May";
3761 case MON_6: return "June";
3762 case MON_7: return "July";
3763 case MON_8: return "August";
3764 case MON_9: return "September";
3765 case MON_10: return "October";
3766 case MON_11: return "November";
3767 case MON_12: return "December";
3772 } /* End of switch on item */
3776 Perl_croak_nocontext("panic: Unexpected nl_langinfo() item %d", item);
3777 NOT_REACHED; /* NOTREACHED */
3778 PERL_UNUSED_VAR(cat_index);
3781 # ifdef USE_LOCALE_NUMERIC
3783 /* Use either the underlying numeric, or the other underlying categories */
3784 if (cat_index == LC_NUMERIC_INDEX_) {
3785 return my_langinfo_c(item, LC_NUMERIC, PL_numeric_name,
3786 &PL_langinfo_buf, &PL_langinfo_bufsize, utf8ness);
3793 return my_langinfo_i(item, cat_index, querylocale_i(cat_index),
3794 &PL_langinfo_buf, &PL_langinfo_bufsize, utf8ness);
3803 /* There are several implementations of my_langinfo, depending on the
3804 * Configuration. They all share the same beginning of the function */
3806 S_my_langinfo_i(pTHX_
3807 const nl_item item, /* The item to look up */
3808 const unsigned int cat_index, /* The locale category that
3810 /* The locale to look up 'item' in. */
3811 const char * locale,
3813 /* Where to store the result, and where the size of that buffer
3814 * is stored, updated on exit. retbuf_sizep may be NULL for an
3815 * empty-on-entry, single use buffer whose size we don't need
3816 * to keep track of */
3817 const char ** retbufp,
3818 Size_t * retbuf_sizep,
3820 /* If not NULL, the location to store the UTF8-ness of 'item's
3821 * value, as documented */
3822 utf8ness_t * utf8ness)
3824 const char * retval = NULL;
3826 PERL_ARGS_ASSERT_MY_LANGINFO_I;
3827 assert(cat_index <= NOMINAL_LC_ALL_INDEX);
3829 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3830 "Entering my_langinfo item=%d, using locale %s\n",
3832 /*--------------------------------------------------------------------------*/
3833 /* Above is the common beginning to all the implementations of my_langinfo().
3834 * Below are the various completions.
3836 * Some platforms don't deal well with non-ASCII strings in locale X when
3837 * LC_CTYPE is not in X. (Actually it is probably when X is UTF-8 and LC_CTYPE
3838 * isn't, or vice versa). There is explicit code to bring the categories into
3839 * sync. This doesn't seem to be a problem with nl_langinfo(), so that
3840 * implementation doesn't currently worry about it. But it is a problem on
3841 * Windows boxes, which don't have nl_langinfo(). */
3843 # if defined(HAS_THREAD_SAFE_NL_LANGINFO_L) && defined(USE_POSIX_2008_LOCALE)
3845 /* Simplest is if we can use nl_langinfo_l()
3847 * With it, we can change LC_CTYPE in the same call as the other category */
3848 # ifdef USE_LOCALE_CTYPE
3849 # define CTYPE_SAFETY_MASK LC_CTYPE_MASK
3851 # define CTYPE_SAFETY_MASK 0
3854 locale_t cur = newlocale((category_masks[cat_index] | CTYPE_SAFETY_MASK),
3855 locale, (locale_t) 0);
3857 retval = save_to_buffer(nl_langinfo_l(item, cur), retbufp, retbuf_sizep);
3859 *utf8ness = get_locale_string_utf8ness_i(locale, cat_index, retval,
3860 LOCALE_UTF8NESS_UNKNOWN);
3866 /*--------------------------------------------------------------------------*/
3867 # elif defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
3869 /* The second version of my_langinfo() is if we have plain nl_langinfo() */
3871 # ifdef USE_LOCALE_CTYPE
3873 /* Ths function sorts out if things actually have to be switched or not,
3874 * for both calls. */
3875 const char * orig_CTYPE_locale = toggle_locale_c(LC_CTYPE, locale);
3879 const char * orig_switched_locale = toggle_locale_i(cat_index, locale);
3882 retval = save_to_buffer(nl_langinfo(item), retbufp, retbuf_sizep);
3886 *utf8ness = get_locale_string_utf8ness_i(locale, cat_index,
3887 retval, LOCALE_UTF8NESS_UNKNOWN);
3890 restore_toggled_locale_i(cat_index, orig_switched_locale);
3892 # ifdef USE_LOCALE_CTYPE
3893 restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
3897 /*--------------------------------------------------------------------------*/
3898 # else /* Below, emulate nl_langinfo as best we can */
3900 /* And the third and final completion is where we have to emulate
3901 * nl_langinfo(). There are various possibilities depending on the
3904 # ifdef USE_LOCALE_CTYPE
3906 const char * orig_CTYPE_locale = toggle_locale_c(LC_CTYPE, locale);
3910 const char * orig_switched_locale = toggle_locale_i(cat_index, locale);
3912 /* Here, we are in the locale we want information about */
3914 /* Almost all the items will have ASCII return values. Set that here, and
3915 * override if necessary */
3916 utf8ness_t is_utf8 = UTF8NESS_IMMATERIAL;
3925 # if defined(HAS_SNPRINTF) \
3926 && (! defined(HAS_SOME_LOCALECONV) || defined(TS_W32_BROKEN_LOCALECONV))
3929 /* snprintf() can be used to find the radix character by outputting
3930 * a known simple floating point number to a buffer, and parsing
3931 * it, inferring the radix as the bytes separating the integer and
3932 * fractional parts. But localeconv() is more direct, not
3933 * requiring inference, so use it instead of the code just below,
3934 * if (likely) it is available and works ok */
3936 char * floatbuf = NULL;
3937 const Size_t initial_size = 10;
3939 Newx(floatbuf, initial_size, char);
3941 /* 1.5 is exactly representable on binary computers */
3942 Size_t needed_size = snprintf(floatbuf, initial_size, "%.1f", 1.5);
3944 /* If our guess wasn't big enough, increase and try again, based on
3945 * the real number that strnprintf() is supposed to return */
3946 if (UNLIKELY(needed_size >= initial_size)) {
3947 needed_size++; /* insurance */
3948 Renew(floatbuf, needed_size, char);
3949 Size_t new_needed = snprintf(floatbuf, needed_size, "%.1f", 1.5);
3950 assert(new_needed <= needed_size);
3951 needed_size = new_needed;
3954 char * s = floatbuf;
3955 char * e = floatbuf + needed_size;
3958 while (s < e && *s != '1') {
3962 if (LIKELY(s < e)) {
3967 char * item_start = s;
3968 while (s < e && *s != '5') {
3972 /* Everything in between is the radix string */
3973 if (LIKELY(s < e)) {
3975 retval = save_to_buffer(item_start,
3976 (const char **) &PL_langinfo_buf,
3977 &PL_langinfo_bufsize);
3981 is_utf8 = get_locale_string_utf8ness_i(locale, cat_index,
3983 LOCALE_UTF8NESS_UNKNOWN);
3993 # ifdef HAS_SOME_LOCALECONV /* snprintf() failed; drop down to use
3998 # else /* snprintf() failed and no localeconv() */
4000 retval = C_decimal_point;
4005 # ifdef HAS_SOME_LOCALECONV
4007 /* These items are available from localeconv(). (To avoid using
4008 * TS_W32_BROKEN_LOCALECONV, one could use GetNumberFormat and
4009 * GetCurrencyFormat; patches welcome) */
4014 SV * string = (SV *) my_localeconv(item, LOCALE_UTF8NESS_UNKNOWN);
4016 retval = save_to_buffer(SvPV_nolen(string), retbufp, retbuf_sizep);
4019 is_utf8 = get_locale_string_utf8ness_i(locale, cat_index, retval,
4020 LOCALE_UTF8NESS_UNKNOWN);
4023 SvREFCNT_dec_NN(string);
4027 # endif /* Some form of localeconv */
4028 # ifdef HAS_STRFTIME
4030 /* These formats are only available in later strfmtime's */
4031 case ERA_D_FMT: case ERA_T_FMT: case ERA_D_T_FMT: case T_FMT_AMPM:
4033 /* The rest can be gotten from most versions of strftime(). */
4034 case ABDAY_1: case ABDAY_2: case ABDAY_3:
4035 case ABDAY_4: case ABDAY_5: case ABDAY_6: case ABDAY_7:
4037 case AM_STR: case PM_STR:
4038 case ABMON_1: case ABMON_2: case ABMON_3: case ABMON_4:
4039 case ABMON_5: case ABMON_6: case ABMON_7: case ABMON_8:
4040 case ABMON_9: case ABMON_10: case ABMON_11: case ABMON_12:
4041 case DAY_1: case DAY_2: case DAY_3: case DAY_4:
4042 case DAY_5: case DAY_6: case DAY_7:
4043 case MON_1: case MON_2: case MON_3: case MON_4:
4044 case MON_5: case MON_6: case MON_7: case MON_8:
4045 case MON_9: case MON_10: case MON_11: case MON_12:
4047 const char * format;
4048 bool return_format = FALSE;
4053 GCC_DIAG_IGNORE_STMT(-Wimplicit-fallthrough);
4057 locale_panic_(Perl_form(aTHX_ "switch case: %d problem", item));
4058 NOT_REACHED; /* NOTREACHED */
4060 case PM_STR: hour = 18;
4064 case ABDAY_7: mday++;
4065 case ABDAY_6: mday++;
4066 case ABDAY_5: mday++;
4067 case ABDAY_4: mday++;
4068 case ABDAY_3: mday++;
4069 case ABDAY_2: mday++;
4082 case ABMON_12: mon++;
4083 case ABMON_11: mon++;
4084 case ABMON_10: mon++;
4085 case ABMON_9: mon++;
4086 case ABMON_8: mon++;
4087 case ABMON_7: mon++;
4088 case ABMON_6: mon++;
4089 case ABMON_5: mon++;
4090 case ABMON_4: mon++;
4091 case ABMON_3: mon++;
4092 case ABMON_2: mon++;
4112 return_format = TRUE;
4116 return_format = TRUE;
4120 return_format = TRUE;
4124 return_format = TRUE;
4127 format = "%Ow"; /* Find the alternate digit for 0 */
4131 GCC_DIAG_RESTORE_STMT;
4133 /* The year was deliberately chosen so that January 1 is on the
4134 * first day of the week. Since we're only getting one thing at a
4135 * time, it all works */
4136 const char * temp = my_strftime8(format, 30, 30, hour, mday, mon,
4137 2011, 0, 0, 0, &is_utf8);
4138 retval = save_to_buffer(temp, retbufp, retbuf_sizep);
4141 /* If the item is 'ALT_DIGITS', '*retbuf' contains the alternate
4142 * format for wday 0. If the value is the same as the normal 0,
4143 * there isn't an alternate, so clear the buffer.
4145 * (wday was chosen because its range is all a single digit.
4146 * Things like tm_sec have two digits as the minimum: '00'.) */
4147 if (item == ALT_DIGITS && strEQ(*retbufp, "0")) {
4152 /* ALT_DIGITS is problematic. Experiments on it showed that
4153 * strftime() did not always work properly when going from alt-9 to
4154 * alt-10. Only a few locales have this item defined, and in all
4155 * of them on Linux that khw was able to find, nl_langinfo() merely
4156 * returned the alt-0 character, possibly doubled. Most Unicode
4157 * digits are in blocks of 10 consecutive code points, so that is
4158 * sufficient information for such scripts, as we can infer alt-1,
4159 * alt-2, .... But for a Japanese locale, a CJK ideographic 0 is
4160 * returned, and the CJK digits are not in code point order, so you
4161 * can't really infer anything. The localedef for this locale did
4162 * specify the succeeding digits, so that strftime() works properly
4163 * on them, without needing to infer anything. But the
4164 * nl_langinfo() return did not give sufficient information for the
4165 * caller to understand what's going on. So until there is
4166 * evidence that it should work differently, this returns the alt-0
4167 * string for ALT_DIGITS. */
4169 if (return_format) {
4171 /* If to return the format, not the value, overwrite the buffer
4172 * with it. But some strftime()s will keep the original format
4173 * if illegal, so change those to "" */
4174 if (strEQ(*retbufp, format)) {
4181 /* A format is always in ASCII */
4182 is_utf8 = UTF8NESS_IMMATERIAL;
4192 /* The trivial case */
4193 if (isNAME_C_OR_POSIX(locale)) {
4200 /* This function retrieves the code page. It is subject to change, but
4201 * is documented and has been stable for many releases */
4202 UINT ___lc_codepage_func(void);
4204 retval = save_to_buffer(Perl_form(aTHX_ "%d", ___lc_codepage_func()),
4205 retbufp, retbuf_sizep);
4206 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "locale='%s' cp=%s\n",
4212 /* The codeset is important, but khw did not figure out a way for it to
4213 * be retrieved on non-Windows boxes without nl_langinfo(). But even
4214 * if we can't get it directly, we can usually determine if it is a
4215 * UTF-8 locale or not. If it is UTF-8, we (correctly) use that for
4218 # if defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
4220 /* If libc mbtowc() evaluates the bytes that form the REPLACEMENT
4221 * CHARACTER as that Unicode code point, this has to be a UTF-8 locale.
4225 (void) Perl_mbtowc_(aTHX_ NULL, NULL, 0);/* Reset shift state */
4226 int mbtowc_ret = Perl_mbtowc_(aTHX_ &wc,
4227 STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
4228 if (mbtowc_ret >= 0 && wc == UNICODE_REPLACEMENT) {
4229 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
4230 "mbtowc returned REPLACEMENT\n"));
4235 /* Here, it isn't a UTF-8 locale. */
4237 # else /* mbtowc() is not available. */
4239 /* Sling together several possibilities, depending on platform
4240 * capabilities and what we found.
4242 * For non-English locales or non-dollar currency locales, we likely
4243 * will find out whether a locale is UTF-8 or not */
4245 utf8ness_t is_utf8 = UTF8NESS_UNKNOWN;
4246 const char * scratch_buf = NULL;
4248 # if defined(USE_LOCALE_MONETARY) && defined(HAS_SOME_LOCALECONV)
4250 /* Can't use this method unless localeconv() is available, as that's
4251 * the way we find out the currency symbol. */
4253 /* First try looking at the currency symbol (via a recursive call) to
4254 * see if it disambiguates things. Often that will be in the native
4255 * script, and if the symbol isn't legal UTF-8, we know that the locale
4257 (void) my_langinfo_c(CRNCYSTR, LC_MONETARY, locale, &scratch_buf, NULL,
4259 Safefree(scratch_buf);
4262 # ifdef USE_LOCALE_TIME
4264 /* If we have ruled out being UTF-8, no point in checking further. */
4265 if (is_utf8 != UTF8NESS_NO) {
4267 /* But otherwise do check more. This is done even if the currency
4268 * symbol looks to be UTF-8, just in case that's a false positive.
4270 * Look at the LC_TIME entries, like the names of the months or
4271 * weekdays. We quit at the first one that is illegal UTF-8 */
4273 utf8ness_t this_is_utf8 = UTF8NESS_UNKNOWN;
4274 const int times[] = {
4275 DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7,
4276 MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7, MON_8,
4277 MON_9, MON_10, MON_11, MON_12,
4278 ALT_DIGITS, AM_STR, PM_STR,
4279 ABDAY_1, ABDAY_2, ABDAY_3, ABDAY_4, ABDAY_5, ABDAY_6,
4281 ABMON_1, ABMON_2, ABMON_3, ABMON_4, ABMON_5, ABMON_6,
4282 ABMON_7, ABMON_8, ABMON_9, ABMON_10, ABMON_11, ABMON_12
4285 /* The code in the recursive call can handle switching the locales,
4286 * but by doing it here, we avoid switching each iteration of the
4288 const char * orig_TIME_locale = toggle_locale_c(LC_TIME, locale);
4290 for (PERL_UINT_FAST8_T i = 0; i < C_ARRAY_LENGTH(times); i++) {
4292 (void) my_langinfo_c(times[i], LC_TIME, locale, &scratch_buf,
4293 NULL, &this_is_utf8);
4294 Safefree(scratch_buf);
4295 if (this_is_utf8 == UTF8NESS_NO) {
4296 is_utf8 = UTF8NESS_NO;
4300 if (this_is_utf8 == UTF8NESS_YES) {
4301 is_utf8 = UTF8NESS_YES;
4305 /* Here we have gone through all the LC_TIME elements. is_utf8 has
4306 * been set as follows:
4307 * UTF8NESS_NO If any aren't legal UTF-8
4308 * UTF8NESS_IMMMATERIAL If all are ASCII
4309 * UTF8NESS_YES If all are legal UTF-8 (including
4310 * ASCIIi), and at least one isn't
4313 restore_toggled_locale_c(LC_TIME, orig_TIME_locale);
4316 # endif /* LC_TIME */
4318 /* If nothing examined above rules out it being UTF-8, and at least one
4319 * thing fits as UTF-8 (and not plain ASCII), assume the codeset is
4321 if (is_utf8 == UTF8NESS_YES) {
4326 /* Here, nothing examined indicates that the codeset is UTF-8. But
4327 * what is it? The other locale categories are not likely to be of
4330 * LC_NUMERIC Only a few locales in the world have a non-ASCII radix
4331 * or group separator.
4332 * LC_CTYPE This code wouldn't be compiled if mbtowc() existed and
4333 * was reliable. This is unlikely in C99. There are
4334 * other functions that could be used instead, but are
4335 * they going to exist, and be able to distinguish between
4336 * UTF-8 and 8859-1? Deal with this only if it becomes
4338 * LC_MESSAGES The strings returned from strerror() would seem likely
4339 * candidates, but experience has shown that many systems
4340 * don't actually have translations installed for them.
4341 * They are instead always in English, so everything in
4342 * them is ASCII, which is of no help to us. A Configure
4343 * probe could possibly be written to see if this platform
4344 * has non-ASCII error messages. But again, wait until it
4345 * turns out to be an actual problem. */
4347 # endif /* ! mbtowc() */
4349 /* Rejoin the mbtowc available/not-available cases.
4351 * We got here only because we haven't been able to find the codeset.
4352 * The only other option khw could think of is to see if the codeset is
4353 * part of the locale name. This is very less than ideal; often there
4354 * is no code set in the name; and at other times they even lie.
4356 * Find any dot in the locale name */
4357 retval = (const char *) strchr(locale, '.');
4359 retval = ""; /* Alas, no dot */
4363 /* Use everything past the dot */
4366 # if defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
4368 /* When these functions, are available, they were tried earlier and
4369 * indicated that the locale did not act like a proper UTF-8 one. So
4370 * if it claims to be UTF-8, it is a lie */
4371 if (is_codeset_name_UTF8(retval)) {
4378 /* Otherwise the code set name is considered to be everything past the
4380 retval = save_to_buffer(retval, retbufp, retbuf_sizep);
4386 } /* Giant switch() of nl_langinfo() items */
4388 restore_toggled_locale_i(cat_index, orig_switched_locale);
4390 # ifdef USE_LOCALE_CTYPE
4391 restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
4395 *utf8ness = is_utf8;
4400 # endif /* All the implementations of my_langinfo() */
4402 /*--------------------------------------------------------------------------*/
4404 } /* my_langinfo() */
4406 #endif /* USE_LOCALE */
4409 Perl_my_strftime8(pTHX_ const char *fmt, int sec, int min, int hour, int mday,
4410 int mon, int year, int wday, int yday, int isdst,
4411 utf8ness_t * utf8ness)
4412 { /* Documented in util.c */
4413 char * retval = my_strftime(fmt, sec, min, hour, mday, mon, year, wday,
4416 PERL_ARGS_ASSERT_MY_STRFTIME8;
4420 #ifdef USE_LOCALE_TIME
4421 *utf8ness = get_locale_string_utf8ness_i(NULL, LC_TIME_INDEX_,
4422 retval, LOCALE_UTF8NESS_UNKNOWN);
4424 *utf8ness = UTF8NESS_IMMATERIAL;
4429 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "fmt=%s, retval=%s", fmt,
4430 ((is_utf8_string((U8 *) retval, 0))
4432 :_byte_dump_string((U8 *) retval, strlen(retval), 0)));
4433 if (utf8ness) PerlIO_printf(Perl_debug_log, "; utf8ness=%d",
4435 PerlIO_printf(Perl_debug_log, "\n");
4442 * Initialize locale awareness.
4445 Perl_init_i18nl10n(pTHX_ int printwarn)
4449 * 0 if not to output warning when setup locale is bad
4450 * 1 if to output warning based on value of PERL_BADLANG
4451 * >1 if to output regardless of PERL_BADLANG
4454 * 1 = set ok or not applicable,
4455 * 0 = fallback to a locale of lower priority
4456 * -1 = fallback to all locales failed, not even to the C locale
4458 * Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
4459 * set, debugging information is output.
4461 * This looks more complicated than it is, mainly due to the #ifdefs and
4464 * Besides some asserts, data structure initialization, and specific
4465 * platform complications, this routine is effectively represented by this
4468 * setlocale(LC_ALL, ""); x
4469 * foreach (subcategory) { x
4470 * curlocales[f(subcategory)] = setlocale(subcategory, NULL); x
4472 * if (platform_so_requires) {
4473 * foreach (subcategory) {
4474 * PL_curlocales[f(subcategory)] = curlocales[f(subcategory)]
4477 * foreach (subcategory) {
4478 * if (needs_special_handling[f(subcategory)] &this_subcat_handler
4481 * This sets all the categories to the values in the current environment,
4482 * saves them temporarily in curlocales[] until they can be handled and/or
4483 * on some platforms saved in a per-thread array PL_curlocales[].
4485 * f(foo) is a mapping from the opaque system category numbers to small
4486 * non-negative integers used most everywhere in this file as indices into
4487 * arrays (such as curlocales[]) so the program doesn't have to otherwise
4488 * deal with the opaqueness.
4490 * If the platform doesn't have LC_ALL, the lines marked 'x' above are
4491 * effectively replaced by:
4492 * foreach (subcategory) { y
4493 * curlocales[f(subcategory)] = setlocale(subcategory, ""); y
4496 * The only differences being the lack of an LC_ALL call, and using ""
4497 * instead of NULL in the setlocale calls.
4499 * But there are, of course, complications.
4501 * it has to deal with if this is an embedded perl, whose locale doesn't
4502 * come from the environment, but has been set up by the caller. This is
4503 * pretty simply handled: the "" in the setlocale calls is not a string
4504 * constant, but a variable which is set to NULL in the embedded case.
4506 * But the major complication is handling failure and doing fallback. All
4507 * the code marked 'x' or 'y' above is actually enclosed in an outer loop,
4508 * using the array trial_locales[]. On entry, trial_locales[] is
4509 * initialized to just one entry, containing the NULL or "" locale argument
4510 * shown above. If, as is almost always the case, everything works, it
4511 * exits after just the one iteration, going on to the next step.
4513 * But if there is a failure, the code tries its best to honor the
4514 * environment as much as possible. It self-modifies trial_locales[] to
4515 * have more elements, one for each of the POSIX-specified settings from
4516 * the environment, such as LANG, ending in the ultimate fallback, the C
4517 * locale. Thus if there is something bogus with a higher priority
4518 * environment variable, it will try with the next highest, until something
4519 * works. If everything fails, it limps along with whatever state it got
4522 * A further complication is that Windows has an additional fallback, the
4523 * user-default ANSI code page obtained from the operating system. This is
4524 * added as yet another loop iteration, just before the final "C"
4526 * A slight complication is that in embedded Perls, the locale may already
4527 * be set-up, and we don't want to get it from the normal environment
4528 * variables. This is handled by having a special environment variable
4529 * indicate we're in this situation. We simply set setlocale's 2nd
4530 * parameter to be a NULL instead of "". That indicates to setlocale that
4531 * it is not to change anything, but to return the current value,
4532 * effectively initializing perl's db to what the locale already is.
4534 * We play the same trick with NULL if a LC_ALL succeeds. We call
4535 * setlocale() on the individual categores with NULL to get their existing
4536 * values for our db, instead of trying to change them.
4543 PERL_UNUSED_ARG(printwarn);
4545 #else /* USE_LOCALE */
4548 const char * const language = PerlEnv_getenv("LANGUAGE");
4552 /* NULL uses the existing already set up locale */
4553 const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
4556 typedef struct trial_locales_struct_s {
4557 const char* trial_locale;
4558 const char* fallback_desc;
4559 const char* fallback_name;
4560 } trial_locales_struct;
4561 /* 5 = 1 each for "", LC_ALL, LANG, (Win32) system default locale, C */
4562 trial_locales_struct trial_locales[5];
4563 unsigned int trial_locales_count;
4564 const char * const lc_all = PerlEnv_getenv("LC_ALL");
4565 const char * const lang = PerlEnv_getenv("LANG");
4566 bool setlocale_failure = FALSE;
4569 /* A later getenv() could zap this, so only use here */
4570 const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
4572 const bool locwarn = (printwarn > 1
4574 && ( ! bad_lang_use_once
4576 /* disallow with "" or "0" */
4578 && strNE("0", bad_lang_use_once)))));
4580 /* current locale for given category; should have been copied so aren't
4582 const char * curlocales[NOMINAL_LC_ALL_INDEX + 1];
4585 # define DEBUG_LOCALE_INIT(a,b,c)
4588 DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
4590 # define DEBUG_LOCALE_INIT(cat_index, locale, result) \
4591 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n", \
4592 setlocale_debug_string_i(cat_index, locale, result)));
4594 /* Make sure the parallel arrays are properly set up */
4595 # ifdef USE_LOCALE_NUMERIC
4596 assert(categories[LC_NUMERIC_INDEX_] == LC_NUMERIC);
4597 assert(strEQ(category_names[LC_NUMERIC_INDEX_], "LC_NUMERIC"));
4598 # ifdef USE_POSIX_2008_LOCALE
4599 assert(category_masks[LC_NUMERIC_INDEX_] == LC_NUMERIC_MASK);
4602 # ifdef USE_LOCALE_CTYPE
4603 assert(categories[LC_CTYPE_INDEX_] == LC_CTYPE);
4604 assert(strEQ(category_names[LC_CTYPE_INDEX_], "LC_CTYPE"));
4605 # ifdef USE_POSIX_2008_LOCALE
4606 assert(category_masks[LC_CTYPE_INDEX_] == LC_CTYPE_MASK);
4609 # ifdef USE_LOCALE_COLLATE
4610 assert(categories[LC_COLLATE_INDEX_] == LC_COLLATE);
4611 assert(strEQ(category_names[LC_COLLATE_INDEX_], "LC_COLLATE"));
4612 # ifdef USE_POSIX_2008_LOCALE
4613 assert(category_masks[LC_COLLATE_INDEX_] == LC_COLLATE_MASK);
4616 # ifdef USE_LOCALE_TIME
4617 assert(categories[LC_TIME_INDEX_] == LC_TIME);
4618 assert(strEQ(category_names[LC_TIME_INDEX_], "LC_TIME"));
4619 # ifdef USE_POSIX_2008_LOCALE
4620 assert(category_masks[LC_TIME_INDEX_] == LC_TIME_MASK);
4623 # ifdef USE_LOCALE_MESSAGES
4624 assert(categories[LC_MESSAGES_INDEX_] == LC_MESSAGES);
4625 assert(strEQ(category_names[LC_MESSAGES_INDEX_], "LC_MESSAGES"));
4626 # ifdef USE_POSIX_2008_LOCALE
4627 assert(category_masks[LC_MESSAGES_INDEX_] == LC_MESSAGES_MASK);
4630 # ifdef USE_LOCALE_MONETARY
4631 assert(categories[LC_MONETARY_INDEX_] == LC_MONETARY);
4632 assert(strEQ(category_names[LC_MONETARY_INDEX_], "LC_MONETARY"));
4633 # ifdef USE_POSIX_2008_LOCALE
4634 assert(category_masks[LC_MONETARY_INDEX_] == LC_MONETARY_MASK);
4637 # ifdef USE_LOCALE_ADDRESS
4638 assert(categories[LC_ADDRESS_INDEX_] == LC_ADDRESS);
4639 assert(strEQ(category_names[LC_ADDRESS_INDEX_], "LC_ADDRESS"));
4640 # ifdef USE_POSIX_2008_LOCALE
4641 assert(category_masks[LC_ADDRESS_INDEX_] == LC_ADDRESS_MASK);
4644 # ifdef USE_LOCALE_IDENTIFICATION
4645 assert(categories[LC_IDENTIFICATION_INDEX_] == LC_IDENTIFICATION);
4646 assert(strEQ(category_names[LC_IDENTIFICATION_INDEX_], "LC_IDENTIFICATION"));
4647 # ifdef USE_POSIX_2008_LOCALE
4648 assert(category_masks[LC_IDENTIFICATION_INDEX_] == LC_IDENTIFICATION_MASK);
4651 # ifdef USE_LOCALE_MEASUREMENT
4652 assert(categories[LC_MEASUREMENT_INDEX_] == LC_MEASUREMENT);
4653 assert(strEQ(category_names[LC_MEASUREMENT_INDEX_], "LC_MEASUREMENT"));
4654 # ifdef USE_POSIX_2008_LOCALE
4655 assert(category_masks[LC_MEASUREMENT_INDEX_] == LC_MEASUREMENT_MASK);
4658 # ifdef USE_LOCALE_PAPER
4659 assert(categories[LC_PAPER_INDEX_] == LC_PAPER);
4660 assert(strEQ(category_names[LC_PAPER_INDEX_], "LC_PAPER"));
4661 # ifdef USE_POSIX_2008_LOCALE
4662 assert(category_masks[LC_PAPER_INDEX_] == LC_PAPER_MASK);
4665 # ifdef USE_LOCALE_TELEPHONE
4666 assert(categories[LC_TELEPHONE_INDEX_] == LC_TELEPHONE);
4667 assert(strEQ(category_names[LC_TELEPHONE_INDEX_], "LC_TELEPHONE"));
4668 # ifdef USE_POSIX_2008_LOCALE
4669 assert(category_masks[LC_TELEPHONE_INDEX_] == LC_TELEPHONE_MASK);
4672 # ifdef USE_LOCALE_SYNTAX
4673 assert(categories[LC_SYNTAX_INDEX_] == LC_SYNTAX);
4674 assert(strEQ(category_names[LC_SYNTAX_INDEX_], "LC_SYNTAX"));
4675 # ifdef USE_POSIX_2008_LOCALE
4676 assert(category_masks[LC_SYNTAX_INDEX_] == LC_SYNTAX_MASK);
4679 # ifdef USE_LOCALE_TOD
4680 assert(categories[LC_TOD_INDEX_] == LC_TOD);
4681 assert(strEQ(category_names[LC_TOD_INDEX_], "LC_TOD"));
4682 # ifdef USE_POSIX_2008_LOCALE
4683 assert(category_masks[LC_TOD_INDEX_] == LC_TOD_MASK);
4687 assert(categories[LC_ALL_INDEX_] == LC_ALL);
4688 assert(strEQ(category_names[LC_ALL_INDEX_], "LC_ALL"));
4689 STATIC_ASSERT_STMT(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX_);
4690 # ifdef USE_POSIX_2008_LOCALE
4691 assert(category_masks[LC_ALL_INDEX_] == LC_ALL_MASK);
4694 # endif /* DEBUGGING */
4696 /* Initialize the per-thread mbrFOO() state variables. See POSIX.xs for
4697 * why these particular incantations are used. */
4699 memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
4702 memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
4705 wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
4708 /* Initialize the cache of the program's UTF-8ness for the always known
4709 * locales C and POSIX */
4710 my_strlcpy(PL_locale_utf8ness, C_and_POSIX_utf8ness,
4711 sizeof(PL_locale_utf8ness));
4713 /* See https://github.com/Perl/perl5/issues/17824 */
4714 Zero(curlocales, NOMINAL_LC_ALL_INDEX, char *);
4716 # ifdef USE_THREAD_SAFE_LOCALE
4719 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
4723 # ifdef USE_POSIX_2008_LOCALE
4725 PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
4726 if (! PL_C_locale_obj) {
4727 locale_panic_(Perl_form(aTHX_
4728 "Cannot create POSIX 2008 C locale object"));
4731 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "created C object %p\n",
4734 # ifdef USE_LOCALE_NUMERIC
4736 PL_numeric_radix_sv = newSVpvn(C_decimal_point, strlen(C_decimal_point));
4737 Newx(PL_numeric_name, 2, char);
4738 Copy("C", PL_numeric_name, 2, char);
4741 # ifdef USE_LOCALE_COLLATE
4743 Newx(PL_collation_name, 2, char);
4744 Copy("C", PL_collation_name, 2, char);
4747 # ifdef USE_PL_CURLOCALES
4749 /* Initialize our records. If we have POSIX 2008, we have LC_ALL */
4750 void_setlocale_c(LC_ALL, porcelain_setlocale(LC_ALL, NULL));
4754 /* We try each locale in the list until we get one that works, or exhaust
4755 * the list. Normally the loop is executed just once. But if setting the
4756 * locale fails, inside the loop we add fallback trials to the array and so
4757 * will execute the loop multiple times */
4758 trial_locales[0] = (trial_locales_struct) {
4759 .trial_locale = setlocale_init,
4760 .fallback_desc = NULL,
4761 .fallback_name = NULL,
4763 trial_locales_count = 1;
4765 for (i= 0; i < trial_locales_count; i++) {
4766 const char * trial_locale = trial_locales[i].trial_locale;
4767 setlocale_failure = FALSE;
4771 /* setlocale() return vals; not copied so must be looked at
4773 const char * sl_result[NOMINAL_LC_ALL_INDEX + 1];
4774 sl_result[LC_ALL_INDEX_] = stdized_setlocale(LC_ALL, trial_locale);
4775 DEBUG_LOCALE_INIT(LC_ALL_INDEX_, trial_locale, sl_result[LC_ALL_INDEX_]);
4776 if (! sl_result[LC_ALL_INDEX_]) {
4777 setlocale_failure = TRUE;
4780 /* Since LC_ALL succeeded, it should have changed all the other
4781 * categories it can to its value; so we massage things so that the
4782 * setlocales below just return their category's current values.
4783 * This adequately handles the case in NetBSD where LC_COLLATE may
4784 * not be defined for a locale, and setting it individually will
4785 * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to
4786 * the POSIX locale. */
4787 trial_locale = NULL;
4790 # endif /* LC_ALL */
4792 if (! setlocale_failure) {
4794 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
4795 Safefree(curlocales[j]);
4796 curlocales[j] = stdized_setlocale(categories[j], trial_locale);
4797 if (! curlocales[j]) {
4798 setlocale_failure = TRUE;
4800 curlocales[j] = savepv(curlocales[j]);
4801 DEBUG_LOCALE_INIT(j, trial_locale, curlocales[j]);
4804 if (LIKELY(! setlocale_failure)) { /* All succeeded */
4805 break; /* Exit trial_locales loop */
4809 /* Here, something failed; will need to try a fallback. */
4815 if (locwarn) { /* Output failure info only on the first one */
4819 PerlIO_printf(Perl_error_log,
4820 "perl: warning: Setting locale failed.\n");
4822 # else /* !LC_ALL */
4824 PerlIO_printf(Perl_error_log,
4825 "perl: warning: Setting locale failed for the categories:\n");
4827 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
4828 if (! curlocales[j]) {
4829 PerlIO_printf(Perl_error_log, "\t%s\n", category_names[j]);
4833 # endif /* LC_ALL */
4835 PerlIO_printf(Perl_error_log,
4836 "perl: warning: Please check that your locale settings:\n");
4840 PerlIO_printf(Perl_error_log,
4841 "\tLANGUAGE = %c%s%c,\n",
4842 language ? '"' : '(',
4843 language ? language : "unset",
4844 language ? '"' : ')');
4847 PerlIO_printf(Perl_error_log,
4848 "\tLC_ALL = %c%s%c,\n",
4850 lc_all ? lc_all : "unset",
4851 lc_all ? '"' : ')');
4853 # if defined(USE_ENVIRON_ARRAY)
4858 /* Look through the environment for any variables of the
4859 * form qr/ ^ LC_ [A-Z]+ = /x, except LC_ALL which was
4860 * already handled above. These are assumed to be locale
4861 * settings. Output them and their values. */
4862 for (e = environ; *e; e++) {
4863 const STRLEN prefix_len = sizeof("LC_") - 1;
4866 if ( strBEGINs(*e, "LC_")
4867 && ! strBEGINs(*e, "LC_ALL=")
4868 && (uppers_len = strspn(*e + prefix_len,
4869 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
4870 && ((*e)[prefix_len + uppers_len] == '='))
4872 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
4873 (int) (prefix_len + uppers_len), *e,
4874 *e + prefix_len + uppers_len + 1);
4881 PerlIO_printf(Perl_error_log,
4882 "\t(possibly more locale environment variables)\n");
4886 PerlIO_printf(Perl_error_log,
4887 "\tLANG = %c%s%c\n",
4889 lang ? lang : "unset",
4892 PerlIO_printf(Perl_error_log,
4893 " are supported and installed on your system.\n");
4896 /* Calculate what fallback locales to try. We have avoided this
4897 * until we have to, because failure is quite unlikely. This will
4898 * usually change the upper bound of the loop we are in.
4900 * Since the system's default way of setting the locale has not
4901 * found one that works, We use Perl's defined ordering: LC_ALL,
4902 * LANG, and the C locale. We don't try the same locale twice, so
4903 * don't add to the list if already there. (On POSIX systems, the
4904 * LC_ALL element will likely be a repeat of the 0th element "",
4905 * but there's no harm done by doing it explicitly.
4907 * Note that this tries the LC_ALL environment variable even on
4908 * systems which have no LC_ALL locale setting. This may or may
4909 * not have been originally intentional, but there's no real need
4910 * to change the behavior. */
4912 for (j = 0; j < trial_locales_count; j++) {
4913 if (strEQ(lc_all, trial_locales[j].trial_locale)) {
4917 trial_locales[trial_locales_count++] = (trial_locales_struct) {
4918 .trial_locale = lc_all,
4919 .fallback_desc = (strEQ(lc_all, "C")
4920 ? "the standard locale"
4921 : "a fallback locale"),
4922 .fallback_name = lc_all,
4928 for (j = 0; j < trial_locales_count; j++) {
4929 if (strEQ(lang, trial_locales[j].trial_locale)) {
4933 trial_locales[trial_locales_count++] = (trial_locales_struct) {
4934 .trial_locale = lang,
4935 .fallback_desc = (strEQ(lang, "C")
4936 ? "the standard locale"
4937 : "a fallback locale"),
4938 .fallback_name = lang,
4943 # if defined(WIN32) && defined(LC_ALL)
4945 /* For Windows, we also try the system default locale before "C".
4946 * (If there exists a Windows without LC_ALL we skip this because
4947 * it gets too complicated. For those, the "C" is the next
4948 * fallback possibility). */
4950 /* Note that this may change the locale, but we are going to do
4953 * Our normal Windows setlocale() implementation ignores the
4954 * system default locale to make things work like POSIX. This
4955 * is the only place where we want to consider it, so have to
4956 * use wrap_wsetlocale(). */
4957 const char *system_default_locale =
4958 stdize_locale(LC_ALL,
4959 S_wrap_wsetlocale(aTHX_ LC_ALL, ""),
4960 &PL_stdize_locale_buf,
4961 &PL_stdize_locale_bufsize,
4963 DEBUG_LOCALE_INIT(LC_ALL_INDEX_, "", system_default_locale);
4965 /* Skip if invalid or if it's already on the list of locales to
4967 if (! system_default_locale) {
4968 goto done_system_default;
4970 for (j = 0; j < trial_locales_count; j++) {
4971 if (strEQ(system_default_locale, trial_locales[j].trial_locale)) {
4972 goto done_system_default;
4976 trial_locales[trial_locales_count++] = (trial_locales_struct) {
4977 .trial_locale = system_default_locale,
4978 .fallback_desc = (strEQ(system_default_locale, "C")
4979 ? "the standard locale"
4980 : "the system default locale"),
4981 .fallback_name = system_default_locale,
4984 done_system_default:
4988 for (j = 0; j < trial_locales_count; j++) {
4989 if (strEQ("C", trial_locales[j].trial_locale)) {
4993 trial_locales[trial_locales_count++] = (trial_locales_struct) {
4994 .trial_locale = "C",
4995 .fallback_desc = "the standard locale",
4996 .fallback_name = "C",
5000 } /* end of first time through the loop */
5008 } /* end of looping through the trial locales */
5010 if (ok < 1) { /* If we tried to fallback */
5012 if (! setlocale_failure) { /* fallback succeeded */
5013 msg = "Falling back to";
5015 else { /* fallback failed */
5018 /* We dropped off the end of the loop, so have to decrement i to
5019 * get back to the value the last time through */
5023 msg = "Failed to fall back to";
5025 /* To continue, we should use whatever values we've got */
5027 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
5028 Safefree(curlocales[j]);
5029 curlocales[j] = savepv(stdized_setlocale(categories[j], NULL));
5030 DEBUG_LOCALE_INIT(j, NULL, curlocales[j]);
5035 const char * description = trial_locales[i].fallback_desc;
5036 const char * name = trial_locales[i].fallback_name;
5038 if (name && strNE(name, "")) {
5039 PerlIO_printf(Perl_error_log,
5040 "perl: warning: %s %s (\"%s\").\n", msg, description, name);
5043 PerlIO_printf(Perl_error_log,
5044 "perl: warning: %s %s.\n", msg, description);
5047 } /* End of tried to fallback */
5049 # ifdef USE_POSIX_2008_LOCALE
5051 /* The stdized setlocales haven't affected the P2008 locales. Initialize
5052 * them now, calculating LC_ALL only on the final go round, when all have
5054 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
5055 (void) emulate_setlocale_i(i, curlocales[i],
5056 RECALCULATE_LC_ALL_ON_FINAL_INTERATION,
5062 /* Done with finding the locales; update the auxiliary records */
5065 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
5067 # if defined(USE_LOCALE_THREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
5069 /* This caches whether each category's locale is UTF-8 or not. This
5070 * may involve changing the locale. It is ok to do this at
5071 * initialization time before any threads have started, but not later
5072 * unless thread-safe operations are used.
5073 * Caching means that if the program heeds our dictate not to change
5074 * locales in threaded applications, this data will remain valid, and
5075 * it may get queried without having to change locales. If the
5076 * environment is such that all categories have the same locale, this
5077 * isn't needed, as the code will not change the locale; but this
5078 * handles the uncommon case where the environment has disparate
5079 * locales for the categories */
5080 (void) _is_cur_LC_category_utf8(categories[i]);
5084 Safefree(curlocales[i]);
5087 # if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
5089 /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
5090 * locale is UTF-8. The call to new_ctype() just above has already
5091 * calculated the latter value and saved it in PL_in_utf8_CTYPE_locale. If
5092 * both PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
5093 * are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer on
5094 * STDIN, STDOUT, STDERR, _and_ the default open discipline. */
5095 PL_utf8locale = PL_in_utf8_CTYPE_locale;
5097 /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
5098 This is an alternative to using the -C command line switch
5099 (the -C if present will override this). */
5101 const char *p = PerlEnv_getenv("PERL_UNICODE");
5102 PL_unicode = p ? parse_unicode_opts(&p) : 0;
5103 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
5108 #endif /* USE_LOCALE */
5110 /* So won't continue to output stuff */
5111 DEBUG_INITIALIZATION_set(FALSE);
5116 #ifdef USE_LOCALE_COLLATE
5119 Perl__mem_collxfrm(pTHX_ const char *input_string,
5120 STRLEN len, /* Length of 'input_string' */
5121 STRLEN *xlen, /* Set to length of returned string
5122 (not including the collation index
5124 bool utf8 /* Is the input in UTF-8? */
5127 /* _mem_collxfrm() is like strxfrm() but with two important differences.
5128 * First, it handles embedded NULs. Second, it allocates a bit more memory
5129 * than needed for the transformed data itself. The real transformed data
5130 * begins at offset COLLXFRM_HDR_LEN. *xlen is set to the length of that,
5131 * and doesn't include the collation index size.
5133 * It is the caller's responsibility to eventually free the memory returned
5136 * Please see sv_collxfrm() to see how this is used. */
5138 # define COLLXFRM_HDR_LEN sizeof(PL_collation_ix)
5140 char * s = (char *) input_string;
5141 STRLEN s_strlen = strlen(input_string);
5143 STRLEN xAlloc; /* xalloc is a reserved word in VC */
5144 STRLEN length_in_chars;
5145 bool first_time = TRUE; /* Cleared after first loop iteration */
5147 PERL_ARGS_ASSERT__MEM_COLLXFRM;
5149 /* Must be NUL-terminated */
5150 assert(*(input_string + len) == '\0');
5152 /* If this locale has defective collation, skip */
5153 if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
5154 DEBUG_L(PerlIO_printf(Perl_debug_log,
5155 "_mem_collxfrm: locale's collation is defective\n"));
5159 /* Replace any embedded NULs with the control that sorts before any others.
5160 * This will give as good as possible results on strings that don't
5161 * otherwise contain that character, but otherwise there may be
5162 * less-than-perfect results with that character and NUL. This is
5163 * unavoidable unless we replace strxfrm with our own implementation. */
5164 if (UNLIKELY(s_strlen < len)) { /* Only execute if there is an embedded
5168 STRLEN sans_nuls_len;
5169 int try_non_controls;
5170 char this_replacement_char[] = "?\0"; /* Room for a two-byte string,
5171 making sure 2nd byte is NUL.
5173 STRLEN this_replacement_len;
5175 /* If we don't know what non-NUL control character sorts lowest for
5176 * this locale, find it */
5177 if (PL_strxfrm_NUL_replacement == '\0') {
5179 char * cur_min_x = NULL; /* The min_char's xfrm, (except it also
5180 includes the collation index
5183 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
5185 /* Unlikely, but it may be that no control will work to replace
5186 * NUL, in which case we instead look for any character. Controls
5187 * are preferred because collation order is, in general, context
5188 * sensitive, with adjoining characters affecting the order, and
5189 * controls are less likely to have such interactions, allowing the
5190 * NUL-replacement to stand on its own. (Another way to look at it
5191 * is to imagine what would happen if the NUL were replaced by a
5192 * combining character; it wouldn't work out all that well.) */
5193 for (try_non_controls = 0;
5194 try_non_controls < 2;
5197 /* Look through all legal code points (NUL isn't) */
5198 for (j = 1; j < 256; j++) {
5199 char * x; /* j's xfrm plus collation index */
5200 STRLEN x_len; /* length of 'x' */
5201 STRLEN trial_len = 1;
5202 char cur_source[] = { '\0', '\0' };
5204 /* Skip non-controls the first time through the loop. The
5205 * controls in a UTF-8 locale are the L1 ones */
5206 if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
5213 /* Create a 1-char string of the current code point */
5214 cur_source[0] = (char) j;
5216 /* Then transform it */
5217 x = _mem_collxfrm(cur_source, trial_len, &x_len,
5218 0 /* The string is not in UTF-8 */);
5220 /* Ignore any character that didn't successfully transform.
5226 /* If this character's transformation is lower than
5227 * the current lowest, this one becomes the lowest */
5228 if ( cur_min_x == NULL
5229 || strLT(x + COLLXFRM_HDR_LEN,
5230 cur_min_x + COLLXFRM_HDR_LEN))
5232 PL_strxfrm_NUL_replacement = j;
5233 Safefree(cur_min_x);
5239 } /* end of loop through all 255 characters */
5241 /* Stop looking if found */
5246 /* Unlikely, but possible, if there aren't any controls that
5247 * work in the locale, repeat the loop, looking for any
5248 * character that works */
5249 DEBUG_L(PerlIO_printf(Perl_debug_log,
5250 "_mem_collxfrm: No control worked. Trying non-controls\n"));
5251 } /* End of loop to try first the controls, then any char */
5254 DEBUG_L(PerlIO_printf(Perl_debug_log,
5255 "_mem_collxfrm: Couldn't find any character to replace"
5256 " embedded NULs in locale %s with", PL_collation_name));
5260 DEBUG_L(PerlIO_printf(Perl_debug_log,
5261 "_mem_collxfrm: Replacing embedded NULs in locale %s with "
5262 "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
5264 Safefree(cur_min_x);
5265 } /* End of determining the character that is to replace NULs */
5267 /* If the replacement is variant under UTF-8, it must match the
5268 * UTF8-ness of the original */
5269 if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
5270 this_replacement_char[0] =
5271 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
5272 this_replacement_char[1] =
5273 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
5274 this_replacement_len = 2;
5277 this_replacement_char[0] = PL_strxfrm_NUL_replacement;
5278 /* this_replacement_char[1] = '\0' was done at initialization */
5279 this_replacement_len = 1;
5282 /* The worst case length for the replaced string would be if every
5283 * character in it is NUL. Multiply that by the length of each
5284 * replacement, and allow for a trailing NUL */
5285 sans_nuls_len = (len * this_replacement_len) + 1;
5286 Newx(sans_nuls, sans_nuls_len, char);
5289 /* Replace each NUL with the lowest collating control. Loop until have
5290 * exhausted all the NULs */
5291 while (s + s_strlen < e) {
5292 my_strlcat(sans_nuls, s, sans_nuls_len);
5294 /* Do the actual replacement */
5295 my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
5297 /* Move past the input NUL */
5299 s_strlen = strlen(s);
5302 /* And add anything that trails the final NUL */
5303 my_strlcat(sans_nuls, s, sans_nuls_len);
5305 /* Switch so below we transform this modified string */
5308 } /* End of replacing NULs */
5310 /* Make sure the UTF8ness of the string and locale match */
5311 if (utf8 != PL_in_utf8_COLLATE_locale) {
5312 /* XXX convert above Unicode to 10FFFF? */
5313 const char * const t = s; /* Temporary so we can later find where the
5316 /* Here they don't match. Change the string's to be what the locale is
5319 if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
5320 s = (char *) bytes_to_utf8((const U8 *) s, &len);
5323 else { /* locale is not UTF-8; but input is; downgrade the input */
5325 s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
5327 /* If the downgrade was successful we are done, but if the input
5328 * contains things that require UTF-8 to represent, have to do
5329 * damage control ... */
5330 if (UNLIKELY(utf8)) {
5332 /* What we do is construct a non-UTF-8 string with
5333 * 1) the characters representable by a single byte converted
5334 * to be so (if necessary);
5335 * 2) and the rest converted to collate the same as the
5336 * highest collating representable character. That makes
5337 * them collate at the end. This is similar to how we
5338 * handle embedded NULs, but we use the highest collating
5339 * code point instead of the smallest. Like the NUL case,
5340 * this isn't perfect, but is the best we can reasonably
5341 * do. Every above-255 code point will sort the same as
5342 * the highest-sorting 0-255 code point. If that code
5343 * point can combine in a sequence with some other code
5344 * points for weight calculations, us changing something to
5345 * be it can adversely affect the results. But in most
5346 * cases, it should work reasonably. And note that this is
5347 * really an illegal situation: using code points above 255
5348 * on a locale where only 0-255 are valid. If two strings
5349 * sort entirely equal, then the sort order for the
5350 * above-255 code points will be in code point order. */
5354 /* If we haven't calculated the code point with the maximum
5355 * collating order for this locale, do so now */
5356 if (! PL_strxfrm_max_cp) {
5359 /* The current transformed string that collates the
5360 * highest (except it also includes the prefixed collation
5362 char * cur_max_x = NULL;
5364 /* Look through all legal code points (NUL isn't) */
5365 for (j = 1; j < 256; j++) {
5368 char cur_source[] = { '\0', '\0' };
5370 /* Create a 1-char string of the current code point */
5371 cur_source[0] = (char) j;
5373 /* Then transform it */
5374 x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
5376 /* If something went wrong (which it shouldn't), just
5377 * ignore this code point */
5382 /* If this character's transformation is higher than
5383 * the current highest, this one becomes the highest */
5384 if ( cur_max_x == NULL
5385 || strGT(x + COLLXFRM_HDR_LEN,
5386 cur_max_x + COLLXFRM_HDR_LEN))
5388 PL_strxfrm_max_cp = j;
5389 Safefree(cur_max_x);
5398 DEBUG_L(PerlIO_printf(Perl_debug_log,
5399 "_mem_collxfrm: Couldn't find any character to"
5400 " replace above-Latin1 chars in locale %s with",
5401 PL_collation_name));
5405 DEBUG_L(PerlIO_printf(Perl_debug_log,
5406 "_mem_collxfrm: highest 1-byte collating character"
5407 " in locale %s is 0x%02X\n",
5409 PL_strxfrm_max_cp));
5411 Safefree(cur_max_x);
5414 /* Here we know which legal code point collates the highest.
5415 * We are ready to construct the non-UTF-8 string. The length
5416 * will be at least 1 byte smaller than the input string
5417 * (because we changed at least one 2-byte character into a
5418 * single byte), but that is eaten up by the trailing NUL */
5424 char * e = (char *) t + len;
5426 for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
5428 if (UTF8_IS_INVARIANT(cur_char)) {
5431 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
5432 s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
5434 else { /* Replace illegal cp with highest collating
5436 s[d++] = PL_strxfrm_max_cp;
5440 Renew(s, d, char); /* Free up unused space */
5445 /* Here, we have constructed a modified version of the input. It could
5446 * be that we already had a modified copy before we did this version.
5447 * If so, that copy is no longer needed */
5448 if (t != input_string) {
5453 length_in_chars = (utf8)
5454 ? utf8_length((U8 *) s, (U8 *) s + len)
5457 /* The first element in the output is the collation id, used by
5458 * sv_collxfrm(); then comes the space for the transformed string. The
5459 * equation should give us a good estimate as to how much is needed */
5460 xAlloc = COLLXFRM_HDR_LEN
5462 + (PL_collxfrm_mult * length_in_chars);
5463 Newx(xbuf, xAlloc, char);
5464 if (UNLIKELY(! xbuf)) {
5465 DEBUG_L(PerlIO_printf(Perl_debug_log,
5466 "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
5470 /* Store the collation id */
5471 *(U32*)xbuf = PL_collation_ix;
5473 /* Then the transformation of the input. We loop until successful, or we
5478 *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
5480 /* If the transformed string occupies less space than we told strxfrm()
5481 * was available, it means it transformed the whole string. */
5482 if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
5484 /* But there still could have been a problem */
5486 DEBUG_L(PerlIO_printf(Perl_debug_log,
5487 "strxfrm failed for LC_COLLATE=%s; errno=%d, input=%s\n",
5488 PL_collation_name, errno,
5489 _byte_dump_string((U8 *) s, len, 0)));
5493 /* Here, the transformation was successful. Some systems include a
5494 * trailing NUL in the returned length. Ignore it, using a loop in
5495 * case multiple trailing NULs are returned. */
5497 && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
5502 /* If the first try didn't get it, it means our prediction was low.
5503 * Modify the coefficients so that we predict a larger value in any
5504 * future transformations */
5506 STRLEN needed = *xlen + 1; /* +1 For trailing NUL */
5507 STRLEN computed_guess = PL_collxfrm_base
5508 + (PL_collxfrm_mult * length_in_chars);
5510 /* On zero-length input, just keep current slope instead of
5512 const STRLEN new_m = (length_in_chars != 0)
5513 ? needed / length_in_chars
5516 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5517 "initial size of %zu bytes for a length "
5518 "%zu string was insufficient, %zu needed\n",
5519 computed_guess, length_in_chars, needed));
5521 /* If slope increased, use it, but discard this result for
5522 * length 1 strings, as we can't be sure that it's a real slope
5524 if (length_in_chars > 1 && new_m > PL_collxfrm_mult) {
5528 STRLEN old_m = PL_collxfrm_mult;
5529 STRLEN old_b = PL_collxfrm_base;
5533 PL_collxfrm_mult = new_m;
5534 PL_collxfrm_base = 1; /* +1 For trailing NUL */
5535 computed_guess = PL_collxfrm_base
5536 + (PL_collxfrm_mult * length_in_chars);
5537 if (computed_guess < needed) {
5538 PL_collxfrm_base += needed - computed_guess;
5541 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5542 "slope is now %zu; was %zu, base "
5543 "is now %zu; was %zu\n",
5544 PL_collxfrm_mult, old_m,
5545 PL_collxfrm_base, old_b));
5547 else { /* Slope didn't change, but 'b' did */
5548 const STRLEN new_b = needed
5551 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5552 "base is now %zu; was %zu\n", new_b, PL_collxfrm_base));
5553 PL_collxfrm_base = new_b;
5560 if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
5561 DEBUG_L(PerlIO_printf(Perl_debug_log,
5562 "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
5563 *xlen, PERL_INT_MAX));
5567 /* A well-behaved strxfrm() returns exactly how much space it needs
5568 * (usually not including the trailing NUL) when it fails due to not
5569 * enough space being provided. Assume that this is the case unless
5570 * it's been proven otherwise */
5571 if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
5572 xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
5574 else { /* Here, either:
5575 * 1) The strxfrm() has previously shown bad behavior; or
5576 * 2) It isn't the first time through the loop, which means
5577 * that the strxfrm() is now showing bad behavior, because
5578 * we gave it what it said was needed in the previous
5579 * iteration, and it came back saying it needed still more.
5580 * (Many versions of cygwin fit this. When the buffer size
5581 * isn't sufficient, they return the input size instead of
5582 * how much is needed.)
5583 * Increase the buffer size by a fixed percentage and try again.
5585 xAlloc += (xAlloc / 4) + 1;
5586 PL_strxfrm_is_behaved = FALSE;
5588 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5589 "_mem_collxfrm required more space than previously"
5590 " calculated for locale %s, trying again with new"
5592 PL_collation_name, COLLXFRM_HDR_LEN,
5593 xAlloc - COLLXFRM_HDR_LEN));
5596 Renew(xbuf, xAlloc, char);
5597 if (UNLIKELY(! xbuf)) {
5598 DEBUG_L(PerlIO_printf(Perl_debug_log,
5599 "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
5606 DEBUG_Lv((print_collxfrm_input_and_return(s, s + len, xlen, utf8),
5607 PerlIO_printf(Perl_debug_log, "Its xfrm is:"),
5608 PerlIO_printf(Perl_debug_log, "%s\n",
5609 _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
5612 /* Free up unneeded space; retain enough for trailing NUL */
5613 Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
5615 if (s != input_string) {
5623 DEBUG_Lv(print_collxfrm_input_and_return(s, s + len, NULL, utf8));
5626 if (s != input_string) {
5637 S_print_collxfrm_input_and_return(pTHX_
5638 const char * const s,
5639 const char * const e,
5640 const STRLEN * const xlen,
5644 PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
5646 PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
5647 (UV)PL_collation_ix);
5649 PerlIO_printf(Perl_debug_log, "%zu", *xlen);
5652 PerlIO_printf(Perl_debug_log, "NULL");
5654 PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
5656 print_bytes_for_locale(s, e, is_utf8);
5658 PerlIO_printf(Perl_debug_log, "'\n");
5661 # endif /* DEBUGGING */
5662 #endif /* USE_LOCALE_COLLATE */
5668 S_print_bytes_for_locale(pTHX_
5669 const char * const s,
5670 const char * const e,
5674 bool prev_was_printable = TRUE;
5675 bool first_time = TRUE;
5677 PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
5681 ? utf8_to_uvchr_buf((U8 *) t, e, NULL)
5684 if (! prev_was_printable) {
5685 PerlIO_printf(Perl_debug_log, " ");
5687 PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
5688 prev_was_printable = TRUE;
5692 PerlIO_printf(Perl_debug_log, " ");
5694 PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
5695 prev_was_printable = FALSE;
5697 t += (is_utf8) ? UTF8SKIP(t) : 1;
5702 # endif /* #ifdef DEBUGGING */
5705 S_toggle_locale_i(pTHX_ const unsigned cat_index,
5706 const char * new_locale,
5707 const line_t caller_line)
5709 /* Changes the locale for the category specified by 'index' to 'new_locale,
5710 * if they aren't already the same.
5712 * Returns a copy of the name of the original locale for 'cat_index'
5713 * so can be switched back to with the companion function
5714 * restore_toggled_locale_i(), (NULL if no restoral is necessary.) */
5716 const char * locale_to_restore_to = NULL;
5718 PERL_ARGS_ASSERT_TOGGLE_LOCALE_I;
5719 assert(cat_index <= NOMINAL_LC_ALL_INDEX);
5721 /* Find the original locale of the category we may need to change, so that
5722 * it can be restored to later */
5724 locale_to_restore_to = querylocale_i(cat_index);
5726 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5727 "(%" LINE_Tf "): toggle_locale_i: index=%d(%s), wanted=%s,"
5729 caller_line, cat_index, category_names[cat_index],
5730 new_locale, locale_to_restore_to));
5732 if (! locale_to_restore_to) {
5733 locale_panic_(Perl_form(aTHX_ "Could not find current %s locale, errno=%d",
5734 category_names[cat_index], errno));
5737 /* If the locales are the same, there's nothing to do */
5738 if (strEQ(locale_to_restore_to, new_locale)) {
5739 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5740 "(%d): %s locale unchanged as %s\n",
5741 caller_line, category_names[cat_index],
5747 /* Finally, change the locale to the new one */
5748 void_setlocale_i(cat_index, new_locale);
5750 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "(%" LINE_Tf "): %s locale switched to %s\n",
5751 caller_line, category_names[cat_index], new_locale));
5753 return locale_to_restore_to;
5756 PERL_UNUSED_ARG(caller_line);
5762 S_restore_toggled_locale_i(pTHX_ const unsigned int cat_index,
5763 const char * restore_locale,
5764 const line_t caller_line)
5766 /* Restores the locale for LC_category corresponding to cat_indes to
5767 * 'restore_locale' (which is a copy that will be freed by this function),
5768 * or do nothing if the latter parameter is NULL */
5770 PERL_ARGS_ASSERT_RESTORE_TOGGLED_LOCALE_I;
5771 assert(cat_index <= NOMINAL_LC_ALL_INDEX);
5773 if (restore_locale == NULL) {
5774 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5775 "(%" LINE_Tf "): No need to restore %s\n",
5776 caller_line, category_names[cat_index]));
5780 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5781 "(%" LINE_Tf "): %s restoring locale to %s\n",
5782 caller_line, category_names[cat_index],
5785 void_setlocale_i(cat_index, restore_locale);
5788 PERL_UNUSED_ARG(caller_line);
5794 S_switch_category_locale_to_template(pTHX_ const int switch_category,
5795 const int template_category,
5796 const char * template_locale)
5798 /* Changes the locale for LC_'switch_category" to that of
5799 * LC_'template_category', if they aren't already the same. If not NULL,
5800 * 'template_locale' is the locale that 'template_category' is in.
5802 * Returns a copy of the name of the original locale for 'switch_category'
5803 * so can be switched back to with the companion function
5804 * restore_switched_locale(), (NULL if no restoral is necessary.) */
5806 const char * restore_to_locale = NULL;
5808 if (switch_category == template_category) { /* No changes needed */
5812 /* Find the original locale of the category we may need to change, so that
5813 * it can be restored to later */
5814 restore_to_locale = querylocale_r(switch_category);
5815 if (! restore_to_locale) {
5816 locale_panic_(Perl_form(aTHX_ "Could not find current %s locale",
5817 category_name(switch_category)));
5819 restore_to_locale = savepv(restore_to_locale);
5821 /* If the locale of the template category wasn't passed in, find it now */
5822 if (template_locale == NULL) {
5823 template_locale = querylocale_r(template_category);
5824 if (! template_locale) {
5825 locale_panic_(Perl_form(aTHX_ "Could not find current %s locale\n",
5826 category_name(template_category)));
5830 /* It the locales are the same, there's nothing to do */
5831 if (strEQ(restore_to_locale, template_locale)) {
5832 Safefree(restore_to_locale);
5834 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale unchanged as %s\n",
5835 category_name(switch_category), template_locale));
5840 /* Finally, change the locale to the template one */
5841 if (! bool_setlocale_r(switch_category, template_locale)) {
5842 setlocale_failure_panic_i(get_category_index(switch_category,
5844 category_name(switch_category),
5850 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale switched to %s\n",
5851 category_name(switch_category), template_locale));
5853 return restore_to_locale;
5857 S_restore_switched_locale(pTHX_ const int category,
5858 const char * const original_locale)
5860 /* Restores the locale for LC_'category' to 'original_locale' (which is a
5861 * copy that will be freed by this function), or do nothing if the latter
5862 * parameter is NULL */
5864 if (original_locale == NULL) {
5868 if (! bool_setlocale_r(category, original_locale)) {
5869 locale_panic_(Perl_form(aTHX_ "s restoring %s to %s failed",
5870 category_name(category), original_locale));
5873 Safefree(original_locale);
5876 /* is_cur_LC_category_utf8 uses a small char buffer to avoid malloc/free */
5877 # define CUR_LC_BUFFER_SIZE 64
5880 Perl__is_cur_LC_category_utf8(pTHX_ int category)
5882 /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
5883 * otherwise. 'category' may not be LC_ALL. If the platform doesn't have
5884 * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
5885 * could give the wrong result. The result will very likely be correct for
5886 * languages that have commonly used non-ASCII characters, but for notably
5887 * English, it comes down to if the locale's name ends in something like
5888 * "UTF-8". It errs on the side of not being a UTF-8 locale.
5890 * If the platform is early C89, not containing mbtowc(), or we are
5891 * compiled to not pay attention to LC_CTYPE, this employs heuristics.
5892 * These work very well for non-Latin locales or those whose currency
5893 * symbol isn't a '$' nor plain ASCII text. But without LC_CTYPE and at
5894 * least MB_CUR_MAX, English locales with an ASCII currency symbol depend
5895 * on the name containing UTF-8 or not. */
5897 /* Name of current locale corresponding to the input category */
5898 const char *save_input_locale = NULL;
5900 bool is_utf8 = FALSE; /* The return value */
5902 /* The variables below are for the cache of previous lookups using this
5903 * function. The cache is a C string, described at the definition for
5904 * 'C_and_POSIX_utf8ness'.
5906 * The first part of the cache is fixed, for the C and POSIX locales. The
5907 * varying part starts just after them. */
5908 char * utf8ness_cache = PL_locale_utf8ness + STRLENs(C_and_POSIX_utf8ness);
5910 Size_t utf8ness_cache_size; /* Size of the varying portion */
5911 Size_t input_name_len; /* Length in bytes of save_input_locale */
5912 Size_t input_name_len_with_overhead; /* plus extra chars used to store
5913 the name in the cache */
5914 char * delimited; /* The name plus the delimiters used to store
5916 char buffer[CUR_LC_BUFFER_SIZE]; /* small buffer */
5917 char * name_pos; /* position of 'delimited' in the cache, or 0
5923 assert(category != LC_ALL);
5927 /* Get the desired category's locale */
5928 save_input_locale = querylocale_r(category);
5930 DEBUG_L(PerlIO_printf(Perl_debug_log,
5931 "Current locale for %s is %s\n",
5932 category_name(category), save_input_locale));
5934 input_name_len = strlen(save_input_locale);
5936 /* In our cache, each name is accompanied by two delimiters and a single
5938 input_name_len_with_overhead = input_name_len + 3;
5940 if ( input_name_len_with_overhead <= CUR_LC_BUFFER_SIZE ) {
5941 /* we can use the buffer, avoid a malloc */
5943 } else { /* need a malloc */
5944 /* Allocate and populate space for a copy of the name surrounded by the
5946 Newx(delimited, input_name_len_with_overhead, char);
5949 delimited[0] = UTF8NESS_SEP[0];
5950 Copy(save_input_locale, delimited + 1, input_name_len, char);
5951 delimited[input_name_len+1] = UTF8NESS_PREFIX[0];
5952 delimited[input_name_len+2] = '\0';
5954 /* And see if that is in the cache */
5955 name_pos = instr(PL_locale_utf8ness, delimited);
5957 is_utf8 = *(name_pos + input_name_len_with_overhead - 1) - '0';
5959 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5960 "UTF8ness for locale %s=%d, \n",
5961 save_input_locale, is_utf8));
5963 /* And, if not already in that position, move it to the beginning of
5964 * the non-constant portion of the list, since it is the most recently
5965 * used. (We don't have to worry about overflow, since just moving
5966 * existing names around) */
5967 if (name_pos > utf8ness_cache) {
5968 Move(utf8ness_cache,
5969 utf8ness_cache + input_name_len_with_overhead,
5970 name_pos - utf8ness_cache, char);
5973 input_name_len_with_overhead - 1, char);
5974 utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
5977 /* free only when not using the buffer */
5978 if ( delimited != buffer ) Safefree(delimited);
5982 /* Here we don't have stored the utf8ness for the input locale. We have to
5985 # if defined(USE_LOCALE_CTYPE) \
5986 && ( defined(HAS_SOME_LANGINFO) \
5987 || (defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)))
5990 const char *original_ctype_locale
5991 = switch_category_locale_to_template(LC_CTYPE,
5995 /* Here the current LC_CTYPE is set to the locale of the category whose
5996 * information is desired. This means that nl_langinfo() and mbtowc()
5997 * should give the correct results */
5999 # ifdef MB_CUR_MAX /* But we can potentially rule out UTF-8ness, avoiding
6000 calling the functions if we have this */
6002 /* Standard UTF-8 needs at least 4 bytes to represent the maximum
6003 * Unicode code point. */
6005 DEBUG_L(PerlIO_printf(Perl_debug_log, "MB_CUR_MAX=%d\n",
6007 if ((unsigned) MB_CUR_MAX < STRLENs(MAX_UNICODE_UTF8)) {
6009 restore_switched_locale(LC_CTYPE, original_ctype_locale);
6010 goto finish_and_return;
6014 # if defined(HAS_SOME_LANGINFO)
6016 { /* The task is easiest if the platform has this POSIX 2001 function.
6017 Except on some platforms it can wrongly return "", so have to have
6018 a fallback. And it can return that it's UTF-8, even if there are
6019 variances from that. For example, Turkish locales may use the
6020 alternate dotted I rules, and sometimes it appears to be a
6021 defective locale definition. XXX We should probably check for
6022 these in the Latin1 range and warn (but on glibc, requires
6023 iswalnum() etc. due to their not handling 80-FF correctly */
6024 const char * scratch_buffer = NULL;
6025 const char *codeset = my_langinfo_c(CODESET, LC_CTYPE,
6027 &scratch_buffer, NULL, NULL);
6029 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6030 "\tnllanginfo returned CODESET '%s'\n", codeset));
6032 if (codeset && strNE(codeset, "")) {
6034 /* If the implementation of foldEQ() somehow were
6035 * to change to not go byte-by-byte, this could
6036 * read past end of string, as only one length is
6037 * checked. But currently, a premature NUL will
6038 * compare false, and it will stop there */
6039 is_utf8 = cBOOL( foldEQ(codeset, "UTF-8", STRLENs("UTF-8"))
6040 || foldEQ(codeset, "UTF8", STRLENs("UTF8")));
6042 DEBUG_L(PerlIO_printf(Perl_debug_log,
6043 "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n",
6045 restore_switched_locale(LC_CTYPE, original_ctype_locale);
6046 Safefree(scratch_buffer);
6047 goto finish_and_return;
6052 # if defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
6053 /* We can see if this is a UTF-8-like locale if have mbtowc(). It was a
6054 * late adder to C89, so very likely to have it. However, testing has
6055 * shown that, like nl_langinfo() above, there are locales that are not
6056 * strictly UTF-8 that this will return that they are */
6061 PERL_UNUSED_RESULT(mbtowc_(NULL, NULL, 0));
6062 len = mbtowc_(&wc, REPLACEMENT_CHARACTER_UTF8,
6063 STRLENs(REPLACEMENT_CHARACTER_UTF8));
6065 is_utf8 = cBOOL( len == STRLENs(REPLACEMENT_CHARACTER_UTF8)
6066 && wc == (wchar_t) UNICODE_REPLACEMENT);
6071 restore_switched_locale(LC_CTYPE, original_ctype_locale);
6072 goto finish_and_return;
6077 /* Here, we must have a C89 compiler that doesn't have mbtowc(). Next
6078 * try looking at the currency symbol to see if it disambiguates
6079 * things. Often that will be in the native script, and if the symbol
6080 * isn't in UTF-8, we know that the locale isn't. If it is non-ASCII
6081 * UTF-8, we infer that the locale is too, as the odds of a non-UTF8
6082 * string being valid UTF-8 are quite small */
6084 # ifdef USE_LOCALE_MONETARY
6086 /* If have LC_MONETARY, we can look at the currency symbol. Often that
6087 * will be in the native script. We do this one first because there is
6088 * just one string to examine, so potentially avoids work */
6091 const char *original_monetary_locale
6092 = switch_category_locale_to_template(LC_MONETARY,
6095 bool only_ascii = FALSE;
6096 const char * scratch_buffer = NULL;
6097 const U8 * currency_string
6098 = (const U8 *) my_langinfo_c(CRNCYSTR, LC_MONETARY,
6100 &scratch_buffer, NULL, NULL);
6101 /* 2nd param not relevant for this item */
6102 const U8 * first_variant;
6104 assert( *currency_string == '-'
6105 || *currency_string == '+'
6106 || *currency_string == '.');
6110 if (is_utf8_invariant_string_loc(currency_string, 0, &first_variant))
6112 DEBUG_L(PerlIO_printf(Perl_debug_log,
6113 "Couldn't get currency symbol for %s, or contains"
6114 " only ASCII; can't use for determining if UTF-8"
6115 " locale\n", save_input_locale));
6119 is_utf8 = is_strict_utf8_string(first_variant, 0);
6121 Safefree(scratch_buffer);
6123 restore_switched_locale(LC_MONETARY, original_monetary_locale);
6127 /* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
6128 * otherwise assume the locale is UTF-8 if and only if the symbol
6129 * is non-ascii UTF-8. */
6130 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6131 "\t?Currency symbol for %s is UTF-8=%d\n",
6132 save_input_locale, is_utf8));
6133 goto finish_and_return;
6137 # endif /* USE_LOCALE_MONETARY */
6138 # if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME)
6140 /* Still haven't found a non-ASCII string to disambiguate UTF-8 or not. Try
6141 * the names of the months and weekdays, timezone, and am/pm indicator */
6143 const char *original_time_locale
6144 = switch_category_locale_to_template(LC_TIME,
6148 bool is_dst = FALSE;
6152 char * formatted_time;
6154 /* Here the current LC_TIME is set to the locale of the category
6155 * whose information is desired. Look at all the days of the week
6156 * and month names, and the timezone and am/pm indicator for UTF-8
6157 * variant characters. The first such a one found will tell us if
6158 * the locale is UTF-8 or not */
6160 for (i = 0; i < 7 + 12; i++) { /* 7 days; 12 months */
6161 formatted_time = my_strftime("%A %B %Z %p",
6162 0, 0, hour, dom, month, 2012 - 1900, 0, 0, is_dst);
6163 if ( ! formatted_time
6164 || is_utf8_invariant_string((U8 *) formatted_time, 0))
6167 /* Here, we didn't find a non-ASCII. Try the next time
6168 * through with the complemented dst and am/pm, and try
6169 * with the next weekday. After we have gotten all
6170 * weekdays, try the next month */
6172 hour = (hour + 12) % 24;
6177 Safefree(formatted_time);
6181 /* Here, we have a non-ASCII. Return TRUE is it is valid UTF8;
6182 * false otherwise. But first, restore LC_TIME to its original
6183 * locale if we changed it */
6184 restore_switched_locale(LC_TIME, original_time_locale);
6186 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6187 "\t?time-related strings for %s are UTF-8=%d\n",
6189 is_utf8_string((U8 *) formatted_time, 0)));
6190 is_utf8 = is_utf8_string((U8 *) formatted_time, 0);
6191 Safefree(formatted_time);
6192 goto finish_and_return;
6195 /* Falling off the end of the loop indicates all the names were just
6196 * ASCII. Go on to the next test. If we changed it, restore LC_TIME
6197 * to its original locale */
6198 restore_switched_locale(LC_TIME, original_time_locale);
6199 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6200 "All time-related words for %s contain only ASCII;"
6201 " can't use for determining if UTF-8 locale\n",
6202 save_input_locale));
6207 # if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST)
6209 /* This code is ifdefd out because it was found to not be necessary in
6210 * testing on our dromedary test machine, which has over 700 locales.
6211 * There, this added no value to looking at the currency symbol and the
6212 * time strings. I left it in so as to avoid rewriting it if real-world
6213 * experience indicates that dromedary is an outlier. Essentially, instead
6214 * of returning abpve if we haven't found illegal utf8, we continue on and
6215 * examine all the strerror() messages on the platform for utf8ness. If
6216 * all are ASCII, we still don't know the answer; but otherwise we have a
6217 * pretty good indication of the utf8ness. The reason this doesn't help
6218 * much is that the messages may not have been translated into the locale.
6219 * The currency symbol and time strings are much more likely to have been
6223 bool non_ascii = FALSE;
6224 const char *original_messages_locale
6225 = switch_category_locale_to_template(LC_MESSAGES,
6228 const char * errmsg = NULL;
6230 /* Here the current LC_MESSAGES is set to the locale of the category
6231 * whose information is desired. Look through all the messages. We
6232 * can't use Strerror() here because it may expand to code that
6233 * segfaults in miniperl */
6235 for (e = 0; e <= sys_nerr; e++) {
6237 errmsg = sys_errlist[e];
6238 if (errno || !errmsg) {
6241 errmsg = savepv(errmsg);
6242 if (! is_utf8_invariant_string((U8 *) errmsg, 0)) {
6244 is_utf8 = is_utf8_string((U8 *) errmsg, 0);
6250 restore_switched_locale(LC_MESSAGES, original_messages_locale);
6254 /* Any non-UTF-8 message means not a UTF-8 locale; if all are
6255 * valid, any non-ascii means it is one; otherwise we assume it
6257 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6258 "\t?error messages for %s are UTF-8=%d\n",
6261 goto finish_and_return;
6264 DEBUG_L(PerlIO_printf(Perl_debug_log,
6265 "All error messages for %s contain only ASCII;"
6266 " can't use for determining if UTF-8 locale\n",
6267 save_input_locale));
6271 # ifndef EBCDIC /* On os390, even if the name ends with "UTF-8', it isn't a
6274 /* As a last resort, look at the locale name to see if it matches
6275 * qr/UTF -? * 8 /ix, or some other common locale names. This "name", the
6276 * return of setlocale(), is actually defined to be opaque, so we can't
6277 * really rely on the absence of various substrings in the name to indicate
6278 * its UTF-8ness, but if it has UTF8 in the name, it is extremely likely to
6279 * be a UTF-8 locale. Similarly for the other common names */
6282 const Size_t final_pos = strlen(save_input_locale) - 1;
6284 if (final_pos >= 3) {
6285 const char *name = save_input_locale;
6287 /* Find next 'U' or 'u' and look from there */
6288 while ((name += strcspn(name, "Uu") + 1)
6289 <= save_input_locale + final_pos - 2)
6291 if ( isALPHA_FOLD_NE(*name, 't')
6292 || isALPHA_FOLD_NE(*(name + 1), 'f'))
6297 if (*(name) == '-') {
6298 if ((name > save_input_locale + final_pos - 1)) {
6303 if (*(name) == '8') {
6304 DEBUG_L(PerlIO_printf(Perl_debug_log,
6305 "Locale %s ends with UTF-8 in name\n",
6306 save_input_locale));
6308 goto finish_and_return;
6311 DEBUG_L(PerlIO_printf(Perl_debug_log,
6312 "Locale %s doesn't end with UTF-8 in name\n",
6313 save_input_locale));
6318 /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
6319 if (memENDs(save_input_locale, final_pos, "65001")) {
6320 DEBUG_L(PerlIO_printf(Perl_debug_log,
6321 "Locale %s ends with 65001 in name, is UTF-8 locale\n",
6322 save_input_locale));
6324 goto finish_and_return;
6331 /* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
6332 * since we are about to return FALSE anyway, there is no point in doing
6333 * this extra work */
6336 if (instr(save_input_locale, "8859")) {
6337 DEBUG_L(PerlIO_printf(Perl_debug_log,
6338 "Locale %s has 8859 in name, not UTF-8 locale\n",
6339 save_input_locale));
6341 goto finish_and_return;
6345 DEBUG_L(PerlIO_printf(Perl_debug_log,
6346 "Assuming locale %s is not a UTF-8 locale\n",
6347 save_input_locale));
6350 # endif /* the code that is compiled when no modern LC_CTYPE */
6354 /* Cache this result so we don't have to go through all this next time. */
6355 utf8ness_cache_size = sizeof(PL_locale_utf8ness)
6356 - (utf8ness_cache - PL_locale_utf8ness);
6358 /* But we can't save it if it is too large for the total space available */
6359 if (LIKELY(input_name_len_with_overhead < utf8ness_cache_size)) {
6360 Size_t utf8ness_cache_len = strlen(utf8ness_cache);
6362 /* Here it can fit, but we may need to clear out the oldest cached
6363 * result(s) to do so. Check */
6364 if (utf8ness_cache_len + input_name_len_with_overhead
6365 >= utf8ness_cache_size)
6367 /* Here we have to clear something out to make room for this.
6368 * Start looking at the rightmost place where it could fit and find
6369 * the beginning of the entry that extends past that. */
6370 char * cutoff = (char *) my_memrchr(utf8ness_cache,
6373 - input_name_len_with_overhead);
6376 assert(cutoff >= utf8ness_cache);
6378 /* This and all subsequent entries must be removed */
6380 utf8ness_cache_len = strlen(utf8ness_cache);
6383 /* Make space for the new entry */
6384 Move(utf8ness_cache,
6385 utf8ness_cache + input_name_len_with_overhead,
6386 utf8ness_cache_len + 1 /* Incl. trailing NUL */, char);
6389 Copy(delimited, utf8ness_cache, input_name_len_with_overhead - 1, char);
6390 utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
6392 if ((PL_locale_utf8ness[strlen(PL_locale_utf8ness)-1] & ~1) != '0') {
6393 locale_panic_(Perl_form(aTHX_
6394 "Corrupt utf8ness_cache=%s\nlen=%zu,"
6395 " inserted_name=%s, its_len=%zu",
6396 PL_locale_utf8ness, strlen(PL_locale_utf8ness),
6397 delimited, input_name_len_with_overhead));
6403 if (DEBUG_Lv_TEST) {
6404 const char * s = PL_locale_utf8ness;
6406 /* Audit the structure */
6407 while (s < PL_locale_utf8ness + strlen(PL_locale_utf8ness)) {
6410 if (*s != UTF8NESS_SEP[0]) {
6411 locale_panic_(Perl_form(aTHX_
6412 "Corrupt utf8ness_cache: missing"
6413 " separator %.*s<-- HERE %s",
6414 (int) (s - PL_locale_utf8ness),
6419 e = strchr(s, UTF8NESS_PREFIX[0]);
6421 e = PL_locale_utf8ness + strlen(PL_locale_utf8ness);
6422 locale_panic_(Perl_form(aTHX_
6423 "Corrupt utf8ness_cache: missing"
6424 " separator %.*s<-- HERE %s",
6425 (int) (e - PL_locale_utf8ness),
6430 if (*e != '0' && *e != '1') {
6431 locale_panic_(Perl_form(aTHX_
6432 "Corrupt utf8ness_cache: utf8ness"
6433 " must be [01] %.*s<-- HERE %s",
6434 (int) (e + 1 - PL_locale_utf8ness),
6438 if (ninstr(PL_locale_utf8ness, s, s-1, e)) {
6439 locale_panic_(Perl_form(aTHX_
6440 "Corrupt utf8ness_cache: entry"
6441 " has duplicate %.*s<-- HERE %s",
6442 (int) (e - PL_locale_utf8ness),
6450 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6451 "PL_locale_utf8ness is now %s; returning %d\n",
6452 PL_locale_utf8ness, is_utf8));
6456 /* free only when not using the buffer */
6457 if ( delimited != buffer ) Safefree(delimited);
6462 S_is_codeset_name_UTF8(const char * name)
6464 /* Return a boolean as to if the passed-in name indicates it is a UTF-8
6465 * code set. Several variants are possible */
6466 const Size_t len = strlen(name);
6468 PERL_ARGS_ASSERT_IS_CODESET_NAME_UTF8;
6472 /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
6473 if (memENDs(name, len, "65001")) {
6478 /* 'UTF8' or 'UTF-8' */
6479 return ( inRANGE(len, 4, 5)
6480 && name[len-1] == '8'
6481 && ( memBEGINs(name, len, "UTF")
6482 || memBEGINs(name, len, "utf"))
6483 && (len == 4 || name[3] == '-'));
6487 S_is_locale_utf8(pTHX_ const char * locale)
6489 /* Returns TRUE if the locale 'locale' is UTF-8; FALSE otherwise. It uses
6490 * my_langinfo(), which employs various methods to get this information
6491 * if nl_langinfo() isn't available, using heuristics as a last resort, in
6492 * which case, the result will very likely be correct for locales for
6493 * languages that have commonly used non-ASCII characters, but for notably
6494 * English, it comes down to if the locale's name ends in something like
6495 * "UTF-8". It errs on the side of not being a UTF-8 locale. */
6497 # if ! defined(USE_LOCALE_CTYPE) \
6498 || defined(EBCDIC) /* There aren't any real UTF-8 locales at this time */
6500 PERL_UNUSED_ARG(locale);
6506 const char * scratch_buffer = NULL;
6507 const char * codeset = my_langinfo_c(CODESET, LC_CTYPE, locale,
6508 &scratch_buffer, NULL, NULL);
6509 bool retval = is_codeset_name_UTF8(codeset);
6511 PERL_ARGS_ASSERT_IS_LOCALE_UTF8;
6513 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6514 "found codeset=%s, is_utf8=%d\n", codeset, retval));
6516 Safefree(scratch_buffer);
6523 #endif /* USE_LOCALE */
6526 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
6528 /* Internal function which returns if we are in the scope of a pragma that
6529 * enables the locale category 'category'. 'compiling' should indicate if
6530 * this is during the compilation phase (TRUE) or not (FALSE). */
6532 const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
6534 SV *these_categories = cop_hints_fetch_pvs(cop, "locale", 0);
6535 if (! these_categories || these_categories == &PL_sv_placeholder) {
6539 /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
6540 * a valid unsigned */
6541 assert(category >= -1);
6542 return cBOOL(SvUV(these_categories) & (1U << (category + 1)));
6546 Perl_my_strerror(pTHX_ const int errnum)
6548 /* Returns a mortalized copy of the text of the error message associated
6549 * with 'errnum'. It uses the current locale's text unless the platform
6550 * doesn't have the LC_MESSAGES category or we are not being called from
6551 * within the scope of 'use locale'. In the former case, it uses whatever
6552 * strerror returns; in the latter case it uses the text from the C locale.
6554 * The function just calls strerror(), but temporarily switches, if needed,
6555 * to the C locale */
6559 #ifndef USE_LOCALE_MESSAGES
6561 /* If platform doesn't have messages category, we don't do any switching to
6562 * the C locale; we just use whatever strerror() returns */
6564 errstr = savepv(Strerror(errnum));
6566 #else /* Has locale messages */
6568 const bool within_locale_scope = IN_LC(LC_MESSAGES);
6570 # ifndef USE_LOCALE_THREADS
6572 /* This function is trivial without threads. */
6573 if (within_locale_scope) {
6574 errstr = savepv(Strerror(errnum));
6577 const char * save_locale = querylocale_c(LC_MESSAGES);
6579 void_setlocale_c(LC_MESSAGES, "C");
6580 errstr = savepv(Strerror(errnum));
6581 void_setlocale_c(LC_MESSAGES, save_locale);
6584 # elif defined(USE_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
6586 /* This function is also trivial if we don't have to worry about thread
6587 * safety and have strerror_l(), as it handles the switch of locales so we
6588 * don't have to deal with that. We don't have to worry about thread
6589 * safety if strerror_r() is also available. Both it and strerror_l() are
6590 * thread-safe. Plain strerror() isn't thread safe. But on threaded
6591 * builds when strerror_r() is available, the apparent call to strerror()
6592 * below is actually a macro that behind-the-scenes calls strerror_r(). */
6594 # ifdef HAS_STRERROR_R
6596 if (within_locale_scope) {
6597 errstr = savepv(Strerror(errnum));
6600 errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
6605 /* Here we have strerror_l(), but not strerror_r() and we are on a
6606 * threaded-build. We use strerror_l() for everything, constructing a
6607 * locale to pass to it if necessary */
6609 locale_t locale_to_use;
6611 if (within_locale_scope) {
6612 locale_to_use = use_curlocale_scratch();
6614 else { /* Use C locale if not within 'use locale' scope */
6615 locale_to_use = PL_C_locale_obj;
6618 errstr = savepv(strerror_l(errnum, locale_to_use));
6621 # else /* Doesn't have strerror_l() */
6623 const char * save_locale = NULL;
6624 bool locale_is_C = FALSE;
6626 /* We have a critical section to prevent another thread from executing this
6627 * same code at the same time which could cause LC_MESSAGES to be changed
6628 * to something else while we need it to be constant. (On thread-safe
6629 * perls, the LOCK is a no-op.) Since this is the only place in core that
6630 * changes LC_MESSAGES (unless the user has called setlocale()), this works
6631 * to prevent races. */
6634 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6635 "my_strerror called with errnum %d\n", errnum));
6637 /* If not within locale scope, need to return messages in the C locale */
6638 if (within_locale_scope) {
6639 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "WITHIN locale scope\n"));
6642 save_locale = querylocale_c(LC_MESSAGES);
6643 if (! save_locale) {
6645 locale_panic_("Could not find current LC_MESSAGES locale");
6646 NOT_REACHED; /* NOTREACHED */ \
6649 locale_is_C = isNAME_C_OR_POSIX(save_locale);
6651 /* Switch to the C locale if not already in it */
6652 if (! locale_is_C && ! bool_setlocale_c(LC_MESSAGES, "C")) {
6654 /* If, for some reason, the locale change failed, we soldier on as
6655 * best as possible under the circumstances, using the current
6656 * locale, and clear save_locale, so we don't try to change back.
6657 * On z/0S, all setlocale() calls fail after you've created a
6658 * thread. This is their way of making sure the entire process is
6659 * always a single locale. This means that 'use locale' is always
6660 * in place for messages under these circumstances. */
6663 } /* end of ! within_locale_scope */
6665 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6666 "Any locale change has been done; about to call Strerror\n"));
6667 errstr = savepv(Strerror(errnum));
6669 /* Switch back if we successully switched */
6672 && ! bool_setlocale_c(LC_MESSAGES, save_locale))
6675 locale_panic_(Perl_form(aTHX_
6676 "setlocale restore to '%s' failed",
6678 NOT_REACHED; /* NOTREACHED */ \
6683 # endif /* End of doesn't have strerror_l */
6685 DEBUG_Lv((PerlIO_printf(Perl_debug_log,
6686 "Strerror returned; saving a copy: '"),
6687 print_bytes_for_locale(errstr, errstr + strlen(errstr), 0),
6688 PerlIO_printf(Perl_debug_log, "'\n")));
6690 #endif /* End of does have locale messages */
6698 =for apidoc switch_to_global_locale
6700 On systems without locale support, or on typical single-threaded builds, or on
6701 platforms that do not support per-thread locale operations, this function does
6702 nothing. On such systems that do have locale support, only a locale global to
6703 the whole program is available.
6705 On multi-threaded builds on systems that do have per-thread locale operations,
6706 this function converts the thread it is running in to use the global locale.
6707 This is for code that has not yet or cannot be updated to handle multi-threaded
6708 locale operation. As long as only a single thread is so-converted, everything
6709 works fine, as all the other threads continue to ignore the global one, so only
6710 this thread looks at it.
6712 However, on Windows systems this isn't quite true prior to Visual Studio 15,
6713 at which point Microsoft fixed a bug. A race can occur if you use the
6714 following operations on earlier Windows platforms:
6718 =item L<POSIX::localeconv|POSIX/localeconv>
6720 =item L<I18N::Langinfo>, items C<CRNCYSTR> and C<THOUSEP>
6722 =item L<perlapi/Perl_langinfo>, items C<CRNCYSTR> and C<THOUSEP>
6726 The first item is not fixable (except by upgrading to a later Visual Studio
6727 release), but it would be possible to work around the latter two items by using
6728 the Windows API functions C<GetNumberFormat> and C<GetCurrencyFormat>; patches
6731 Without this function call, threads that use the L<C<setlocale(3)>> system
6732 function will not work properly, as all the locale-sensitive functions will
6733 look at the per-thread locale, and C<setlocale> will have no effect on this
6736 Perl code should convert to either call
6737 L<C<Perl_setlocale>|perlapi/Perl_setlocale> (which is a drop-in for the system
6738 C<setlocale>) or use the methods given in L<perlcall> to call
6739 L<C<POSIX::setlocale>|POSIX/setlocale>. Either one will transparently properly
6740 handle all cases of single- vs multi-thread, POSIX 2008-supported or not.
6742 Non-Perl libraries, such as C<gtk>, that call the system C<setlocale> can
6743 continue to work if this function is called before transferring control to the
6746 Upon return from the code that needs to use the global locale,
6747 L<C<sync_locale()>|perlapi/sync_locale> should be called to restore the safe
6748 multi-thread operation.
6754 Perl_switch_to_global_locale()
6758 #ifdef USE_THREAD_SAFE_LOCALE
6761 _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
6768 for (i = 0; i < LC_ALL_INDEX_; i++) {
6769 setlocale(categories[i], querylocale_i(i));
6773 uselocale(LC_GLOBAL_LOCALE);
6782 =for apidoc sync_locale
6784 L<C<Perl_setlocale>|perlapi/Perl_setlocale> can be used at any time to query or
6785 change the locale (though changing the locale is antisocial and dangerous on
6786 multi-threaded systems that don't have multi-thread safe locale operations.
6787 (See L<perllocale/Multi-threaded operation>). Using the system
6788 L<C<setlocale(3)>> should be avoided. Nevertheless, certain non-Perl libraries
6789 called from XS, such as C<Gtk> do so, and this can't be changed. When the
6790 locale is changed by XS code that didn't use
6791 L<C<Perl_setlocale>|perlapi/Perl_setlocale>, Perl needs to be told that the
6792 locale has changed. Use this function to do so, before returning to Perl.
6794 The return value is a boolean: TRUE if the global locale at the time of call
6795 was in effect; and FALSE if a per-thread locale was in effect. This can be
6796 used by the caller that needs to restore things as-they-were to decide whether
6798 L<C<Perl_switch_to_global_locale>|perlapi/switch_to_global_locale>.
6813 const char * newlocale;
6816 # ifdef USE_POSIX_2008_LOCALE
6818 bool was_in_global_locale = FALSE;
6819 locale_t cur_obj = uselocale((locale_t) 0);
6821 /* On Windows, unless the foreign code has turned off the thread-safe
6822 * locale setting, any plain setlocale() will have affected what we see, so
6823 * no need to worry. Otherwise, If the foreign code has done a plain
6824 * setlocale(), it will only affect the global locale on POSIX systems, but
6825 * will affect the */
6826 if (cur_obj == LC_GLOBAL_LOCALE) {
6828 # ifdef HAS_QUERY_LOCALE
6830 void_setlocale_c(LC_ALL, querylocale_c(LC_ALL));
6836 /* We can't trust that we can read the LC_ALL format on the
6837 * platform, so do them individually */
6838 for (i = 0; i < LC_ALL_INDEX_; i++) {
6839 void_setlocale_i(i, querylocale_i(i));
6844 was_in_global_locale = TRUE;
6849 bool was_in_global_locale = TRUE;
6852 # ifdef USE_LOCALE_CTYPE
6854 newlocale = querylocale_c(LC_CTYPE);
6855 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6856 "%s\n", setlocale_debug_string_c(LC_CTYPE, NULL, newlocale)));
6857 new_ctype(newlocale);
6859 # endif /* USE_LOCALE_CTYPE */
6860 # ifdef USE_LOCALE_COLLATE
6862 newlocale = querylocale_c(LC_COLLATE);
6863 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6864 "%s\n", setlocale_debug_string_c(LC_COLLATE, NULL, newlocale)));
6865 new_collate(newlocale);
6868 # ifdef USE_LOCALE_NUMERIC
6870 newlocale = querylocale_c(LC_NUMERIC);
6871 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6872 "%s\n", setlocale_debug_string_c(LC_NUMERIC, NULL, newlocale)));
6873 new_numeric(newlocale);
6875 # endif /* USE_LOCALE_NUMERIC */
6877 return was_in_global_locale;
6883 #if defined(DEBUGGING) && defined(USE_LOCALE)
6886 S_setlocale_debug_string_i(const unsigned cat_index,
6887 const char* const locale, /* Optional locale name */
6889 /* return value from setlocale() when attempting to
6890 * set 'category' to 'locale' */
6891 const char* const retval)
6893 /* Returns a pointer to a NUL-terminated string in static storage with
6894 * added text about the info passed in. This is not thread safe and will
6895 * be overwritten by the next call, so this should be used just to
6896 * formulate a string to immediately print or savepv() on. */
6898 static char ret[1024];
6899 assert(cat_index <= NOMINAL_LC_ALL_INDEX);
6901 my_strlcpy(ret, "setlocale(", sizeof(ret));
6902 my_strlcat(ret, category_names[cat_index], sizeof(ret));
6903 my_strlcat(ret, ", ", sizeof(ret));
6906 my_strlcat(ret, "\"", sizeof(ret));
6907 my_strlcat(ret, locale, sizeof(ret));
6908 my_strlcat(ret, "\"", sizeof(ret));
6911 my_strlcat(ret, "NULL", sizeof(ret));
6914 my_strlcat(ret, ") returned ", sizeof(ret));
6917 my_strlcat(ret, "\"", sizeof(ret));
6918 my_strlcat(ret, retval, sizeof(ret));
6919 my_strlcat(ret, "\"", sizeof(ret));
6922 my_strlcat(ret, "NULL", sizeof(ret));
6925 assert(strlen(ret) < sizeof(ret));
6933 Perl_thread_locale_init()
6935 /* Called from a thread on startup*/
6937 #ifdef USE_THREAD_SAFE_LOCALE
6942 DEBUG_L(PerlIO_printf(Perl_debug_log,
6943 "new thread, initial locale is %s; calling setlocale\n",
6944 setlocale(LC_ALL, NULL)));
6948 /* On Windows, make sure new thread has per-thread locales enabled */
6949 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
6953 /* This thread starts off in the C locale */
6954 Perl_setlocale(LC_ALL, "C");
6962 Perl_thread_locale_term()
6964 /* Called from a thread as it gets ready to terminate */
6966 #ifdef USE_POSIX_2008_LOCALE
6968 /* C starts the new thread in the global C locale. If we are thread-safe,
6969 * we want to not be in the global locale */
6972 locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
6973 if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
6974 freelocale(cur_obj);
6983 * ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blob