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
38 #define PERL_IN_LOCALE_C
39 #include "perl_langinfo.h"
44 /* If the environment says to, we can output debugging information during
45 * initialization. This is done before option parsing, and before any thread
46 * creation, so can be a file-level static */
48 # ifdef PERL_GLOBAL_STRUCT
49 /* no global syms allowed */
50 # define debug_initialization 0
51 # define DEBUG_INITIALIZATION_set(v)
53 static bool debug_initialization = FALSE;
54 # define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
58 /* strlen() of a literal string constant. XXX We might want this more general,
59 * but using it in just this file for now */
60 #define STRLENs(s) (sizeof("" s "") - 1)
62 /* Is the C string input 'name' "C" or "POSIX"? If so, and 'name' is the
63 * return of setlocale(), then this is extremely likely to be the C or POSIX
64 * locale. However, the output of setlocale() is documented to be opaque, but
65 * the odds are extremely small that it would return these two strings for some
66 * other locale. Note that VMS in these two locales includes many non-ASCII
67 * characters as controls and punctuation (below are hex bytes):
69 * punct: A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
70 * Oddly, none there are listed as alphas, though some represent alphabetics
71 * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
72 #define isNAME_C_OR_POSIX(name) \
74 && (( *(name) == 'C' && (*(name + 1)) == '\0') \
75 || strEQ((name), "POSIX")))
80 * Standardize the locale name from a string returned by 'setlocale', possibly
81 * modifying that string.
83 * The typical return value of setlocale() is either
84 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
85 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
86 * (the space-separated values represent the various sublocales,
87 * in some unspecified order). This is not handled by this function.
89 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
90 * which is harmful for further use of the string in setlocale(). This
91 * function removes the trailing new line and everything up through the '='
95 S_stdize_locale(pTHX_ char *locs)
97 const char * const s = strchr(locs, '=');
100 PERL_ARGS_ASSERT_STDIZE_LOCALE;
103 const char * const t = strchr(s, '.');
106 const char * const u = strchr(t, '\n');
107 if (u && (u[1] == 0)) {
108 const STRLEN len = u - s;
109 Move(s + 1, locs, len, char);
117 Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
122 /* Two parallel arrays; first the locale categories Perl uses on this system;
123 * the second array is their names. These arrays are in mostly arbitrary
126 const int categories[] = {
128 # ifdef USE_LOCALE_NUMERIC
131 # ifdef USE_LOCALE_CTYPE
134 # ifdef USE_LOCALE_COLLATE
137 # ifdef USE_LOCALE_TIME
140 # ifdef USE_LOCALE_MESSAGES
143 # ifdef USE_LOCALE_MONETARY
149 -1 /* Placeholder because C doesn't allow a
150 trailing comma, and it would get complicated
151 with all the #ifdef's */
154 /* The top-most real element is LC_ALL */
156 const char * category_names[] = {
158 # ifdef USE_LOCALE_NUMERIC
161 # ifdef USE_LOCALE_CTYPE
164 # ifdef USE_LOCALE_COLLATE
167 # ifdef USE_LOCALE_TIME
170 # ifdef USE_LOCALE_MESSAGES
173 # ifdef USE_LOCALE_MONETARY
179 NULL /* Placeholder */
184 /* On systems with LC_ALL, it is kept in the highest index position. (-2
185 * to account for the final unused placeholder element.) */
186 # define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 2)
190 /* On systems without LC_ALL, we pretend it is there, one beyond the real
191 * top element, hence in the unused placeholder element. */
192 # define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 1)
196 /* Pretending there is an LC_ALL element just above allows us to avoid most
197 * special cases. Most loops through these arrays in the code below are
198 * written like 'for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)'. They will work
199 * on either type of system. But the code must be written to not access the
200 * element at 'LC_ALL_INDEX' except on platforms that have it. This can be
201 * checked for at compile time by using the #define LC_ALL_INDEX which is only
202 * defined if we do have LC_ALL. */
204 /* Now create LC_foo_INDEX #defines for just those categories on this system */
205 # ifdef USE_LOCALE_NUMERIC
206 # define LC_NUMERIC_INDEX 0
207 # define _DUMMY_NUMERIC LC_NUMERIC_INDEX
209 # define _DUMMY_NUMERIC -1
211 # ifdef USE_LOCALE_CTYPE
212 # define LC_CTYPE_INDEX _DUMMY_NUMERIC + 1
213 # define _DUMMY_CTYPE LC_CTYPE_INDEX
215 # define _DUMMY_CTYPE _DUMMY_NUMERIC
217 # ifdef USE_LOCALE_COLLATE
218 # define LC_COLLATE_INDEX _DUMMY_CTYPE + 1
219 # define _DUMMY_COLLATE LC_COLLATE_INDEX
221 # define _DUMMY_COLLATE _DUMMY_COLLATE
223 # ifdef USE_LOCALE_TIME
224 # define LC_TIME_INDEX _DUMMY_COLLATE + 1
225 # define _DUMMY_TIME LC_TIME_INDEX
227 # define _DUMMY_TIME _DUMMY_COLLATE
229 # ifdef USE_LOCALE_MESSAGES
230 # define LC_MESSAGES_INDEX _DUMMY_TIME + 1
231 # define _DUMMY_MESSAGES LC_MESSAGES_INDEX
233 # define _DUMMY_MESSAGES _DUMMY_TIME
235 # ifdef USE_LOCALE_MONETARY
236 # define LC_MONETARY_INDEX _DUMMY_MESSAGES + 1
237 # define _DUMMY_MONETARY LC_MONETARY_INDEX
239 # define _DUMMY_MONETARY _DUMMY_MESSAGES
242 # define LC_ALL_INDEX _DUMMY_MONETARY + 1
244 #endif /* ifdef USE_LOCALE */
246 /* Windows requres a customized base-level setlocale() */
248 # define my_setlocale(cat, locale) win32_setlocale(cat, locale)
250 # define my_setlocale(cat, locale) setlocale(cat, locale)
253 /* Just placeholders for now. "_c" is intended to be called when the category
254 * is a constant known at compile time; "_r", not known until run time */
255 # define do_setlocale_c(category, locale) my_setlocale(category, locale)
256 # define do_setlocale_r(category, locale) my_setlocale(category, locale)
259 S_set_numeric_radix(pTHX_ const bool use_locale)
261 /* If 'use_locale' is FALSE, set to use a dot for the radix character. If
262 * TRUE, use the radix character derived from the current locale */
264 #if defined(USE_LOCALE_NUMERIC) && ( defined(HAS_LOCALECONV) \
265 || defined(HAS_NL_LANGINFO))
267 /* We only set up the radix SV if we are to use a locale radix ... */
269 const char * radix = my_nl_langinfo(PERL_RADIXCHAR, FALSE);
270 /* FALSE => already in dest locale */
272 /* ... and the character being used isn't a dot */
273 if (strNE(radix, ".")) {
274 if (PL_numeric_radix_sv) {
275 sv_setpv(PL_numeric_radix_sv, radix);
278 PL_numeric_radix_sv = newSVpv(radix, 0);
281 if ( ! is_utf8_invariant_string(
282 (U8 *) SvPVX(PL_numeric_radix_sv), SvCUR(PL_numeric_radix_sv))
284 (U8 *) SvPVX(PL_numeric_radix_sv), SvCUR(PL_numeric_radix_sv))
285 && _is_cur_LC_category_utf8(LC_NUMERIC))
287 SvUTF8_on(PL_numeric_radix_sv);
293 SvREFCNT_dec(PL_numeric_radix_sv);
294 PL_numeric_radix_sv = NULL;
300 if (DEBUG_L_TEST || debug_initialization) {
301 PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
302 (PL_numeric_radix_sv)
303 ? SvPVX(PL_numeric_radix_sv)
305 (PL_numeric_radix_sv)
306 ? cBOOL(SvUTF8(PL_numeric_radix_sv))
311 #endif /* USE_LOCALE_NUMERIC and can find the radix char */
317 Perl_new_numeric(pTHX_ const char *newnum)
320 #ifndef USE_LOCALE_NUMERIC
322 PERL_UNUSED_ARG(newnum);
326 /* Called after all libc setlocale() calls affecting LC_NUMERIC, to tell
327 * core Perl this and that 'newnum' is the name of the new locale.
328 * It installs this locale as the current underlying default.
330 * The default locale and the C locale can be toggled between by use of the
331 * set_numeric_underlying() and set_numeric_standard() functions, which
332 * should probably not be called directly, but only via macros like
333 * SET_NUMERIC_STANDARD() in perl.h.
335 * The toggling is necessary mainly so that a non-dot radix decimal point
336 * character can be output, while allowing internal calculations to use a
339 * This sets several interpreter-level variables:
340 * PL_numeric_name The underlying locale's name: a copy of 'newnum'
341 * PL_numeric_underlying A boolean indicating if the toggled state is such
342 * that the current locale is the program's underlying
344 * PL_numeric_standard An int indicating if the toggled state is such
345 * that the current locale is the C locale. If non-zero,
346 * it is in C; if > 1, it means it may not be toggled away
348 * Note that both of the last two variables can be true at the same time,
349 * if the underlying locale is C. (Toggling is a no-op under these
352 * Any code changing the locale (outside this file) should use
353 * POSIX::setlocale, which calls this function. Therefore this function
354 * should be called directly only from this file and from
355 * POSIX::setlocale() */
360 Safefree(PL_numeric_name);
361 PL_numeric_name = NULL;
362 PL_numeric_standard = TRUE;
363 PL_numeric_underlying = TRUE;
367 save_newnum = stdize_locale(savepv(newnum));
369 PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
370 PL_numeric_underlying = TRUE;
372 if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
373 Safefree(PL_numeric_name);
374 PL_numeric_name = save_newnum;
377 Safefree(save_newnum);
380 /* Keep LC_NUMERIC in the C locale. This is for XS modules, so they don't
381 * have to worry about the radix being a non-dot. (Core operations that
382 * need the underlying locale change to it temporarily). */
383 set_numeric_standard();
385 #endif /* USE_LOCALE_NUMERIC */
390 Perl_set_numeric_standard(pTHX)
393 #ifdef USE_LOCALE_NUMERIC
395 /* Toggle the LC_NUMERIC locale to C. Most code should use the macros like
396 * SET_NUMERIC_STANDARD() in perl.h instead of calling this directly. The
397 * macro avoids calling this routine if toggling isn't necessary according
398 * to our records (which could be wrong if some XS code has changed the
399 * locale behind our back) */
401 do_setlocale_c(LC_NUMERIC, "C");
402 PL_numeric_standard = TRUE;
403 PL_numeric_underlying = isNAME_C_OR_POSIX(PL_numeric_name);
404 set_numeric_radix(0);
408 if (DEBUG_L_TEST || debug_initialization) {
409 PerlIO_printf(Perl_debug_log,
410 "LC_NUMERIC locale now is standard C\n");
414 #endif /* USE_LOCALE_NUMERIC */
419 Perl_set_numeric_underlying(pTHX)
422 #ifdef USE_LOCALE_NUMERIC
424 /* Toggle the LC_NUMERIC locale to the current underlying default. Most
425 * code should use the macros like SET_NUMERIC_UNDERLYING() in perl.h
426 * instead of calling this directly. The macro avoids calling this routine
427 * if toggling isn't necessary according to our records (which could be
428 * wrong if some XS code has changed the locale behind our back) */
430 do_setlocale_c(LC_NUMERIC, PL_numeric_name);
431 PL_numeric_standard = isNAME_C_OR_POSIX(PL_numeric_name);
432 PL_numeric_underlying = TRUE;
433 set_numeric_radix(1);
437 if (DEBUG_L_TEST || debug_initialization) {
438 PerlIO_printf(Perl_debug_log,
439 "LC_NUMERIC locale now is %s\n",
444 #endif /* USE_LOCALE_NUMERIC */
449 * Set up for a new ctype locale.
452 S_new_ctype(pTHX_ const char *newctype)
455 #ifndef USE_LOCALE_CTYPE
457 PERL_ARGS_ASSERT_NEW_CTYPE;
458 PERL_UNUSED_ARG(newctype);
463 /* Called after all libc setlocale() calls affecting LC_CTYPE, to tell
464 * core Perl this and that 'newctype' is the name of the new locale.
466 * This function sets up the folding arrays for all 256 bytes, assuming
467 * that tofold() is tolc() since fold case is not a concept in POSIX,
469 * Any code changing the locale (outside this file) should use
470 * POSIX::setlocale, which calls this function. Therefore this function
471 * should be called directly only from this file and from
472 * POSIX::setlocale() */
477 PERL_ARGS_ASSERT_NEW_CTYPE;
479 /* We will replace any bad locale warning with 1) nothing if the new one is
480 * ok; or 2) a new warning for the bad new locale */
481 if (PL_warn_locale) {
482 SvREFCNT_dec_NN(PL_warn_locale);
483 PL_warn_locale = NULL;
486 PL_in_utf8_CTYPE_locale = _is_cur_LC_category_utf8(LC_CTYPE);
488 /* A UTF-8 locale gets standard rules. But note that code still has to
489 * handle this specially because of the three problematic code points */
490 if (PL_in_utf8_CTYPE_locale) {
491 Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
494 /* Assume enough space for every character being bad. 4 spaces each
495 * for the 94 printable characters that are output like "'x' "; and 5
496 * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
498 char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ];
500 /* Don't check for problems if we are suppressing the warnings */
501 bool check_for_problems = ckWARN_d(WARN_LOCALE)
502 || UNLIKELY(DEBUG_L_TEST);
503 bool multi_byte_locale = FALSE; /* Assume is a single-byte locale
505 unsigned int bad_count = 0; /* Count of bad characters */
507 for (i = 0; i < 256; i++) {
508 if (isUPPER_LC((U8) i))
509 PL_fold_locale[i] = (U8) toLOWER_LC((U8) i);
510 else if (isLOWER_LC((U8) i))
511 PL_fold_locale[i] = (U8) toUPPER_LC((U8) i);
513 PL_fold_locale[i] = (U8) i;
515 /* If checking for locale problems, see if the native ASCII-range
516 * printables plus \n and \t are in their expected categories in
517 * the new locale. If not, this could mean big trouble, upending
518 * Perl's and most programs' assumptions, like having a
519 * metacharacter with special meaning become a \w. Fortunately,
520 * it's very rare to find locales that aren't supersets of ASCII
521 * nowadays. It isn't a problem for most controls to be changed
522 * into something else; we check only \n and \t, though perhaps \r
523 * could be an issue as well. */
524 if ( check_for_problems
525 && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
527 if (( isALPHANUMERIC_A(i) && ! isALPHANUMERIC_LC(i))
528 || (isPUNCT_A(i) && ! isPUNCT_LC(i))
529 || (isBLANK_A(i) && ! isBLANK_LC(i))
530 || (i == '\n' && ! isCNTRL_LC(i)))
532 if (bad_count) { /* Separate multiple entries with a
534 bad_chars_list[bad_count++] = ' ';
536 bad_chars_list[bad_count++] = '\'';
538 bad_chars_list[bad_count++] = (char) i;
541 bad_chars_list[bad_count++] = '\\';
543 bad_chars_list[bad_count++] = 'n';
547 bad_chars_list[bad_count++] = 't';
550 bad_chars_list[bad_count++] = '\'';
551 bad_chars_list[bad_count] = '\0';
558 /* We only handle single-byte locales (outside of UTF-8 ones; so if
559 * this locale requires more than one byte, there are going to be
561 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
562 "%s:%d: check_for_problems=%d, MB_CUR_MAX=%d\n",
563 __FILE__, __LINE__, check_for_problems, (int) MB_CUR_MAX));
565 if (check_for_problems && MB_CUR_MAX > 1
567 /* Some platforms return MB_CUR_MAX > 1 for even the "C"
568 * locale. Just assume that the implementation for them (plus
569 * for POSIX) is correct and the > 1 value is spurious. (Since
570 * these are specially handled to never be considered UTF-8
571 * locales, as long as this is the only problem, everything
572 * should work fine */
573 && strNE(newctype, "C") && strNE(newctype, "POSIX"))
575 multi_byte_locale = TRUE;
580 if (bad_count || multi_byte_locale) {
581 PL_warn_locale = Perl_newSVpvf(aTHX_
582 "Locale '%s' may not work well.%s%s%s\n",
585 ? " Some characters in it are not recognized by"
589 ? "\nThe following characters (and maybe others)"
590 " may not have the same meaning as the Perl"
591 " program expects:\n"
597 /* If we are actually in the scope of the locale or are debugging,
598 * output the message now. If not in that scope, we save the
599 * message to be output at the first operation using this locale,
600 * if that actually happens. Most programs don't use locales, so
601 * they are immune to bad ones. */
602 if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
604 /* We have to save 'newctype' because the setlocale() just
605 * below may destroy it. The next setlocale() further down
606 * should restore it properly so that the intermediate change
607 * here is transparent to this function's caller */
608 const char * const badlocale = savepv(newctype);
610 do_setlocale_c(LC_CTYPE, "C");
612 /* The '0' below suppresses a bogus gcc compiler warning */
613 Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale), 0);
615 do_setlocale_c(LC_CTYPE, badlocale);
618 if (IN_LC(LC_CTYPE)) {
619 SvREFCNT_dec_NN(PL_warn_locale);
620 PL_warn_locale = NULL;
626 #endif /* USE_LOCALE_CTYPE */
631 Perl__warn_problematic_locale()
634 #ifdef USE_LOCALE_CTYPE
638 /* Internal-to-core function that outputs the message in PL_warn_locale,
639 * and then NULLS it. Should be called only through the macro
640 * _CHECK_AND_WARN_PROBLEMATIC_LOCALE */
642 if (PL_warn_locale) {
643 /*GCC_DIAG_IGNORE(-Wformat-security); Didn't work */
644 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
645 SvPVX(PL_warn_locale),
646 0 /* dummy to avoid compiler warning */ );
647 /* GCC_DIAG_RESTORE; */
648 SvREFCNT_dec_NN(PL_warn_locale);
649 PL_warn_locale = NULL;
657 S_new_collate(pTHX_ const char *newcoll)
660 #ifndef USE_LOCALE_COLLATE
662 PERL_UNUSED_ARG(newcoll);
667 /* Called after all libc setlocale() calls affecting LC_COLLATE, to tell
668 * core Perl this and that 'newcoll' is the name of the new locale.
670 * The design of locale collation is that every locale change is given an
671 * index 'PL_collation_ix'. The first time a string particpates in an
672 * operation that requires collation while locale collation is active, it
673 * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()). That
674 * magic includes the collation index, and the transformation of the string
675 * by strxfrm(), q.v. That transformation is used when doing comparisons,
676 * instead of the string itself. If a string changes, the magic is
677 * cleared. The next time the locale changes, the index is incremented,
678 * and so we know during a comparison that the transformation is not
679 * necessarily still valid, and so is recomputed. Note that if the locale
680 * changes enough times, the index could wrap (a U32), and it is possible
681 * that a transformation would improperly be considered valid, leading to
685 if (PL_collation_name) {
687 Safefree(PL_collation_name);
688 PL_collation_name = NULL;
690 PL_collation_standard = TRUE;
691 is_standard_collation:
692 PL_collxfrm_base = 0;
693 PL_collxfrm_mult = 2;
694 PL_in_utf8_COLLATE_locale = FALSE;
695 PL_strxfrm_NUL_replacement = '\0';
696 PL_strxfrm_max_cp = 0;
700 /* If this is not the same locale as currently, set the new one up */
701 if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
703 Safefree(PL_collation_name);
704 PL_collation_name = stdize_locale(savepv(newcoll));
705 PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
706 if (PL_collation_standard) {
707 goto is_standard_collation;
710 PL_in_utf8_COLLATE_locale = _is_cur_LC_category_utf8(LC_COLLATE);
711 PL_strxfrm_NUL_replacement = '\0';
712 PL_strxfrm_max_cp = 0;
714 /* A locale collation definition includes primary, secondary, tertiary,
715 * etc. weights for each character. To sort, the primary weights are
716 * used, and only if they compare equal, then the secondary weights are
717 * used, and only if they compare equal, then the tertiary, etc.
719 * strxfrm() works by taking the input string, say ABC, and creating an
720 * output transformed string consisting of first the primary weights,
721 * A¹B¹C¹ followed by the secondary ones, A²B²C²; and then the
722 * tertiary, etc, yielding A¹B¹C¹ A²B²C² A³B³C³ .... Some characters
723 * may not have weights at every level. In our example, let's say B
724 * doesn't have a tertiary weight, and A doesn't have a secondary
725 * weight. The constructed string is then going to be
726 * A¹B¹C¹ B²C² A³C³ ....
727 * This has the desired effect that strcmp() will look at the secondary
728 * or tertiary weights only if the strings compare equal at all higher
729 * priority weights. The spaces shown here, like in
731 * are not just for readability. In the general case, these must
732 * actually be bytes, which we will call here 'separator weights'; and
733 * they must be smaller than any other weight value, but since these
734 * are C strings, only the terminating one can be a NUL (some
735 * implementations may include a non-NUL separator weight just before
736 * the NUL). Implementations tend to reserve 01 for the separator
737 * weights. They are needed so that a shorter string's secondary
738 * weights won't be misconstrued as primary weights of a longer string,
739 * etc. By making them smaller than any other weight, the shorter
740 * string will sort first. (Actually, if all secondary weights are
741 * smaller than all primary ones, there is no need for a separator
742 * weight between those two levels, etc.)
744 * The length of the transformed string is roughly a linear function of
745 * the input string. It's not exactly linear because some characters
746 * don't have weights at all levels. When we call strxfrm() we have to
747 * allocate some memory to hold the transformed string. The
748 * calculations below try to find coefficients 'm' and 'b' for this
749 * locale so that m*x + b equals how much space we need, given the size
750 * of the input string in 'x'. If we calculate too small, we increase
751 * the size as needed, and call strxfrm() again, but it is better to
752 * get it right the first time to avoid wasted expensive string
753 * transformations. */
756 /* We use the string below to find how long the tranformation of it
757 * is. Almost all locales are supersets of ASCII, or at least the
758 * ASCII letters. We use all of them, half upper half lower,
759 * because if we used fewer, we might hit just the ones that are
760 * outliers in a particular locale. Most of the strings being
761 * collated will contain a preponderance of letters, and even if
762 * they are above-ASCII, they are likely to have the same number of
763 * weight levels as the ASCII ones. It turns out that digits tend
764 * to have fewer levels, and some punctuation has more, but those
765 * are relatively sparse in text, and khw believes this gives a
766 * reasonable result, but it could be changed if experience so
768 const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
769 char * x_longer; /* Transformed 'longer' */
770 Size_t x_len_longer; /* Length of 'x_longer' */
772 char * x_shorter; /* We also transform a substring of 'longer' */
773 Size_t x_len_shorter;
775 /* _mem_collxfrm() is used get the transformation (though here we
776 * are interested only in its length). It is used because it has
777 * the intelligence to handle all cases, but to work, it needs some
778 * values of 'm' and 'b' to get it started. For the purposes of
779 * this calculation we use a very conservative estimate of 'm' and
780 * 'b'. This assumes a weight can be multiple bytes, enough to
781 * hold any UV on the platform, and there are 5 levels, 4 weight
782 * bytes, and a trailing NUL. */
783 PL_collxfrm_base = 5;
784 PL_collxfrm_mult = 5 * sizeof(UV);
786 /* Find out how long the transformation really is */
787 x_longer = _mem_collxfrm(longer,
791 /* We avoid converting to UTF-8 in the
792 * called function by telling it the
793 * string is in UTF-8 if the locale is a
794 * UTF-8 one. Since the string passed
795 * here is invariant under UTF-8, we can
796 * claim it's UTF-8 even though it isn't.
798 PL_in_utf8_COLLATE_locale);
801 /* Find out how long the transformation of a substring of 'longer'
802 * is. Together the lengths of these transformations are
803 * sufficient to calculate 'm' and 'b'. The substring is all of
804 * 'longer' except the first character. This minimizes the chances
805 * of being swayed by outliers */
806 x_shorter = _mem_collxfrm(longer + 1,
809 PL_in_utf8_COLLATE_locale);
812 /* If the results are nonsensical for this simple test, the whole
813 * locale definition is suspect. Mark it so that locale collation
814 * is not active at all for it. XXX Should we warn? */
815 if ( x_len_shorter == 0
817 || x_len_shorter >= x_len_longer)
819 PL_collxfrm_mult = 0;
820 PL_collxfrm_base = 0;
823 SSize_t base; /* Temporary */
825 /* We have both: m * strlen(longer) + b = x_len_longer
826 * m * strlen(shorter) + b = x_len_shorter;
827 * subtracting yields:
828 * m * (strlen(longer) - strlen(shorter))
829 * = x_len_longer - x_len_shorter
830 * But we have set things up so that 'shorter' is 1 byte smaller
831 * than 'longer'. Hence:
832 * m = x_len_longer - x_len_shorter
834 * But if something went wrong, make sure the multiplier is at
837 if (x_len_longer > x_len_shorter) {
838 PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
841 PL_collxfrm_mult = 1;
846 * but in case something has gone wrong, make sure it is
848 base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
853 /* Add 1 for the trailing NUL */
854 PL_collxfrm_base = base + 1;
859 if (DEBUG_L_TEST || debug_initialization) {
860 PerlIO_printf(Perl_debug_log,
861 "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, "
863 " collate multipler=%zu, collate base=%zu\n",
865 PL_in_utf8_COLLATE_locale,
866 x_len_shorter, x_len_longer,
867 PL_collxfrm_mult, PL_collxfrm_base);
874 #endif /* USE_LOCALE_COLLATE */
881 S_win32_setlocale(pTHX_ int category, const char* locale)
883 /* This, for Windows, emulates POSIX setlocale() behavior. There is no
884 * difference between the two unless the input locale is "", which normally
885 * means on Windows to get the machine default, which is set via the
886 * computer's "Regional and Language Options" (or its current equivalent).
887 * In POSIX, it instead means to find the locale from the user's
888 * environment. This routine changes the Windows behavior to first look in
889 * the environment, and, if anything is found, use that instead of going to
890 * the machine default. If there is no environment override, the machine
891 * default is used, by calling the real setlocale() with "".
893 * The POSIX behavior is to use the LC_ALL variable if set; otherwise to
894 * use the particular category's variable if set; otherwise to use the LANG
897 bool override_LC_ALL = FALSE;
901 if (locale && strEQ(locale, "")) {
905 locale = PerlEnv_getenv("LC_ALL");
907 if (category == LC_ALL) {
908 override_LC_ALL = TRUE;
914 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
915 if (category == categories[i]) {
916 locale = PerlEnv_getenv(category_names[i]);
921 locale = PerlEnv_getenv("LANG");
937 result = setlocale(category, locale);
938 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
939 setlocale_debug_string(category, locale, result)));
941 if (! override_LC_ALL) {
945 /* Here the input category was LC_ALL, and we have set it to what is in the
946 * LANG variable or the system default if there is no LANG. But these have
947 * lower priority than the other LC_foo variables, so override it for each
948 * one that is set. (If they are set to "", it means to use the same thing
949 * we just set LC_ALL to, so can skip) */
951 for (i = 0; i < LC_ALL_INDEX; i++) {
952 result = PerlEnv_getenv(category_names[i]);
953 if (result && strNE(result, "")) {
954 setlocale(categories[i], result);
955 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
957 setlocale_debug_string(categories[i], result, "not captured")));
961 result = setlocale(LC_ALL, NULL);
962 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
964 setlocale_debug_string(LC_ALL, NULL, result)));
972 Perl_setlocale(int category, const char * locale)
974 /* This wraps POSIX::setlocale() */
980 #ifdef USE_LOCALE_NUMERIC
982 /* A NULL locale means only query what the current one is. We
983 * have the LC_NUMERIC name saved, because we are normally switched
984 * into the C locale for it. Switch back so an LC_ALL query will yield
985 * the correct results; all other categories don't require special
987 if (locale == NULL) {
988 if (category == LC_NUMERIC) {
989 return savepv(PL_numeric_name);
994 else if (category == LC_ALL) {
995 SET_NUMERIC_UNDERLYING();
1004 /* Save retval since subsequent setlocale() calls may overwrite it. */
1005 retval = savepv(do_setlocale_r(category, locale));
1007 DEBUG_L(PerlIO_printf(Perl_debug_log,
1008 "%s:%d: %s\n", __FILE__, __LINE__,
1009 setlocale_debug_string(category, locale, retval)));
1011 /* Should never happen that a query would return an error, but be
1012 * sure and reset to C locale */
1014 SET_NUMERIC_STANDARD();
1020 /* If locale == NULL, we are just querying the state, but may have switched
1021 * to NUMERIC_UNDERLYING. Switch back before returning. */
1022 if (locale == NULL) {
1023 SET_NUMERIC_STANDARD();
1027 /* Now that have switched locales, we have to update our records to
1032 #ifdef USE_LOCALE_CTYPE
1039 #ifdef USE_LOCALE_COLLATE
1042 new_collate(retval);
1046 #ifdef USE_LOCALE_NUMERIC
1049 new_numeric(retval);
1057 /* LC_ALL updates all the things we care about. The values may not
1058 * be the same as 'retval', as the locale "" may have set things
1061 # ifdef USE_LOCALE_CTYPE
1063 newlocale = do_setlocale_c(LC_CTYPE, NULL);
1064 new_ctype(newlocale);
1066 # endif /* USE_LOCALE_CTYPE */
1067 # ifdef USE_LOCALE_COLLATE
1069 newlocale = do_setlocale_c(LC_COLLATE, NULL);
1070 new_collate(newlocale);
1073 # ifdef USE_LOCALE_NUMERIC
1075 newlocale = do_setlocale_c(LC_NUMERIC, NULL);
1076 new_numeric(newlocale);
1078 # endif /* USE_LOCALE_NUMERIC */
1090 PERL_STATIC_INLINE const char *
1091 S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t offset)
1093 /* Copy the NUL-terminated 'string' to 'buf' + 'offset'. 'buf' has size 'buf_size',
1094 * growing it if necessary */
1096 const Size_t string_size = strlen(string) + offset + 1;
1098 PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
1100 if (*buf_size == 0) {
1101 Newx(*buf, string_size, char);
1102 *buf_size = string_size;
1104 else if (string_size > *buf_size) {
1105 Renew(*buf, string_size, char);
1106 *buf_size = string_size;
1109 Copy(string, *buf + offset, string_size - offset, char);
1115 =head1 Locale-related functions and macros
1117 =for apidoc Perl_langinfo
1119 This is an (almost ª) drop-in replacement for the system C<L<nl_langinfo(3)>>,
1120 taking the same C<item> parameter values, and returning the same information.
1121 But it is more thread-safe than regular C<nl_langinfo()>, and hides the quirks
1122 of Perl's locale handling from your code, and can be used on systems that lack
1123 a native C<nl_langinfo>.
1131 It delivers the correct results for the C<RADIXCHAR> and C<THOUSESEP> items,
1132 without you having to write extra code. The reason for the extra code would be
1133 because these are from the C<LC_NUMERIC> locale category, which is normally
1134 kept set to the C locale by Perl, no matter what the underlying locale is
1135 supposed to be, and so to get the expected results, you have to temporarily
1136 toggle into the underlying locale, and later toggle back. (You could use
1137 plain C<nl_langinfo> and C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this
1138 but then you wouldn't get the other advantages of C<Perl_langinfo()>; not
1139 keeping C<LC_NUMERIC> in the C locale would break a lot of CPAN, which is
1140 expecting the radix (decimal point) character to be a dot.)
1144 Depending on C<item>, it works on systems that don't have C<nl_langinfo>, hence
1145 makes your code more portable. Of the fifty-some possible items specified by
1146 the POSIX 2008 standard,
1147 L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
1148 only two are completely unimplemented. It uses various techniques to recover
1149 the other items, including calling C<L<localeconv(3)>>, and C<L<strftime(3)>>,
1150 both of which are specified in C89, so should be always be available. Later
1151 C<strftime()> versions have additional capabilities; C<""> is returned for
1152 those not available on your system.
1154 The details for those items which may differ from what this emulation returns
1155 and what a native C<nl_langinfo()> would return are:
1163 Unimplemented, so returns C<"">.
1169 Only the values for English are returned. Earlier POSIX standards also
1170 specified C<YESSTR> and C<NOSTR>, but these have been removed from POSIX 2008,
1171 and aren't supported by C<Perl_langinfo>.
1175 Always evaluates to C<%x>, the locale's appropriate date representation.
1179 Always evaluates to C<%X>, the locale's appropriate time representation.
1183 Always evaluates to C<%c>, the locale's appropriate date and time
1188 The return may be incorrect for those rare locales where the currency symbol
1189 replaces the radix character.
1190 Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
1191 to work differently.
1195 Currently this gives the same results as Linux does.
1196 Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
1197 to work differently.
1203 =item C<ERA_D_T_FMT>
1207 These are derived by using C<strftime()>, and not all versions of that function
1208 know about them. C<""> is returned for these on such systems.
1212 When using C<Perl_langinfo> on systems that don't have a native
1213 C<nl_langinfo()>, you must
1215 #include "perl_langinfo.h"
1217 before the C<perl.h> C<#include>. You can replace your C<langinfo.h>
1218 C<#include> with this one. (Doing it this way keeps out the symbols that plain
1219 C<langinfo.h> imports into the namespace for code that doesn't need it.)
1221 You also should not use the bare C<langinfo.h> item names, but should preface
1222 them with C<PERL_>, so use C<PERL_RADIXCHAR> instead of plain C<RADIXCHAR>.
1223 The C<PERL_I<foo>> versions will also work for this function on systems that do
1224 have a native C<nl_langinfo>.
1228 It is thread-friendly, returning its result in a buffer that won't be
1229 overwritten by another thread, so you don't have to code for that possibility.
1230 The buffer can be overwritten by the next call to C<nl_langinfo> or
1231 C<Perl_langinfo> in the same thread.
1235 ª It returns S<C<const char *>>, whereas plain C<nl_langinfo()> returns S<C<char
1236 *>>, but you are (only by documentation) forbidden to write into the buffer.
1237 By declaring this C<const>, the compiler enforces this restriction. The extra
1238 C<const> is why this isn't an unequivocal drop-in replacement for
1243 The original impetus for C<Perl_langinfo()> was so that code that needs to
1244 find out the current currency symbol, floating point radix character, or digit
1245 grouping separator can use, on all systems, the simpler and more
1246 thread-friendly C<nl_langinfo> API instead of C<L<localeconv(3)>> which is a
1247 pain to make thread-friendly. For other fields returned by C<localeconv>, it
1248 is better to use the methods given in L<perlcall> to call
1249 L<C<POSIX::localeconv()>|POSIX/localeconv>, which is thread-friendly.
1256 #ifdef HAS_NL_LANGINFO
1257 Perl_langinfo(const nl_item item)
1259 Perl_langinfo(const int item)
1262 return my_nl_langinfo(item, TRUE);
1266 #ifdef HAS_NL_LANGINFO
1267 S_my_nl_langinfo(const nl_item item, bool toggle)
1269 S_my_nl_langinfo(const int item, bool toggle)
1274 #if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
1275 #if ! defined(HAS_POSIX_2008_LOCALE)
1277 /* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
1278 * for those items dependent on it. This must be copied to a buffer before
1279 * switching back, as some systems destroy the buffer when setlocale() is
1285 if (item == PERL_RADIXCHAR || item == PERL_THOUSEP) {
1286 do_setlocale_c(LC_NUMERIC, PL_numeric_name);
1293 save_to_buffer(nl_langinfo(item), &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
1296 do_setlocale_c(LC_NUMERIC, "C");
1301 return PL_langinfo_buf;
1303 # else /* Use nl_langinfo_l(), avoiding both a mutex and changing the locale */
1305 bool do_free = FALSE;
1306 locale_t cur = uselocale((locale_t) 0);
1308 if (cur == LC_GLOBAL_LOCALE) {
1309 cur = duplocale(LC_GLOBAL_LOCALE);
1314 && (item == PERL_RADIXCHAR || item == PERL_THOUSEP))
1316 cur = newlocale(LC_NUMERIC_MASK, PL_numeric_name, cur);
1320 save_to_buffer(nl_langinfo_l(item, cur),
1321 &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
1326 return PL_langinfo_buf;
1329 #else /* Below, emulate nl_langinfo as best we can */
1330 # ifdef HAS_LOCALECONV
1332 const struct lconv* lc;
1335 # ifdef HAS_STRFTIME
1338 bool return_format = FALSE; /* Return the %format, not the value */
1339 const char * format;
1343 /* We copy the results to a per-thread buffer, even if not multi-threaded.
1344 * This is in part to simplify this code, and partly because we need a
1345 * buffer anyway for strftime(), and partly because a call of localeconv()
1346 * could otherwise wipe out the buffer, and the programmer would not be
1347 * expecting this, as this is a nl_langinfo() substitute after all, so s/he
1348 * might be thinking their localeconv() is safe until another localeconv()
1353 const char * retval;
1355 /* These 2 are unimplemented */
1357 case PERL_ERA: /* For use with strftime() %E modifier */
1362 /* We use only an English set, since we don't know any more */
1363 case PERL_YESEXPR: return "^[+1yY]";
1364 case PERL_NOEXPR: return "^[-0nN]";
1366 # ifdef HAS_LOCALECONV
1373 if (! lc || ! lc->currency_symbol || strEQ("", lc->currency_symbol))
1379 /* Leave the first spot empty to be filled in below */
1380 save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
1381 &PL_langinfo_bufsize, 1);
1382 if (lc->mon_decimal_point && strEQ(lc->mon_decimal_point, ""))
1383 { /* khw couldn't figure out how the localedef specifications
1384 would show that the $ should replace the radix; this is
1385 just a guess as to how it might work.*/
1386 *PL_langinfo_buf = '.';
1388 else if (lc->p_cs_precedes) {
1389 *PL_langinfo_buf = '-';
1392 *PL_langinfo_buf = '+';
1398 case PERL_RADIXCHAR:
1404 do_setlocale_c(LC_NUMERIC, PL_numeric_name);
1412 retval = (item == PERL_RADIXCHAR)
1414 : lc->thousands_sep;
1420 save_to_buffer(retval, &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
1423 do_setlocale_c(LC_NUMERIC, "C");
1431 # ifdef HAS_STRFTIME
1433 /* These are defined by C89, so we assume that strftime supports them,
1434 * and so are returned unconditionally; they may not be what the locale
1435 * actually says, but should give good enough results for someone using
1436 * them as formats (as opposed to trying to parse them to figure out
1437 * what the locale says). The other format items are actually tested to
1438 * verify they work on the platform */
1439 case PERL_D_FMT: return "%x";
1440 case PERL_T_FMT: return "%X";
1441 case PERL_D_T_FMT: return "%c";
1443 /* These formats are only available in later strfmtime's */
1444 case PERL_ERA_D_FMT: case PERL_ERA_T_FMT: case PERL_ERA_D_T_FMT:
1445 case PERL_T_FMT_AMPM:
1447 /* The rest can be gotten from most versions of strftime(). */
1448 case PERL_ABDAY_1: case PERL_ABDAY_2: case PERL_ABDAY_3:
1449 case PERL_ABDAY_4: case PERL_ABDAY_5: case PERL_ABDAY_6:
1451 case PERL_ALT_DIGITS:
1452 case PERL_AM_STR: case PERL_PM_STR:
1453 case PERL_ABMON_1: case PERL_ABMON_2: case PERL_ABMON_3:
1454 case PERL_ABMON_4: case PERL_ABMON_5: case PERL_ABMON_6:
1455 case PERL_ABMON_7: case PERL_ABMON_8: case PERL_ABMON_9:
1456 case PERL_ABMON_10: case PERL_ABMON_11: case PERL_ABMON_12:
1457 case PERL_DAY_1: case PERL_DAY_2: case PERL_DAY_3: case PERL_DAY_4:
1458 case PERL_DAY_5: case PERL_DAY_6: case PERL_DAY_7:
1459 case PERL_MON_1: case PERL_MON_2: case PERL_MON_3: case PERL_MON_4:
1460 case PERL_MON_5: case PERL_MON_6: case PERL_MON_7: case PERL_MON_8:
1461 case PERL_MON_9: case PERL_MON_10: case PERL_MON_11: case PERL_MON_12:
1465 init_tm(&tm); /* Precaution against core dumps */
1469 tm.tm_year = 2017 - 1900;
1475 Perl_croak(aTHX_ "panic: %s: %d: switch case: %d problem",
1476 __FILE__, __LINE__, item);
1477 NOT_REACHED; /* NOTREACHED */
1479 case PERL_PM_STR: tm.tm_hour = 18;
1484 case PERL_ABDAY_7: tm.tm_wday++;
1485 case PERL_ABDAY_6: tm.tm_wday++;
1486 case PERL_ABDAY_5: tm.tm_wday++;
1487 case PERL_ABDAY_4: tm.tm_wday++;
1488 case PERL_ABDAY_3: tm.tm_wday++;
1489 case PERL_ABDAY_2: tm.tm_wday++;
1494 case PERL_DAY_7: tm.tm_wday++;
1495 case PERL_DAY_6: tm.tm_wday++;
1496 case PERL_DAY_5: tm.tm_wday++;
1497 case PERL_DAY_4: tm.tm_wday++;
1498 case PERL_DAY_3: tm.tm_wday++;
1499 case PERL_DAY_2: tm.tm_wday++;
1504 case PERL_ABMON_12: tm.tm_mon++;
1505 case PERL_ABMON_11: tm.tm_mon++;
1506 case PERL_ABMON_10: tm.tm_mon++;
1507 case PERL_ABMON_9: tm.tm_mon++;
1508 case PERL_ABMON_8: tm.tm_mon++;
1509 case PERL_ABMON_7: tm.tm_mon++;
1510 case PERL_ABMON_6: tm.tm_mon++;
1511 case PERL_ABMON_5: tm.tm_mon++;
1512 case PERL_ABMON_4: tm.tm_mon++;
1513 case PERL_ABMON_3: tm.tm_mon++;
1514 case PERL_ABMON_2: tm.tm_mon++;
1519 case PERL_MON_12: tm.tm_mon++;
1520 case PERL_MON_11: tm.tm_mon++;
1521 case PERL_MON_10: tm.tm_mon++;
1522 case PERL_MON_9: tm.tm_mon++;
1523 case PERL_MON_8: tm.tm_mon++;
1524 case PERL_MON_7: tm.tm_mon++;
1525 case PERL_MON_6: tm.tm_mon++;
1526 case PERL_MON_5: tm.tm_mon++;
1527 case PERL_MON_4: tm.tm_mon++;
1528 case PERL_MON_3: tm.tm_mon++;
1529 case PERL_MON_2: tm.tm_mon++;
1534 case PERL_T_FMT_AMPM:
1536 return_format = TRUE;
1539 case PERL_ERA_D_FMT:
1541 return_format = TRUE;
1544 case PERL_ERA_T_FMT:
1546 return_format = TRUE;
1549 case PERL_ERA_D_T_FMT:
1551 return_format = TRUE;
1554 case PERL_ALT_DIGITS:
1556 format = "%Ow"; /* Find the alternate digit for 0 */
1560 /* We can't use my_strftime() because it doesn't look at tm_wday */
1561 while (0 == strftime(PL_langinfo_buf, PL_langinfo_bufsize,
1564 /* A zero return means one of:
1565 * a) there wasn't enough space in PL_langinfo_buf
1566 * b) the format, like a plain %p, returns empty
1567 * c) it was an illegal format, though some implementations of
1568 * strftime will just return the illegal format as a plain
1569 * character sequence.
1571 * To quickly test for case 'b)', try again but precede the
1572 * format with a plain character. If that result is still
1573 * empty, the problem is either 'a)' or 'c)' */
1575 Size_t format_size = strlen(format) + 1;
1576 Size_t mod_size = format_size + 1;
1580 Newx(mod_format, mod_size, char);
1581 Newx(temp_result, PL_langinfo_bufsize, char);
1583 my_strlcpy(mod_format + 1, format, mod_size);
1584 len = strftime(temp_result,
1585 PL_langinfo_bufsize,
1587 Safefree(mod_format);
1588 Safefree(temp_result);
1590 /* If 'len' is non-zero, it means that we had a case like %p
1591 * which means the current locale doesn't use a.m. or p.m., and
1595 /* Here, still didn't work. If we get well beyond a
1596 * reasonable size, bail out to prevent an infinite loop. */
1598 if (PL_langinfo_bufsize > 100 * format_size) {
1599 *PL_langinfo_buf = '\0';
1601 else { /* Double the buffer size to retry; Add 1 in case
1602 original was 0, so we aren't stuck at 0. */
1603 PL_langinfo_bufsize *= 2;
1604 PL_langinfo_bufsize++;
1605 Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
1613 /* Here, we got a result.
1615 * If the item is 'ALT_DIGITS', PL_langinfo_buf contains the
1616 * alternate format for wday 0. If the value is the same as the
1617 * normal 0, there isn't an alternate, so clear the buffer. */
1618 if ( item == PERL_ALT_DIGITS
1619 && strEQ(PL_langinfo_buf, "0"))
1621 *PL_langinfo_buf = '\0';
1624 /* ALT_DIGITS is problematic. Experiments on it showed that
1625 * strftime() did not always work properly when going from alt-9 to
1626 * alt-10. Only a few locales have this item defined, and in all
1627 * of them on Linux that khw was able to find, nl_langinfo() merely
1628 * returned the alt-0 character, possibly doubled. Most Unicode
1629 * digits are in blocks of 10 consecutive code points, so that is
1630 * sufficient information for those scripts, as we can infer alt-1,
1631 * alt-2, .... But for a Japanese locale, a CJK ideographic 0 is
1632 * returned, and the CJK digits are not in code point order, so you
1633 * can't really infer anything. The localedef for this locale did
1634 * specify the succeeding digits, so that strftime() works properly
1635 * on them, without needing to infer anything. But the
1636 * nl_langinfo() return did not give sufficient information for the
1637 * caller to understand what's going on. So until there is
1638 * evidence that it should work differently, this returns the alt-0
1639 * string for ALT_DIGITS.
1641 * wday was chosen because its range is all a single digit. Things
1642 * like tm_sec have two digits as the minimum: '00' */
1646 /* If to return the format, not the value, overwrite the buffer
1647 * with it. But some strftime()s will keep the original format if
1648 * illegal, so change those to "" */
1649 if (return_format) {
1650 if (strEQ(PL_langinfo_buf, format)) {
1651 *PL_langinfo_buf = '\0';
1654 save_to_buffer(format, &PL_langinfo_buf,
1655 &PL_langinfo_bufsize, 0);
1665 return PL_langinfo_buf;
1672 * Initialize locale awareness.
1675 Perl_init_i18nl10n(pTHX_ int printwarn)
1679 * 0 if not to output warning when setup locale is bad
1680 * 1 if to output warning based on value of PERL_BADLANG
1681 * >1 if to output regardless of PERL_BADLANG
1684 * 1 = set ok or not applicable,
1685 * 0 = fallback to a locale of lower priority
1686 * -1 = fallback to all locales failed, not even to the C locale
1688 * Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
1689 * set, debugging information is output.
1691 * This looks more complicated than it is, mainly due to the #ifdefs.
1693 * We try to set LC_ALL to the value determined by the environment. If
1694 * there is no LC_ALL on this platform, we try the individual categories we
1695 * know about. If this works, we are done.
1697 * But if it doesn't work, we have to do something else. We search the
1698 * environment variables ourselves instead of relying on the system to do
1699 * it. We look at, in order, LC_ALL, LANG, a system default locale (if we
1700 * think there is one), and the ultimate fallback "C". This is all done in
1701 * the same loop as above to avoid duplicating code, but it makes things
1702 * more complex. The 'trial_locales' array is initialized with just one
1703 * element; it causes the behavior described in the paragraph above this to
1704 * happen. If that fails, we add elements to 'trial_locales', and do extra
1705 * loop iterations to cause the behavior described in this paragraph.
1707 * On Ultrix, the locale MUST come from the environment, so there is
1708 * preliminary code to set it. I (khw) am not sure that it is necessary,
1709 * and that this couldn't be folded into the loop, but barring any real
1710 * platforms to test on, it's staying as-is
1712 * A slight complication is that in embedded Perls, the locale may already
1713 * be set-up, and we don't want to get it from the normal environment
1714 * variables. This is handled by having a special environment variable
1715 * indicate we're in this situation. We simply set setlocale's 2nd
1716 * parameter to be a NULL instead of "". That indicates to setlocale that
1717 * it is not to change anything, but to return the current value,
1718 * effectively initializing perl's db to what the locale already is.
1720 * We play the same trick with NULL if a LC_ALL succeeds. We call
1721 * setlocale() on the individual categores with NULL to get their existing
1722 * values for our db, instead of trying to change them.
1729 PERL_UNUSED_ARG(printwarn);
1731 #else /* USE_LOCALE */
1734 const char * const language = savepv(PerlEnv_getenv("LANGUAGE"));
1738 /* NULL uses the existing already set up locale */
1739 const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
1742 const char* trial_locales[5]; /* 5 = 1 each for "", LC_ALL, LANG, "", C */
1743 unsigned int trial_locales_count;
1744 const char * const lc_all = savepv(PerlEnv_getenv("LC_ALL"));
1745 const char * const lang = savepv(PerlEnv_getenv("LANG"));
1746 bool setlocale_failure = FALSE;
1749 /* A later getenv() could zap this, so only use here */
1750 const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
1752 const bool locwarn = (printwarn > 1
1754 && ( ! bad_lang_use_once
1756 /* disallow with "" or "0" */
1758 && strNE("0", bad_lang_use_once)))));
1760 char * sl_result[NOMINAL_LC_ALL_INDEX + 1]; /* setlocale() return vals;
1761 not copied so must be
1762 looked at immediately */
1763 char * curlocales[NOMINAL_LC_ALL_INDEX + 1]; /* current locale for given
1764 category; should have been
1765 copied so aren't volatile
1767 char * locale_param;
1771 /* In some systems you can find out the system default locale
1772 * and use that as the fallback locale. */
1773 # define SYSTEM_DEFAULT_LOCALE
1775 # ifdef SYSTEM_DEFAULT_LOCALE
1777 const char *system_default_locale = NULL;
1782 # define DEBUG_LOCALE_INIT(a,b,c)
1785 DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
1787 # define DEBUG_LOCALE_INIT(category, locale, result) \
1789 if (debug_initialization) { \
1790 PerlIO_printf(Perl_debug_log, \
1792 __FILE__, __LINE__, \
1793 setlocale_debug_string(category, \
1799 /* Make sure the parallel arrays are properly set up */
1800 # ifdef USE_LOCALE_NUMERIC
1801 assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
1802 assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
1804 # ifdef USE_LOCALE_CTYPE
1805 assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
1806 assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
1808 # ifdef USE_LOCALE_COLLATE
1809 assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
1810 assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
1812 # ifdef USE_LOCALE_TIME
1813 assert(categories[LC_TIME_INDEX] == LC_TIME);
1814 assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
1816 # ifdef USE_LOCALE_MESSAGES
1817 assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
1818 assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
1820 # ifdef USE_LOCALE_MONETARY
1821 assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
1822 assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
1825 assert(categories[LC_ALL_INDEX] == LC_ALL);
1826 assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
1827 assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
1829 # endif /* DEBUGGING */
1830 # ifndef LOCALE_ENVIRON_REQUIRED
1832 PERL_UNUSED_VAR(done);
1833 PERL_UNUSED_VAR(locale_param);
1838 * Ultrix setlocale(..., "") fails if there are no environment
1839 * variables from which to get a locale name.
1845 sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, setlocale_init);
1846 DEBUG_LOCALE_INIT(LC_ALL, setlocale_init, sl_result[LC_ALL_INDEX]);
1847 if (sl_result[LC_ALL_INDEX])
1850 setlocale_failure = TRUE;
1852 if (! setlocale_failure) {
1853 for (i = 0; i < LC_ALL_INDEX; i++) {
1854 locale_param = (! done && (lang || PerlEnv_getenv(category_names[i])))
1857 sl_result[i] = do_setlocale_r(categories[i], locale_param);
1858 if (! sl_result[i]) {
1859 setlocale_failure = TRUE;
1861 DEBUG_LOCALE_INIT(categories[i], locale_param, sl_result[i]);
1865 # endif /* LC_ALL */
1866 # endif /* LOCALE_ENVIRON_REQUIRED */
1868 /* We try each locale in the list until we get one that works, or exhaust
1869 * the list. Normally the loop is executed just once. But if setting the
1870 * locale fails, inside the loop we add fallback trials to the array and so
1871 * will execute the loop multiple times */
1872 trial_locales[0] = setlocale_init;
1873 trial_locales_count = 1;
1875 for (i= 0; i < trial_locales_count; i++) {
1876 const char * trial_locale = trial_locales[i];
1880 /* XXX This is to preserve old behavior for LOCALE_ENVIRON_REQUIRED
1881 * when i==0, but I (khw) don't think that behavior makes much
1883 setlocale_failure = FALSE;
1885 # ifdef SYSTEM_DEFAULT_LOCALE
1888 /* On Windows machines, an entry of "" after the 0th means to use
1889 * the system default locale, which we now proceed to get. */
1890 if (strEQ(trial_locale, "")) {
1893 /* Note that this may change the locale, but we are going to do
1894 * that anyway just below */
1895 system_default_locale = do_setlocale_c(LC_ALL, "");
1896 DEBUG_LOCALE_INIT(LC_ALL, "", system_default_locale);
1898 /* Skip if invalid or if it's already on the list of locales to
1900 if (! system_default_locale) {
1901 goto next_iteration;
1903 for (j = 0; j < trial_locales_count; j++) {
1904 if (strEQ(system_default_locale, trial_locales[j])) {
1905 goto next_iteration;
1909 trial_locale = system_default_locale;
1912 # endif /* SYSTEM_DEFAULT_LOCALE */
1917 sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, trial_locale);
1918 DEBUG_LOCALE_INIT(LC_ALL, trial_locale, sl_result[LC_ALL_INDEX]);
1919 if (! sl_result[LC_ALL_INDEX]) {
1920 setlocale_failure = TRUE;
1923 /* Since LC_ALL succeeded, it should have changed all the other
1924 * categories it can to its value; so we massage things so that the
1925 * setlocales below just return their category's current values.
1926 * This adequately handles the case in NetBSD where LC_COLLATE may
1927 * not be defined for a locale, and setting it individually will
1928 * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to
1929 * the POSIX locale. */
1930 trial_locale = NULL;
1933 # endif /* LC_ALL */
1935 if (! setlocale_failure) {
1937 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
1939 = savepv(do_setlocale_r(categories[j], trial_locale));
1940 if (! curlocales[j]) {
1941 setlocale_failure = TRUE;
1943 DEBUG_LOCALE_INIT(categories[j], trial_locale, curlocales[j]);
1946 if (! setlocale_failure) { /* All succeeded */
1947 break; /* Exit trial_locales loop */
1951 /* Here, something failed; will need to try a fallback. */
1957 if (locwarn) { /* Output failure info only on the first one */
1961 PerlIO_printf(Perl_error_log,
1962 "perl: warning: Setting locale failed.\n");
1964 # else /* !LC_ALL */
1966 PerlIO_printf(Perl_error_log,
1967 "perl: warning: Setting locale failed for the categories:\n\t");
1969 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
1970 if (! curlocales[j]) {
1971 PerlIO_printf(Perl_error_log, category_names[j]);
1974 Safefree(curlocales[j]);
1978 PerlIO_printf(Perl_error_log, "and possibly others\n");
1980 # endif /* LC_ALL */
1982 PerlIO_printf(Perl_error_log,
1983 "perl: warning: Please check that your locale settings:\n");
1987 PerlIO_printf(Perl_error_log,
1988 "\tLANGUAGE = %c%s%c,\n",
1989 language ? '"' : '(',
1990 language ? language : "unset",
1991 language ? '"' : ')');
1994 PerlIO_printf(Perl_error_log,
1995 "\tLC_ALL = %c%s%c,\n",
1997 lc_all ? lc_all : "unset",
1998 lc_all ? '"' : ')');
2000 # if defined(USE_ENVIRON_ARRAY)
2005 /* Look through the environment for any variables of the
2006 * form qr/ ^ LC_ [A-Z]+ = /x, except LC_ALL which was
2007 * already handled above. These are assumed to be locale
2008 * settings. Output them and their values. */
2009 for (e = environ; *e; e++) {
2010 const STRLEN prefix_len = sizeof("LC_") - 1;
2013 if ( strBEGINs(*e, "LC_")
2014 && ! strBEGINs(*e, "LC_ALL=")
2015 && (uppers_len = strspn(*e + prefix_len,
2016 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
2017 && ((*e)[prefix_len + uppers_len] == '='))
2019 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
2020 (int) (prefix_len + uppers_len), *e,
2021 *e + prefix_len + uppers_len + 1);
2028 PerlIO_printf(Perl_error_log,
2029 "\t(possibly more locale environment variables)\n");
2033 PerlIO_printf(Perl_error_log,
2034 "\tLANG = %c%s%c\n",
2036 lang ? lang : "unset",
2039 PerlIO_printf(Perl_error_log,
2040 " are supported and installed on your system.\n");
2043 /* Calculate what fallback locales to try. We have avoided this
2044 * until we have to, because failure is quite unlikely. This will
2045 * usually change the upper bound of the loop we are in.
2047 * Since the system's default way of setting the locale has not
2048 * found one that works, We use Perl's defined ordering: LC_ALL,
2049 * LANG, and the C locale. We don't try the same locale twice, so
2050 * don't add to the list if already there. (On POSIX systems, the
2051 * LC_ALL element will likely be a repeat of the 0th element "",
2052 * but there's no harm done by doing it explicitly.
2054 * Note that this tries the LC_ALL environment variable even on
2055 * systems which have no LC_ALL locale setting. This may or may
2056 * not have been originally intentional, but there's no real need
2057 * to change the behavior. */
2059 for (j = 0; j < trial_locales_count; j++) {
2060 if (strEQ(lc_all, trial_locales[j])) {
2064 trial_locales[trial_locales_count++] = lc_all;
2069 for (j = 0; j < trial_locales_count; j++) {
2070 if (strEQ(lang, trial_locales[j])) {
2074 trial_locales[trial_locales_count++] = lang;
2078 # if defined(WIN32) && defined(LC_ALL)
2080 /* For Windows, we also try the system default locale before "C".
2081 * (If there exists a Windows without LC_ALL we skip this because
2082 * it gets too complicated. For those, the "C" is the next
2083 * fallback possibility). The "" is the same as the 0th element of
2084 * the array, but the code at the loop above knows to treat it
2085 * differently when not the 0th */
2086 trial_locales[trial_locales_count++] = "";
2090 for (j = 0; j < trial_locales_count; j++) {
2091 if (strEQ("C", trial_locales[j])) {
2095 trial_locales[trial_locales_count++] = "C";
2098 } /* end of first time through the loop */
2106 } /* end of looping through the trial locales */
2108 if (ok < 1) { /* If we tried to fallback */
2110 if (! setlocale_failure) { /* fallback succeeded */
2111 msg = "Falling back to";
2113 else { /* fallback failed */
2116 /* We dropped off the end of the loop, so have to decrement i to
2117 * get back to the value the last time through */
2121 msg = "Failed to fall back to";
2123 /* To continue, we should use whatever values we've got */
2125 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2126 Safefree(curlocales[j]);
2127 curlocales[j] = savepv(do_setlocale_r(categories[j], NULL));
2128 DEBUG_LOCALE_INIT(categories[j], NULL, curlocales[j]);
2133 const char * description;
2134 const char * name = "";
2135 if (strEQ(trial_locales[i], "C")) {
2136 description = "the standard locale";
2140 # ifdef SYSTEM_DEFAULT_LOCALE
2142 else if (strEQ(trial_locales[i], "")) {
2143 description = "the system default locale";
2144 if (system_default_locale) {
2145 name = system_default_locale;
2149 # endif /* SYSTEM_DEFAULT_LOCALE */
2152 description = "a fallback locale";
2153 name = trial_locales[i];
2155 if (name && strNE(name, "")) {
2156 PerlIO_printf(Perl_error_log,
2157 "perl: warning: %s %s (\"%s\").\n", msg, description, name);
2160 PerlIO_printf(Perl_error_log,
2161 "perl: warning: %s %s.\n", msg, description);
2164 } /* End of tried to fallback */
2166 /* Done with finding the locales; update our records */
2168 # ifdef USE_LOCALE_CTYPE
2170 new_ctype(curlocales[LC_CTYPE_INDEX]);
2173 # ifdef USE_LOCALE_COLLATE
2175 new_collate(curlocales[LC_COLLATE_INDEX]);
2178 # ifdef USE_LOCALE_NUMERIC
2180 new_numeric(curlocales[LC_NUMERIC_INDEX]);
2185 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
2186 Safefree(curlocales[i]);
2189 # if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
2191 /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
2192 * locale is UTF-8. If PL_utf8locale and PL_unicode (set by -C or by
2193 * $ENV{PERL_UNICODE}) are true, perl.c:S_parse_body() will turn on the
2194 * PerlIO :utf8 layer on STDIN, STDOUT, STDERR, _and_ the default open
2196 PL_utf8locale = _is_cur_LC_category_utf8(LC_CTYPE);
2198 /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
2199 This is an alternative to using the -C command line switch
2200 (the -C if present will override this). */
2202 const char *p = PerlEnv_getenv("PERL_UNICODE");
2203 PL_unicode = p ? parse_unicode_opts(&p) : 0;
2204 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
2218 #endif /* USE_LOCALE */
2221 /* So won't continue to output stuff */
2222 DEBUG_INITIALIZATION_set(FALSE);
2229 #ifdef USE_LOCALE_COLLATE
2232 Perl__mem_collxfrm(pTHX_ const char *input_string,
2233 STRLEN len, /* Length of 'input_string' */
2234 STRLEN *xlen, /* Set to length of returned string
2235 (not including the collation index
2237 bool utf8 /* Is the input in UTF-8? */
2241 /* _mem_collxfrm() is a bit like strxfrm() but with two important
2242 * differences. First, it handles embedded NULs. Second, it allocates a bit
2243 * more memory than needed for the transformed data itself. The real
2244 * transformed data begins at offset COLLXFRM_HDR_LEN. *xlen is set to
2245 * the length of that, and doesn't include the collation index size.
2246 * Please see sv_collxfrm() to see how this is used. */
2248 #define COLLXFRM_HDR_LEN sizeof(PL_collation_ix)
2250 char * s = (char *) input_string;
2251 STRLEN s_strlen = strlen(input_string);
2253 STRLEN xAlloc; /* xalloc is a reserved word in VC */
2254 STRLEN length_in_chars;
2255 bool first_time = TRUE; /* Cleared after first loop iteration */
2257 PERL_ARGS_ASSERT__MEM_COLLXFRM;
2259 /* Must be NUL-terminated */
2260 assert(*(input_string + len) == '\0');
2262 /* If this locale has defective collation, skip */
2263 if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
2264 DEBUG_L(PerlIO_printf(Perl_debug_log,
2265 "_mem_collxfrm: locale's collation is defective\n"));
2269 /* Replace any embedded NULs with the control that sorts before any others.
2270 * This will give as good as possible results on strings that don't
2271 * otherwise contain that character, but otherwise there may be
2272 * less-than-perfect results with that character and NUL. This is
2273 * unavoidable unless we replace strxfrm with our own implementation. */
2274 if (UNLIKELY(s_strlen < len)) { /* Only execute if there is an embedded
2278 STRLEN sans_nuls_len;
2279 int try_non_controls;
2280 char this_replacement_char[] = "?\0"; /* Room for a two-byte string,
2281 making sure 2nd byte is NUL.
2283 STRLEN this_replacement_len;
2285 /* If we don't know what non-NUL control character sorts lowest for
2286 * this locale, find it */
2287 if (PL_strxfrm_NUL_replacement == '\0') {
2289 char * cur_min_x = NULL; /* The min_char's xfrm, (except it also
2290 includes the collation index
2293 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
2295 /* Unlikely, but it may be that no control will work to replace
2296 * NUL, in which case we instead look for any character. Controls
2297 * are preferred because collation order is, in general, context
2298 * sensitive, with adjoining characters affecting the order, and
2299 * controls are less likely to have such interactions, allowing the
2300 * NUL-replacement to stand on its own. (Another way to look at it
2301 * is to imagine what would happen if the NUL were replaced by a
2302 * combining character; it wouldn't work out all that well.) */
2303 for (try_non_controls = 0;
2304 try_non_controls < 2;
2307 /* Look through all legal code points (NUL isn't) */
2308 for (j = 1; j < 256; j++) {
2309 char * x; /* j's xfrm plus collation index */
2310 STRLEN x_len; /* length of 'x' */
2311 STRLEN trial_len = 1;
2312 char cur_source[] = { '\0', '\0' };
2314 /* Skip non-controls the first time through the loop. The
2315 * controls in a UTF-8 locale are the L1 ones */
2316 if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
2323 /* Create a 1-char string of the current code point */
2324 cur_source[0] = (char) j;
2326 /* Then transform it */
2327 x = _mem_collxfrm(cur_source, trial_len, &x_len,
2328 0 /* The string is not in UTF-8 */);
2330 /* Ignore any character that didn't successfully transform.
2336 /* If this character's transformation is lower than
2337 * the current lowest, this one becomes the lowest */
2338 if ( cur_min_x == NULL
2339 || strLT(x + COLLXFRM_HDR_LEN,
2340 cur_min_x + COLLXFRM_HDR_LEN))
2342 PL_strxfrm_NUL_replacement = j;
2348 } /* end of loop through all 255 characters */
2350 /* Stop looking if found */
2355 /* Unlikely, but possible, if there aren't any controls that
2356 * work in the locale, repeat the loop, looking for any
2357 * character that works */
2358 DEBUG_L(PerlIO_printf(Perl_debug_log,
2359 "_mem_collxfrm: No control worked. Trying non-controls\n"));
2360 } /* End of loop to try first the controls, then any char */
2363 DEBUG_L(PerlIO_printf(Perl_debug_log,
2364 "_mem_collxfrm: Couldn't find any character to replace"
2365 " embedded NULs in locale %s with", PL_collation_name));
2369 DEBUG_L(PerlIO_printf(Perl_debug_log,
2370 "_mem_collxfrm: Replacing embedded NULs in locale %s with "
2371 "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
2373 Safefree(cur_min_x);
2374 } /* End of determining the character that is to replace NULs */
2376 /* If the replacement is variant under UTF-8, it must match the
2377 * UTF8-ness as the original */
2378 if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
2379 this_replacement_char[0] =
2380 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
2381 this_replacement_char[1] =
2382 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
2383 this_replacement_len = 2;
2386 this_replacement_char[0] = PL_strxfrm_NUL_replacement;
2387 /* this_replacement_char[1] = '\0' was done at initialization */
2388 this_replacement_len = 1;
2391 /* The worst case length for the replaced string would be if every
2392 * character in it is NUL. Multiply that by the length of each
2393 * replacement, and allow for a trailing NUL */
2394 sans_nuls_len = (len * this_replacement_len) + 1;
2395 Newx(sans_nuls, sans_nuls_len, char);
2398 /* Replace each NUL with the lowest collating control. Loop until have
2399 * exhausted all the NULs */
2400 while (s + s_strlen < e) {
2401 my_strlcat(sans_nuls, s, sans_nuls_len);
2403 /* Do the actual replacement */
2404 my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
2406 /* Move past the input NUL */
2408 s_strlen = strlen(s);
2411 /* And add anything that trails the final NUL */
2412 my_strlcat(sans_nuls, s, sans_nuls_len);
2414 /* Switch so below we transform this modified string */
2417 } /* End of replacing NULs */
2419 /* Make sure the UTF8ness of the string and locale match */
2420 if (utf8 != PL_in_utf8_COLLATE_locale) {
2421 const char * const t = s; /* Temporary so we can later find where the
2424 /* Here they don't match. Change the string's to be what the locale is
2427 if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
2428 s = (char *) bytes_to_utf8((const U8 *) s, &len);
2431 else { /* locale is not UTF-8; but input is; downgrade the input */
2433 s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
2435 /* If the downgrade was successful we are done, but if the input
2436 * contains things that require UTF-8 to represent, have to do
2437 * damage control ... */
2438 if (UNLIKELY(utf8)) {
2440 /* What we do is construct a non-UTF-8 string with
2441 * 1) the characters representable by a single byte converted
2442 * to be so (if necessary);
2443 * 2) and the rest converted to collate the same as the
2444 * highest collating representable character. That makes
2445 * them collate at the end. This is similar to how we
2446 * handle embedded NULs, but we use the highest collating
2447 * code point instead of the smallest. Like the NUL case,
2448 * this isn't perfect, but is the best we can reasonably
2449 * do. Every above-255 code point will sort the same as
2450 * the highest-sorting 0-255 code point. If that code
2451 * point can combine in a sequence with some other code
2452 * points for weight calculations, us changing something to
2453 * be it can adversely affect the results. But in most
2454 * cases, it should work reasonably. And note that this is
2455 * really an illegal situation: using code points above 255
2456 * on a locale where only 0-255 are valid. If two strings
2457 * sort entirely equal, then the sort order for the
2458 * above-255 code points will be in code point order. */
2462 /* If we haven't calculated the code point with the maximum
2463 * collating order for this locale, do so now */
2464 if (! PL_strxfrm_max_cp) {
2467 /* The current transformed string that collates the
2468 * highest (except it also includes the prefixed collation
2470 char * cur_max_x = NULL;
2472 /* Look through all legal code points (NUL isn't) */
2473 for (j = 1; j < 256; j++) {
2476 char cur_source[] = { '\0', '\0' };
2478 /* Create a 1-char string of the current code point */
2479 cur_source[0] = (char) j;
2481 /* Then transform it */
2482 x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
2484 /* If something went wrong (which it shouldn't), just
2485 * ignore this code point */
2490 /* If this character's transformation is higher than
2491 * the current highest, this one becomes the highest */
2492 if ( cur_max_x == NULL
2493 || strGT(x + COLLXFRM_HDR_LEN,
2494 cur_max_x + COLLXFRM_HDR_LEN))
2496 PL_strxfrm_max_cp = j;
2505 DEBUG_L(PerlIO_printf(Perl_debug_log,
2506 "_mem_collxfrm: Couldn't find any character to"
2507 " replace above-Latin1 chars in locale %s with",
2508 PL_collation_name));
2512 DEBUG_L(PerlIO_printf(Perl_debug_log,
2513 "_mem_collxfrm: highest 1-byte collating character"
2514 " in locale %s is 0x%02X\n",
2516 PL_strxfrm_max_cp));
2518 Safefree(cur_max_x);
2521 /* Here we know which legal code point collates the highest.
2522 * We are ready to construct the non-UTF-8 string. The length
2523 * will be at least 1 byte smaller than the input string
2524 * (because we changed at least one 2-byte character into a
2525 * single byte), but that is eaten up by the trailing NUL */
2531 char * e = (char *) t + len;
2533 for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
2535 if (UTF8_IS_INVARIANT(cur_char)) {
2538 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
2539 s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
2541 else { /* Replace illegal cp with highest collating
2543 s[d++] = PL_strxfrm_max_cp;
2547 Renew(s, d, char); /* Free up unused space */
2552 /* Here, we have constructed a modified version of the input. It could
2553 * be that we already had a modified copy before we did this version.
2554 * If so, that copy is no longer needed */
2555 if (t != input_string) {
2560 length_in_chars = (utf8)
2561 ? utf8_length((U8 *) s, (U8 *) s + len)
2564 /* The first element in the output is the collation id, used by
2565 * sv_collxfrm(); then comes the space for the transformed string. The
2566 * equation should give us a good estimate as to how much is needed */
2567 xAlloc = COLLXFRM_HDR_LEN
2569 + (PL_collxfrm_mult * length_in_chars);
2570 Newx(xbuf, xAlloc, char);
2571 if (UNLIKELY(! xbuf)) {
2572 DEBUG_L(PerlIO_printf(Perl_debug_log,
2573 "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
2577 /* Store the collation id */
2578 *(U32*)xbuf = PL_collation_ix;
2580 /* Then the transformation of the input. We loop until successful, or we
2584 *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
2586 /* If the transformed string occupies less space than we told strxfrm()
2587 * was available, it means it successfully transformed the whole
2589 if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
2591 /* Some systems include a trailing NUL in the returned length.
2592 * Ignore it, using a loop in case multiple trailing NULs are
2595 && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
2600 /* If the first try didn't get it, it means our prediction was low.
2601 * Modify the coefficients so that we predict a larger value in any
2602 * future transformations */
2604 STRLEN needed = *xlen + 1; /* +1 For trailing NUL */
2605 STRLEN computed_guess = PL_collxfrm_base
2606 + (PL_collxfrm_mult * length_in_chars);
2608 /* On zero-length input, just keep current slope instead of
2610 const STRLEN new_m = (length_in_chars != 0)
2611 ? needed / length_in_chars
2614 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2615 "%s: %d: initial size of %zu bytes for a length "
2616 "%zu string was insufficient, %zu needed\n",
2618 computed_guess, length_in_chars, needed));
2620 /* If slope increased, use it, but discard this result for
2621 * length 1 strings, as we can't be sure that it's a real slope
2623 if (length_in_chars > 1 && new_m > PL_collxfrm_mult) {
2627 STRLEN old_m = PL_collxfrm_mult;
2628 STRLEN old_b = PL_collxfrm_base;
2632 PL_collxfrm_mult = new_m;
2633 PL_collxfrm_base = 1; /* +1 For trailing NUL */
2634 computed_guess = PL_collxfrm_base
2635 + (PL_collxfrm_mult * length_in_chars);
2636 if (computed_guess < needed) {
2637 PL_collxfrm_base += needed - computed_guess;
2640 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2641 "%s: %d: slope is now %zu; was %zu, base "
2642 "is now %zu; was %zu\n",
2644 PL_collxfrm_mult, old_m,
2645 PL_collxfrm_base, old_b));
2647 else { /* Slope didn't change, but 'b' did */
2648 const STRLEN new_b = needed
2651 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2652 "%s: %d: base is now %zu; was %zu\n",
2654 new_b, PL_collxfrm_base));
2655 PL_collxfrm_base = new_b;
2662 if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
2663 DEBUG_L(PerlIO_printf(Perl_debug_log,
2664 "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
2665 *xlen, PERL_INT_MAX));
2669 /* A well-behaved strxfrm() returns exactly how much space it needs
2670 * (usually not including the trailing NUL) when it fails due to not
2671 * enough space being provided. Assume that this is the case unless
2672 * it's been proven otherwise */
2673 if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
2674 xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
2676 else { /* Here, either:
2677 * 1) The strxfrm() has previously shown bad behavior; or
2678 * 2) It isn't the first time through the loop, which means
2679 * that the strxfrm() is now showing bad behavior, because
2680 * we gave it what it said was needed in the previous
2681 * iteration, and it came back saying it needed still more.
2682 * (Many versions of cygwin fit this. When the buffer size
2683 * isn't sufficient, they return the input size instead of
2684 * how much is needed.)
2685 * Increase the buffer size by a fixed percentage and try again.
2687 xAlloc += (xAlloc / 4) + 1;
2688 PL_strxfrm_is_behaved = FALSE;
2692 if (DEBUG_Lv_TEST || debug_initialization) {
2693 PerlIO_printf(Perl_debug_log,
2694 "_mem_collxfrm required more space than previously calculated"
2695 " for locale %s, trying again with new guess=%d+%zu\n",
2696 PL_collation_name, (int) COLLXFRM_HDR_LEN,
2697 xAlloc - COLLXFRM_HDR_LEN);
2704 Renew(xbuf, xAlloc, char);
2705 if (UNLIKELY(! xbuf)) {
2706 DEBUG_L(PerlIO_printf(Perl_debug_log,
2707 "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
2717 if (DEBUG_Lv_TEST || debug_initialization) {
2719 print_collxfrm_input_and_return(s, s + len, xlen, utf8);
2720 PerlIO_printf(Perl_debug_log, "Its xfrm is:");
2721 PerlIO_printf(Perl_debug_log, "%s\n",
2722 _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
2728 /* Free up unneeded space; retain ehough for trailing NUL */
2729 Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
2731 if (s != input_string) {
2739 if (s != input_string) {
2746 if (DEBUG_Lv_TEST || debug_initialization) {
2747 print_collxfrm_input_and_return(s, s + len, NULL, utf8);
2758 S_print_collxfrm_input_and_return(pTHX_
2759 const char * const s,
2760 const char * const e,
2761 const STRLEN * const xlen,
2765 PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
2767 PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
2768 (UV)PL_collation_ix);
2770 PerlIO_printf(Perl_debug_log, "%zu", *xlen);
2773 PerlIO_printf(Perl_debug_log, "NULL");
2775 PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
2777 print_bytes_for_locale(s, e, is_utf8);
2779 PerlIO_printf(Perl_debug_log, "'\n");
2783 S_print_bytes_for_locale(pTHX_
2784 const char * const s,
2785 const char * const e,
2789 bool prev_was_printable = TRUE;
2790 bool first_time = TRUE;
2792 PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
2796 ? utf8_to_uvchr_buf((U8 *) t, e, NULL)
2799 if (! prev_was_printable) {
2800 PerlIO_printf(Perl_debug_log, " ");
2802 PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
2803 prev_was_printable = TRUE;
2807 PerlIO_printf(Perl_debug_log, " ");
2809 PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
2810 prev_was_printable = FALSE;
2812 t += (is_utf8) ? UTF8SKIP(t) : 1;
2817 # endif /* #ifdef DEBUGGING */
2818 #endif /* USE_LOCALE_COLLATE */
2823 Perl__is_cur_LC_category_utf8(pTHX_ int category)
2825 /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
2826 * otherwise. 'category' may not be LC_ALL. If the platform doesn't have
2827 * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
2828 * could give the wrong result. The result will very likely be correct for
2829 * languages that have commonly used non-ASCII characters, but for notably
2830 * English, it comes down to if the locale's name ends in something like
2831 * "UTF-8". It errs on the side of not being a UTF-8 locale. */
2833 char *save_input_locale = NULL;
2838 assert(category != LC_ALL);
2842 /* First dispose of the trivial cases */
2843 save_input_locale = do_setlocale_r(category, NULL);
2844 if (! save_input_locale) {
2845 DEBUG_L(PerlIO_printf(Perl_debug_log,
2846 "Could not find current locale for category %d\n",
2848 return FALSE; /* XXX maybe should croak */
2850 save_input_locale = stdize_locale(savepv(save_input_locale));
2851 if (isNAME_C_OR_POSIX(save_input_locale)) {
2852 DEBUG_L(PerlIO_printf(Perl_debug_log,
2853 "Current locale for category %d is %s\n",
2854 category, save_input_locale));
2855 Safefree(save_input_locale);
2859 # if defined(USE_LOCALE_CTYPE) \
2860 && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET)))
2862 { /* Next try nl_langinfo or MB_CUR_MAX if available */
2864 char *save_ctype_locale = NULL;
2867 if (category != LC_CTYPE) { /* These work only on LC_CTYPE */
2869 /* Get the current LC_CTYPE locale */
2870 save_ctype_locale = do_setlocale_c(LC_CTYPE, NULL);
2871 if (! save_ctype_locale) {
2872 DEBUG_L(PerlIO_printf(Perl_debug_log,
2873 "Could not find current locale for LC_CTYPE\n"));
2874 goto cant_use_nllanginfo;
2876 save_ctype_locale = stdize_locale(savepv(save_ctype_locale));
2878 /* If LC_CTYPE and the desired category use the same locale, this
2879 * means that finding the value for LC_CTYPE is the same as finding
2880 * the value for the desired category. Otherwise, switch LC_CTYPE
2881 * to the desired category's locale */
2882 if (strEQ(save_ctype_locale, save_input_locale)) {
2883 Safefree(save_ctype_locale);
2884 save_ctype_locale = NULL;
2886 else if (! do_setlocale_c(LC_CTYPE, save_input_locale)) {
2887 DEBUG_L(PerlIO_printf(Perl_debug_log,
2888 "Could not change LC_CTYPE locale to %s\n",
2889 save_input_locale));
2890 Safefree(save_ctype_locale);
2891 goto cant_use_nllanginfo;
2895 DEBUG_L(PerlIO_printf(Perl_debug_log, "Current LC_CTYPE locale=%s\n",
2896 save_input_locale));
2898 /* Here the current LC_CTYPE is set to the locale of the category whose
2899 * information is desired. This means that nl_langinfo() and MB_CUR_MAX
2900 * should give the correct results */
2902 # if defined(HAS_NL_LANGINFO) && defined(CODESET)
2903 /* The task is easiest if has this POSIX 2001 function */
2906 const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE);
2907 /* FALSE => already in dest locale */
2909 DEBUG_L(PerlIO_printf(Perl_debug_log,
2910 "\tnllanginfo returned CODESET '%s'\n", codeset));
2912 if (codeset && strNE(codeset, "")) {
2913 /* If we switched LC_CTYPE, switch back */
2914 if (save_ctype_locale) {
2915 do_setlocale_c(LC_CTYPE, save_ctype_locale);
2916 Safefree(save_ctype_locale);
2919 is_utf8 = ( ( strlen(codeset) == STRLENs("UTF-8")
2920 && foldEQ(codeset, STR_WITH_LEN("UTF-8")))
2921 || ( strlen(codeset) == STRLENs("UTF8")
2922 && foldEQ(codeset, STR_WITH_LEN("UTF8"))));
2924 DEBUG_L(PerlIO_printf(Perl_debug_log,
2925 "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n",
2927 Safefree(save_input_locale);
2935 /* Here, either we don't have nl_langinfo, or it didn't return a
2936 * codeset. Try MB_CUR_MAX */
2938 /* Standard UTF-8 needs at least 4 bytes to represent the maximum
2939 * Unicode code point. Since UTF-8 is the only non-single byte
2940 * encoding we handle, we just say any such encoding is UTF-8, and if
2941 * turns out to be wrong, other things will fail */
2942 is_utf8 = (unsigned) MB_CUR_MAX >= STRLENs(MAX_UNICODE_UTF8);
2944 DEBUG_L(PerlIO_printf(Perl_debug_log,
2945 "\tMB_CUR_MAX=%d; ?UTF8 locale=%d\n",
2946 (int) MB_CUR_MAX, is_utf8));
2948 Safefree(save_input_locale);
2952 /* ... But, most system that have MB_CUR_MAX will also have mbtowc(),
2953 * since they are both in the C99 standard. We can feed a known byte
2954 * string to the latter function, and check that it gives the expected
2960 PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
2962 len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
2965 if ( len != STRLENs(REPLACEMENT_CHARACTER_UTF8)
2966 || wc != (wchar_t) UNICODE_REPLACEMENT)
2969 DEBUG_L(PerlIO_printf(Perl_debug_log, "\replacement=U+%x\n",
2971 DEBUG_L(PerlIO_printf(Perl_debug_log,
2972 "\treturn from mbtowc=%d; errno=%d; ?UTF8 locale=0\n",
2979 /* If we switched LC_CTYPE, switch back */
2980 if (save_ctype_locale) {
2981 do_setlocale_c(LC_CTYPE, save_ctype_locale);
2982 Safefree(save_ctype_locale);
2991 cant_use_nllanginfo:
2993 # else /* nl_langinfo should work if available, so don't bother compiling this
2994 fallback code. The final fallback of looking at the name is
2995 compiled, and will be executed if nl_langinfo fails */
2997 /* nl_langinfo not available or failed somehow. Next try looking at the
2998 * currency symbol to see if it disambiguates things. Often that will be
2999 * in the native script, and if the symbol isn't in UTF-8, we know that the
3000 * locale isn't. If it is non-ASCII UTF-8, we infer that the locale is
3001 * too, as the odds of a non-UTF8 string being valid UTF-8 are quite small
3004 # ifdef HAS_LOCALECONV
3005 # ifdef USE_LOCALE_MONETARY
3008 char *save_monetary_locale = NULL;
3009 bool only_ascii = FALSE;
3010 bool is_utf8 = FALSE;
3013 /* Like above for LC_CTYPE, we first set LC_MONETARY to the locale of
3014 * the desired category, if it isn't that locale already */
3016 if (category != LC_MONETARY) {
3018 save_monetary_locale = do_setlocale_c(LC_MONETARY, NULL);
3019 if (! save_monetary_locale) {
3020 DEBUG_L(PerlIO_printf(Perl_debug_log,
3021 "Could not find current locale for LC_MONETARY\n"));
3022 goto cant_use_monetary;
3024 save_monetary_locale = stdize_locale(savepv(save_monetary_locale));
3026 if (strEQ(save_monetary_locale, save_input_locale)) {
3027 Safefree(save_monetary_locale);
3028 save_monetary_locale = NULL;
3030 else if (! do_setlocale_c(LC_MONETARY, save_input_locale)) {
3031 DEBUG_L(PerlIO_printf(Perl_debug_log,
3032 "Could not change LC_MONETARY locale to %s\n",
3033 save_input_locale));
3034 Safefree(save_monetary_locale);
3035 goto cant_use_monetary;
3039 /* Here the current LC_MONETARY is set to the locale of the category
3040 * whose information is desired. */
3044 || ! lc->currency_symbol
3045 || is_utf8_invariant_string((U8 *) lc->currency_symbol, 0))
3047 DEBUG_L(PerlIO_printf(Perl_debug_log, "Couldn't get currency symbol for %s, or contains only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
3051 is_utf8 = is_utf8_string((U8 *) lc->currency_symbol, 0);
3054 /* If we changed it, restore LC_MONETARY to its original locale */
3055 if (save_monetary_locale) {
3056 do_setlocale_c(LC_MONETARY, save_monetary_locale);
3057 Safefree(save_monetary_locale);
3062 /* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
3063 * otherwise assume the locale is UTF-8 if and only if the symbol
3064 * is non-ascii UTF-8. */
3065 DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
3066 save_input_locale, is_utf8));
3067 Safefree(save_input_locale);
3073 # endif /* USE_LOCALE_MONETARY */
3074 # endif /* HAS_LOCALECONV */
3076 # if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME)
3078 /* Still haven't found a non-ASCII string to disambiguate UTF-8 or not. Try
3079 * the names of the months and weekdays, timezone, and am/pm indicator */
3081 char *save_time_locale = NULL;
3083 bool is_dst = FALSE;
3087 char * formatted_time;
3090 /* Like above for LC_MONETARY, we set LC_TIME to the locale of the
3091 * desired category, if it isn't that locale already */
3093 if (category != LC_TIME) {
3095 save_time_locale = do_setlocale_c(LC_TIME, NULL);
3096 if (! save_time_locale) {
3097 DEBUG_L(PerlIO_printf(Perl_debug_log,
3098 "Could not find current locale for LC_TIME\n"));
3101 save_time_locale = stdize_locale(savepv(save_time_locale));
3103 if (strEQ(save_time_locale, save_input_locale)) {
3104 Safefree(save_time_locale);
3105 save_time_locale = NULL;
3107 else if (! do_setlocale_c(LC_TIME, save_input_locale)) {
3108 DEBUG_L(PerlIO_printf(Perl_debug_log,
3109 "Could not change LC_TIME locale to %s\n",
3110 save_input_locale));
3111 Safefree(save_time_locale);
3116 /* Here the current LC_TIME is set to the locale of the category
3117 * whose information is desired. Look at all the days of the week and
3118 * month names, and the timezone and am/pm indicator for UTF-8 variant
3119 * characters. The first such a one found will tell us if the locale
3120 * is UTF-8 or not */
3122 for (i = 0; i < 7 + 12; i++) { /* 7 days; 12 months */
3123 formatted_time = my_strftime("%A %B %Z %p",
3124 0, 0, hour, dom, month, 2012 - 1900, 0, 0, is_dst);
3125 if ( ! formatted_time
3126 || is_utf8_invariant_string((U8 *) formatted_time, 0))
3129 /* Here, we didn't find a non-ASCII. Try the next time through
3130 * with the complemented dst and am/pm, and try with the next
3131 * weekday. After we have gotten all weekdays, try the next
3134 hour = (hour + 12) % 24;
3142 /* Here, we have a non-ASCII. Return TRUE is it is valid UTF8;
3143 * false otherwise. But first, restore LC_TIME to its original
3144 * locale if we changed it */
3145 if (save_time_locale) {
3146 do_setlocale_c(LC_TIME, save_time_locale);
3147 Safefree(save_time_locale);
3150 DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
3152 is_utf8_string((U8 *) formatted_time, 0)));
3153 Safefree(save_input_locale);
3154 return is_utf8_string((U8 *) formatted_time, 0);
3157 /* Falling off the end of the loop indicates all the names were just
3158 * ASCII. Go on to the next test. If we changed it, restore LC_TIME
3159 * to its original locale */
3160 if (save_time_locale) {
3161 do_setlocale_c(LC_TIME, save_time_locale);
3162 Safefree(save_time_locale);
3164 DEBUG_L(PerlIO_printf(Perl_debug_log, "All time-related words for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
3170 # if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST)
3172 /* This code is ifdefd out because it was found to not be necessary in testing
3173 * on our dromedary test machine, which has over 700 locales. There, this
3174 * added no value to looking at the currency symbol and the time strings. I
3175 * left it in so as to avoid rewriting it if real-world experience indicates
3176 * that dromedary is an outlier. Essentially, instead of returning abpve if we
3177 * haven't found illegal utf8, we continue on and examine all the strerror()
3178 * messages on the platform for utf8ness. If all are ASCII, we still don't
3179 * know the answer; but otherwise we have a pretty good indication of the
3180 * utf8ness. The reason this doesn't help much is that the messages may not
3181 * have been translated into the locale. The currency symbol and time strings
3182 * are much more likely to have been translated. */
3185 bool is_utf8 = FALSE;
3186 bool non_ascii = FALSE;
3187 char *save_messages_locale = NULL;
3188 const char * errmsg = NULL;
3190 /* Like above, we set LC_MESSAGES to the locale of the desired
3191 * category, if it isn't that locale already */
3193 if (category != LC_MESSAGES) {
3195 save_messages_locale = do_setlocale_c(LC_MESSAGES, NULL);
3196 if (! save_messages_locale) {
3197 DEBUG_L(PerlIO_printf(Perl_debug_log,
3198 "Could not find current locale for LC_MESSAGES\n"));
3199 goto cant_use_messages;
3201 save_messages_locale = stdize_locale(savepv(save_messages_locale));
3203 if (strEQ(save_messages_locale, save_input_locale)) {
3204 Safefree(save_messages_locale);
3205 save_messages_locale = NULL;
3207 else if (! do_setlocale_c(LC_MESSAGES, save_input_locale)) {
3208 DEBUG_L(PerlIO_printf(Perl_debug_log,
3209 "Could not change LC_MESSAGES locale to %s\n",
3210 save_input_locale));
3211 Safefree(save_messages_locale);
3212 goto cant_use_messages;
3216 /* Here the current LC_MESSAGES is set to the locale of the category
3217 * whose information is desired. Look through all the messages. We
3218 * can't use Strerror() here because it may expand to code that
3219 * segfaults in miniperl */
3221 for (e = 0; e <= sys_nerr; e++) {
3223 errmsg = sys_errlist[e];
3224 if (errno || !errmsg) {
3227 errmsg = savepv(errmsg);
3228 if (! is_utf8_invariant_string((U8 *) errmsg, 0)) {
3230 is_utf8 = is_utf8_string((U8 *) errmsg, 0);
3236 /* And, if we changed it, restore LC_MESSAGES to its original locale */
3237 if (save_messages_locale) {
3238 do_setlocale_c(LC_MESSAGES, save_messages_locale);
3239 Safefree(save_messages_locale);
3244 /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
3245 * any non-ascii means it is one; otherwise we assume it isn't */
3246 DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
3249 Safefree(save_input_locale);
3253 DEBUG_L(PerlIO_printf(Perl_debug_log, "All error messages for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
3258 # endif /* the code that is compiled when no nl_langinfo */
3260 # ifndef EBCDIC /* On os390, even if the name ends with "UTF-8', it isn't a
3263 /* As a last resort, look at the locale name to see if it matches
3264 * qr/UTF -? * 8 /ix, or some other common locale names. This "name", the
3265 * return of setlocale(), is actually defined to be opaque, so we can't
3266 * really rely on the absence of various substrings in the name to indicate
3267 * its UTF-8ness, but if it has UTF8 in the name, it is extremely likely to
3268 * be a UTF-8 locale. Similarly for the other common names */
3270 final_pos = strlen(save_input_locale) - 1;
3271 if (final_pos >= 3) {
3272 char *name = save_input_locale;
3274 /* Find next 'U' or 'u' and look from there */
3275 while ((name += strcspn(name, "Uu") + 1)
3276 <= save_input_locale + final_pos - 2)
3278 if ( isALPHA_FOLD_NE(*name, 't')
3279 || isALPHA_FOLD_NE(*(name + 1), 'f'))
3284 if (*(name) == '-') {
3285 if ((name > save_input_locale + final_pos - 1)) {
3290 if (*(name) == '8') {
3291 DEBUG_L(PerlIO_printf(Perl_debug_log,
3292 "Locale %s ends with UTF-8 in name\n",
3293 save_input_locale));
3294 Safefree(save_input_locale);
3298 DEBUG_L(PerlIO_printf(Perl_debug_log,
3299 "Locale %s doesn't end with UTF-8 in name\n",
3300 save_input_locale));
3306 /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
3307 if (memENDs(save_input_locale, final_pos, "65001")) {
3308 DEBUG_L(PerlIO_printf(Perl_debug_log,
3309 "Locale %s ends with 65001 in name, is UTF-8 locale\n",
3310 save_input_locale));
3311 Safefree(save_input_locale);
3317 /* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
3318 * since we are about to return FALSE anyway, there is no point in doing
3319 * this extra work */
3322 if (instr(save_input_locale, "8859")) {
3323 DEBUG_L(PerlIO_printf(Perl_debug_log,
3324 "Locale %s has 8859 in name, not UTF-8 locale\n",
3325 save_input_locale));
3326 Safefree(save_input_locale);
3331 DEBUG_L(PerlIO_printf(Perl_debug_log,
3332 "Assuming locale %s is not a UTF-8 locale\n",
3333 save_input_locale));
3334 Safefree(save_input_locale);
3342 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
3345 /* Internal function which returns if we are in the scope of a pragma that
3346 * enables the locale category 'category'. 'compiling' should indicate if
3347 * this is during the compilation phase (TRUE) or not (FALSE). */
3349 const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
3351 SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
3352 if (! categories || categories == &PL_sv_placeholder) {
3356 /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
3357 * a valid unsigned */
3358 assert(category >= -1);
3359 return cBOOL(SvUV(categories) & (1U << (category + 1)));
3363 Perl_my_strerror(pTHX_ const int errnum)
3365 /* Returns a mortalized copy of the text of the error message associated
3366 * with 'errnum'. It uses the current locale's text unless the platform
3367 * doesn't have the LC_MESSAGES category or we are not being called from
3368 * within the scope of 'use locale'. In the former case, it uses whatever
3369 * strerror returns; in the latter case it uses the text from the C locale.
3371 * The function just calls strerror(), but temporarily switches, if needed,
3372 * to the C locale */
3377 #ifndef USE_LOCALE_MESSAGES
3379 /* If platform doesn't have messages category, we don't do any switching to
3380 * the C locale; we just use whatever strerror() returns */
3382 errstr = savepv(Strerror(errnum));
3384 #else /* Has locale messages */
3386 const bool within_locale_scope = IN_LC(LC_MESSAGES);
3388 # if defined(HAS_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
3390 /* This function is trivial if we don't have to worry about thread safety
3391 * and have strerror_l(), as it handles the switch of locales so we don't
3392 * have to deal with that. We don't have to worry about thread safety if
3393 * this is an unthreaded build, or if strerror_r() is also available. Both
3394 * it and strerror_l() are thread-safe. Plain strerror() isn't thread
3395 * safe. But on threaded builds when strerror_r() is available, the
3396 * apparent call to strerror() below is actually a macro that
3397 * behind-the-scenes calls strerror_r().
3400 # if ! defined(USE_ITHREADS) || defined(HAS_STRERROR_R)
3402 if (within_locale_scope) {
3403 errstr = savepv(strerror(errnum));
3406 errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
3411 /* Here we have strerror_l(), but not strerror_r() and we are on a
3412 * threaded-build. We use strerror_l() for everything, constructing a
3413 * locale to pass to it if necessary */
3415 bool do_free = FALSE;
3416 locale_t locale_to_use;
3418 if (within_locale_scope) {
3419 locale_to_use = uselocale((locale_t) 0);
3420 if (locale_to_use == LC_GLOBAL_LOCALE) {
3421 locale_to_use = duplocale(LC_GLOBAL_LOCALE);
3425 else { /* Use C locale if not within 'use locale' scope */
3426 locale_to_use = PL_C_locale_obj;
3429 errstr = savepv(strerror_l(errnum, locale_to_use));
3432 freelocale(locale_to_use);
3436 # else /* Doesn't have strerror_l() */
3438 # ifdef USE_POSIX_2008_LOCALE
3440 locale_t save_locale = NULL;
3444 char * save_locale = NULL;
3445 bool locale_is_C = FALSE;
3447 /* We have a critical section to prevent another thread from changing the
3448 * locale out from under us (or zapping the buffer returned from
3454 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3455 "my_strerror called with errnum %d\n", errnum));
3456 if (! within_locale_scope) {
3459 # ifdef USE_POSIX_2008_LOCALE /* Use the thread-safe locale functions */
3461 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3462 "Not within locale scope, about to call"
3463 " uselocale(0x%p)\n", PL_C_locale_obj));
3464 save_locale = uselocale(PL_C_locale_obj);
3465 if (! save_locale) {
3466 DEBUG_L(PerlIO_printf(Perl_debug_log,
3467 "uselocale failed, errno=%d\n", errno));
3470 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3471 "uselocale returned 0x%p\n", save_locale));
3474 # else /* Not thread-safe build */
3476 save_locale = do_setlocale_c(LC_MESSAGES, NULL);
3477 if (! save_locale) {
3478 DEBUG_L(PerlIO_printf(Perl_debug_log,
3479 "setlocale failed, errno=%d\n", errno));
3482 locale_is_C = isNAME_C_OR_POSIX(save_locale);
3484 /* Switch to the C locale if not already in it */
3485 if (! locale_is_C) {
3487 /* The setlocale() just below likely will zap 'save_locale', so
3489 save_locale = savepv(save_locale);
3490 do_setlocale_c(LC_MESSAGES, "C");
3496 } /* end of ! within_locale_scope */
3498 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
3499 __FILE__, __LINE__));
3502 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3503 "Any locale change has been done; about to call Strerror\n"));
3504 errstr = savepv(Strerror(errnum));
3506 if (! within_locale_scope) {
3509 # ifdef USE_POSIX_2008_LOCALE
3511 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3512 "%s: %d: not within locale scope, restoring the locale\n",
3513 __FILE__, __LINE__));
3514 if (save_locale && ! uselocale(save_locale)) {
3515 DEBUG_L(PerlIO_printf(Perl_debug_log,
3516 "uselocale restore failed, errno=%d\n", errno));
3522 if (save_locale && ! locale_is_C) {
3523 if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
3524 DEBUG_L(PerlIO_printf(Perl_debug_log,
3525 "setlocale restore failed, errno=%d\n", errno));
3527 Safefree(save_locale);
3534 # endif /* End of doesn't have strerror_l */
3535 #endif /* End of does have locale messages */
3539 if (DEBUG_Lv_TEST) {
3540 PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
3541 print_bytes_for_locale(errstr, errstr + strlen(errstr), 0);
3542 PerlIO_printf(Perl_debug_log, "'\n");
3553 =for apidoc sync_locale
3555 Changing the program's locale should be avoided by XS code. Nevertheless,
3556 certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
3557 happens, Perl needs to be told that the locale has changed. Use this function
3558 to do so, before returning to Perl.
3564 Perl_sync_locale(pTHX)
3568 #ifdef USE_LOCALE_CTYPE
3570 newlocale = do_setlocale_c(LC_CTYPE, NULL);
3571 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3572 "%s:%d: %s\n", __FILE__, __LINE__,
3573 setlocale_debug_string(LC_CTYPE, NULL, newlocale)));
3574 new_ctype(newlocale);
3576 #endif /* USE_LOCALE_CTYPE */
3577 #ifdef USE_LOCALE_COLLATE
3579 newlocale = do_setlocale_c(LC_COLLATE, NULL);
3580 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3581 "%s:%d: %s\n", __FILE__, __LINE__,
3582 setlocale_debug_string(LC_COLLATE, NULL, newlocale)));
3583 new_collate(newlocale);
3586 #ifdef USE_LOCALE_NUMERIC
3588 newlocale = do_setlocale_c(LC_NUMERIC, NULL);
3589 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3590 "%s:%d: %s\n", __FILE__, __LINE__,
3591 setlocale_debug_string(LC_NUMERIC, NULL, newlocale)));
3592 new_numeric(newlocale);
3594 #endif /* USE_LOCALE_NUMERIC */
3598 #if defined(DEBUGGING) && defined(USE_LOCALE)
3601 S_setlocale_debug_string(const int category, /* category number,
3603 const char* const locale, /* locale name */
3605 /* return value from setlocale() when attempting to
3606 * set 'category' to 'locale' */
3607 const char* const retval)
3609 /* Returns a pointer to a NUL-terminated string in static storage with
3610 * added text about the info passed in. This is not thread safe and will
3611 * be overwritten by the next call, so this should be used just to
3612 * formulate a string to immediately print or savepv() on. */
3614 /* initialise to a non-null value to keep it out of BSS and so keep
3615 * -DPERL_GLOBAL_STRUCT_PRIVATE happy */
3616 static char ret[128] = "If you can read this, thank your buggy C"
3617 " library strlcpy(), and change your hints file"
3623 const unsigned int highest_index = LC_ALL_INDEX;
3627 const unsigned int highest_index = NOMINAL_LC_ALL_INDEX - 1;
3632 my_strlcpy(ret, "setlocale(", sizeof(ret));
3634 /* Look for category in our list, and if found, add its name */
3635 for (i = 0; i <= highest_index; i++) {
3636 if (category == categories[i]) {
3637 my_strlcat(ret, category_names[i], sizeof(ret));
3638 goto found_category;
3642 /* Unknown category to us */
3643 my_snprintf(ret, sizeof(ret), "%s? %d", ret, category);
3647 my_strlcat(ret, ", ", sizeof(ret));
3650 my_strlcat(ret, "\"", sizeof(ret));
3651 my_strlcat(ret, locale, sizeof(ret));
3652 my_strlcat(ret, "\"", sizeof(ret));
3655 my_strlcat(ret, "NULL", sizeof(ret));
3658 my_strlcat(ret, ") returned ", sizeof(ret));
3661 my_strlcat(ret, "\"", sizeof(ret));
3662 my_strlcat(ret, retval, sizeof(ret));
3663 my_strlcat(ret, "\"", sizeof(ret));
3666 my_strlcat(ret, "NULL", sizeof(ret));
3669 assert(strlen(ret) < sizeof(ret));
3678 * ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blob