This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4279929753707ca2ff14925dec1169b647d707df
[perl5.git] / locale.c
1 /*    locale.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
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.
8  *
9  */
10
11 /*
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!
19  *
20  *     [p.238 of _The Lord of the Rings_, II/i: "Many Meetings"]
21  */
22
23 /* utility functions for handling locale-specific stuff like what
24  * character represents the decimal point.
25  *
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
34  * of 'use locale'.
35  */
36
37 #include "EXTERN.h"
38 #define PERL_IN_LOCALE_C
39 #include "perl_langinfo.h"
40 #include "perl.h"
41
42 #include "reentr.h"
43
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 */
47 #if ! defined(DEBUGGING) || defined(PERL_GLOBAL_STRUCT)
48 #  define debug_initialization 0
49 #  define DEBUG_INITIALIZATION_set(v)
50 #else
51 static bool debug_initialization = FALSE;
52 #  define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
53 #endif
54
55 /* strlen() of a literal string constant.  We might want this more general,
56  * but using it in just this file for now.  A problem with more generality is
57  * the compiler warnings about comparing unlike signs */
58 #define STRLENs(s)  (sizeof("" s "") - 1)
59
60 /* Is the C string input 'name' "C" or "POSIX"?  If so, and 'name' is the
61  * return of setlocale(), then this is extremely likely to be the C or POSIX
62  * locale.  However, the output of setlocale() is documented to be opaque, but
63  * the odds are extremely small that it would return these two strings for some
64  * other locale.  Note that VMS in these two locales includes many non-ASCII
65  * characters as controls and punctuation (below are hex bytes):
66  *   cntrl:  84-97 9B-9F
67  *   punct:  A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
68  * Oddly, none there are listed as alphas, though some represent alphabetics
69  * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
70 #define isNAME_C_OR_POSIX(name)                                              \
71                              (   (name) != NULL                              \
72                               && (( *(name) == 'C' && (*(name + 1)) == '\0') \
73                                    || strEQ((name), "POSIX")))
74
75 #ifdef USE_LOCALE
76
77 /*
78  * Standardize the locale name from a string returned by 'setlocale', possibly
79  * modifying that string.
80  *
81  * The typical return value of setlocale() is either
82  * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
83  * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
84  *     (the space-separated values represent the various sublocales,
85  *      in some unspecified order).  This is not handled by this function.
86  *
87  * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
88  * which is harmful for further use of the string in setlocale().  This
89  * function removes the trailing new line and everything up through the '='
90  *
91  */
92 STATIC char *
93 S_stdize_locale(pTHX_ char *locs)
94 {
95     const char * const s = strchr(locs, '=');
96     bool okay = TRUE;
97
98     PERL_ARGS_ASSERT_STDIZE_LOCALE;
99
100     if (s) {
101         const char * const t = strchr(s, '.');
102         okay = FALSE;
103         if (t) {
104             const char * const u = strchr(t, '\n');
105             if (u && (u[1] == 0)) {
106                 const STRLEN len = u - s;
107                 Move(s + 1, locs, len, char);
108                 locs[len] = 0;
109                 okay = TRUE;
110             }
111         }
112     }
113
114     if (!okay)
115         Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
116
117     return locs;
118 }
119
120 /* Two parallel arrays; first the locale categories Perl uses on this system;
121  * the second array is their names.  These arrays are in mostly arbitrary
122  * order. */
123
124 const int categories[] = {
125
126 #    ifdef USE_LOCALE_NUMERIC
127                              LC_NUMERIC,
128 #    endif
129 #    ifdef USE_LOCALE_CTYPE
130                              LC_CTYPE,
131 #    endif
132 #    ifdef USE_LOCALE_COLLATE
133                              LC_COLLATE,
134 #    endif
135 #    ifdef USE_LOCALE_TIME
136                              LC_TIME,
137 #    endif
138 #    ifdef USE_LOCALE_MESSAGES
139                              LC_MESSAGES,
140 #    endif
141 #    ifdef USE_LOCALE_MONETARY
142                              LC_MONETARY,
143 #    endif
144 #    ifdef LC_ALL
145                              LC_ALL,
146 #    endif
147                             -1  /* Placeholder because C doesn't allow a
148                                    trailing comma, and it would get complicated
149                                    with all the #ifdef's */
150 };
151
152 /* The top-most real element is LC_ALL */
153
154 const char * category_names[] = {
155
156 #    ifdef USE_LOCALE_NUMERIC
157                                  "LC_NUMERIC",
158 #    endif
159 #    ifdef USE_LOCALE_CTYPE
160                                  "LC_CTYPE",
161 #    endif
162 #    ifdef USE_LOCALE_COLLATE
163                                  "LC_COLLATE",
164 #    endif
165 #    ifdef USE_LOCALE_TIME
166                                  "LC_TIME",
167 #    endif
168 #    ifdef USE_LOCALE_MESSAGES
169                                  "LC_MESSAGES",
170 #    endif
171 #    ifdef USE_LOCALE_MONETARY
172                                  "LC_MONETARY",
173 #    endif
174 #    ifdef LC_ALL
175                                  "LC_ALL",
176 #    endif
177                                  NULL  /* Placeholder */
178                             };
179
180 #  ifdef LC_ALL
181
182     /* On systems with LC_ALL, it is kept in the highest index position.  (-2
183      * to account for the final unused placeholder element.) */
184 #    define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 2)
185
186 #  else
187
188     /* On systems without LC_ALL, we pretend it is there, one beyond the real
189      * top element, hence in the unused placeholder element. */
190 #    define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 1)
191
192 #  endif
193
194 /* Pretending there is an LC_ALL element just above allows us to avoid most
195  * special cases.  Most loops through these arrays in the code below are
196  * written like 'for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)'.  They will work
197  * on either type of system.  But the code must be written to not access the
198  * element at 'LC_ALL_INDEX' except on platforms that have it.  This can be
199  * checked for at compile time by using the #define LC_ALL_INDEX which is only
200  * defined if we do have LC_ALL. */
201
202 STATIC const char *
203 S_category_name(const int category)
204 {
205     unsigned int i;
206
207 #ifdef LC_ALL
208
209     if (category == LC_ALL) {
210         return "LC_ALL";
211     }
212
213 #endif
214
215     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
216         if (category == categories[i]) {
217             return category_names[i];
218         }
219     }
220
221     {
222         const char suffix[] = " (unknown)";
223         int temp = category;
224         Size_t length = sizeof(suffix) + 1;
225         char * unknown;
226         dTHX;
227
228         if (temp < 0) {
229             length++;
230             temp = - temp;
231         }
232
233         /* Calculate the number of digits */
234         while (temp >= 10) {
235             temp /= 10;
236             length++;
237         }
238
239         Newx(unknown, length, char);
240         my_snprintf(unknown, length, "%d%s", category, suffix);
241         SAVEFREEPV(unknown);
242         return unknown;
243     }
244 }
245
246 /* Now create LC_foo_INDEX #defines for just those categories on this system */
247 #  ifdef USE_LOCALE_NUMERIC
248 #    define LC_NUMERIC_INDEX            0
249 #    define _DUMMY_NUMERIC              LC_NUMERIC_INDEX
250 #  else
251 #    define _DUMMY_NUMERIC              -1
252 #  endif
253 #  ifdef USE_LOCALE_CTYPE
254 #    define LC_CTYPE_INDEX              _DUMMY_NUMERIC + 1
255 #    define _DUMMY_CTYPE                LC_CTYPE_INDEX
256 #  else
257 #    define _DUMMY_CTYPE                _DUMMY_NUMERIC
258 #  endif
259 #  ifdef USE_LOCALE_COLLATE
260 #    define LC_COLLATE_INDEX            _DUMMY_CTYPE + 1
261 #    define _DUMMY_COLLATE              LC_COLLATE_INDEX
262 #  else
263 #    define _DUMMY_COLLATE              _DUMMY_COLLATE
264 #  endif
265 #  ifdef USE_LOCALE_TIME
266 #    define LC_TIME_INDEX               _DUMMY_COLLATE + 1
267 #    define _DUMMY_TIME                 LC_TIME_INDEX
268 #  else
269 #    define _DUMMY_TIME                 _DUMMY_COLLATE
270 #  endif
271 #  ifdef USE_LOCALE_MESSAGES
272 #    define LC_MESSAGES_INDEX           _DUMMY_TIME + 1
273 #    define _DUMMY_MESSAGES             LC_MESSAGES_INDEX
274 #  else
275 #    define _DUMMY_MESSAGES             _DUMMY_TIME
276 #  endif
277 #  ifdef USE_LOCALE_MONETARY
278 #    define LC_MONETARY_INDEX           _DUMMY_MESSAGES + 1
279 #    define _DUMMY_MONETARY             LC_MONETARY_INDEX
280 #  else
281 #    define _DUMMY_MONETARY             _DUMMY_MESSAGES
282 #  endif
283 #  ifdef LC_ALL
284 #    define LC_ALL_INDEX                _DUMMY_MONETARY + 1
285 #  endif
286 #endif /* ifdef USE_LOCALE */
287
288 /* Windows requres a customized base-level setlocale() */
289 #  ifdef WIN32
290 #    define my_setlocale(cat, locale) win32_setlocale(cat, locale)
291 #  else
292 #    define my_setlocale(cat, locale) setlocale(cat, locale)
293 #  endif
294
295 /* Just placeholders for now.  "_c" is intended to be called when the category
296  * is a constant known at compile time; "_r", not known until run time  */
297 #  define do_setlocale_c(category, locale) my_setlocale(category, locale)
298 #  define do_setlocale_r(category, locale) my_setlocale(category, locale)
299
300 STATIC void
301 S_set_numeric_radix(pTHX_ const bool use_locale)
302 {
303     /* If 'use_locale' is FALSE, set to use a dot for the radix character.  If
304      * TRUE, use the radix character derived from the current locale */
305
306 #if defined(USE_LOCALE_NUMERIC) && (   defined(HAS_LOCALECONV)              \
307                                     || defined(HAS_NL_LANGINFO))
308
309     /* We only set up the radix SV if we are to use a locale radix ... */
310     if (use_locale) {
311         const char * radix = my_nl_langinfo(PERL_RADIXCHAR, FALSE);
312                                           /* FALSE => already in dest locale */
313         /* ... and the character being used isn't a dot */
314         if (strNE(radix, ".")) {
315             const U8 * first_variant;
316
317             if (PL_numeric_radix_sv) {
318                 sv_setpv(PL_numeric_radix_sv, radix);
319             }
320             else {
321                 PL_numeric_radix_sv = newSVpv(radix, 0);
322             }
323
324             /* If there is a byte variant under UTF-8, and if the remainder of
325              * the string starting there is valid UTF-8, and we are in a UTF-8
326              * locale, then mark the radix as being in UTF-8 */
327             if ( !  is_utf8_invariant_string_loc(
328                                             (U8 *) SvPVX(PL_numeric_radix_sv),
329                                             SvCUR(PL_numeric_radix_sv),
330                                             &first_variant)
331                 &&  is_utf8_string(first_variant,
332                                    SvCUR(PL_numeric_radix_sv)
333                                  - ((char *) first_variant
334                                  - SvPVX(PL_numeric_radix_sv)))
335                 && _is_cur_LC_category_utf8(LC_NUMERIC))
336             {
337                 SvUTF8_on(PL_numeric_radix_sv);
338             }
339             goto done;
340         }
341     }
342
343     SvREFCNT_dec(PL_numeric_radix_sv);
344     PL_numeric_radix_sv = NULL;
345
346   done: ;
347
348 #  ifdef DEBUGGING
349
350     if (DEBUG_L_TEST || debug_initialization) {
351         PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
352                                           (PL_numeric_radix_sv)
353                                            ? SvPVX(PL_numeric_radix_sv)
354                                            : "NULL",
355                                           (PL_numeric_radix_sv)
356                                            ? cBOOL(SvUTF8(PL_numeric_radix_sv))
357                                            : 0);
358     }
359
360 #  endif
361 #endif /* USE_LOCALE_NUMERIC and can find the radix char */
362
363 }
364
365
366 void
367 Perl_new_numeric(pTHX_ const char *newnum)
368 {
369
370 #ifndef USE_LOCALE_NUMERIC
371
372     PERL_UNUSED_ARG(newnum);
373
374 #else
375
376     /* Called after each libc setlocale() call affecting LC_NUMERIC, to tell
377      * core Perl this and that 'newnum' is the name of the new locale.
378      * It installs this locale as the current underlying default.
379      *
380      * The default locale and the C locale can be toggled between by use of the
381      * set_numeric_underlying() and set_numeric_standard() functions, which
382      * should probably not be called directly, but only via macros like
383      * SET_NUMERIC_STANDARD() in perl.h.
384      *
385      * The toggling is necessary mainly so that a non-dot radix decimal point
386      * character can be output, while allowing internal calculations to use a
387      * dot.
388      *
389      * This sets several interpreter-level variables:
390      * PL_numeric_name  The underlying locale's name: a copy of 'newnum'
391      * PL_numeric_underlying  A boolean indicating if the toggled state is such
392      *                  that the current locale is the program's underlying
393      *                  locale
394      * PL_numeric_standard An int indicating if the toggled state is such
395      *                  that the current locale is the C locale.  If non-zero,
396      *                  it is in C; if > 1, it means it may not be toggled away
397      *                  from C.
398      * Note that both of the last two variables can be true at the same time,
399      * if the underlying locale is C.  (Toggling is a no-op under these
400      * circumstances.)
401      *
402      * Any code changing the locale (outside this file) should use
403      * POSIX::setlocale, which calls this function.  Therefore this function
404      * should be called directly only from this file and from
405      * POSIX::setlocale() */
406
407     char *save_newnum;
408
409     if (! newnum) {
410         Safefree(PL_numeric_name);
411         PL_numeric_name = NULL;
412         PL_numeric_standard = TRUE;
413         PL_numeric_underlying = TRUE;
414         return;
415     }
416
417     save_newnum = stdize_locale(savepv(newnum));
418
419     PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
420     PL_numeric_underlying = TRUE;
421
422     if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
423         Safefree(PL_numeric_name);
424         PL_numeric_name = save_newnum;
425     }
426     else {
427         Safefree(save_newnum);
428     }
429
430     /* Keep LC_NUMERIC in the C locale.  This is for XS modules, so they don't
431      * have to worry about the radix being a non-dot.  (Core operations that
432      * need the underlying locale change to it temporarily). */
433     set_numeric_standard();
434
435 #endif /* USE_LOCALE_NUMERIC */
436
437 }
438
439 void
440 Perl_set_numeric_standard(pTHX)
441 {
442
443 #ifdef USE_LOCALE_NUMERIC
444
445     /* Toggle the LC_NUMERIC locale to C.  Most code should use the macros like
446      * SET_NUMERIC_STANDARD() in perl.h instead of calling this directly.  The
447      * macro avoids calling this routine if toggling isn't necessary according
448      * to our records (which could be wrong if some XS code has changed the
449      * locale behind our back) */
450
451     do_setlocale_c(LC_NUMERIC, "C");
452     PL_numeric_standard = TRUE;
453     PL_numeric_underlying = isNAME_C_OR_POSIX(PL_numeric_name);
454     set_numeric_radix(0);
455
456 #  ifdef DEBUGGING
457
458     if (DEBUG_L_TEST || debug_initialization) {
459         PerlIO_printf(Perl_debug_log,
460                           "LC_NUMERIC locale now is standard C\n");
461     }
462
463 #  endif
464 #endif /* USE_LOCALE_NUMERIC */
465
466 }
467
468 void
469 Perl_set_numeric_underlying(pTHX)
470 {
471
472 #ifdef USE_LOCALE_NUMERIC
473
474     /* Toggle the LC_NUMERIC locale to the current underlying default.  Most
475      * code should use the macros like SET_NUMERIC_UNDERLYING() in perl.h
476      * instead of calling this directly.  The macro avoids calling this routine
477      * if toggling isn't necessary according to our records (which could be
478      * wrong if some XS code has changed the locale behind our back) */
479
480     do_setlocale_c(LC_NUMERIC, PL_numeric_name);
481     PL_numeric_standard = isNAME_C_OR_POSIX(PL_numeric_name);
482     PL_numeric_underlying = TRUE;
483     set_numeric_radix(1);
484
485 #  ifdef DEBUGGING
486
487     if (DEBUG_L_TEST || debug_initialization) {
488         PerlIO_printf(Perl_debug_log,
489                           "LC_NUMERIC locale now is %s\n",
490                           PL_numeric_name);
491     }
492
493 #  endif
494 #endif /* USE_LOCALE_NUMERIC */
495
496 }
497
498 /*
499  * Set up for a new ctype locale.
500  */
501 STATIC void
502 S_new_ctype(pTHX_ const char *newctype)
503 {
504
505 #ifndef USE_LOCALE_CTYPE
506
507     PERL_ARGS_ASSERT_NEW_CTYPE;
508     PERL_UNUSED_ARG(newctype);
509     PERL_UNUSED_CONTEXT;
510
511 #else
512
513     /* Called after each libc setlocale() call affecting LC_CTYPE, to tell
514      * core Perl this and that 'newctype' is the name of the new locale.
515      *
516      * This function sets up the folding arrays for all 256 bytes, assuming
517      * that tofold() is tolc() since fold case is not a concept in POSIX,
518      *
519      * Any code changing the locale (outside this file) should use
520      * POSIX::setlocale, which calls this function.  Therefore this function
521      * should be called directly only from this file and from
522      * POSIX::setlocale() */
523
524     dVAR;
525     UV i;
526
527     PERL_ARGS_ASSERT_NEW_CTYPE;
528
529     /* We will replace any bad locale warning with 1) nothing if the new one is
530      * ok; or 2) a new warning for the bad new locale */
531     if (PL_warn_locale) {
532         SvREFCNT_dec_NN(PL_warn_locale);
533         PL_warn_locale = NULL;
534     }
535
536     PL_in_utf8_CTYPE_locale = _is_cur_LC_category_utf8(LC_CTYPE);
537
538     /* A UTF-8 locale gets standard rules.  But note that code still has to
539      * handle this specially because of the three problematic code points */
540     if (PL_in_utf8_CTYPE_locale) {
541         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
542     }
543     else {
544         /* Assume enough space for every character being bad.  4 spaces each
545          * for the 94 printable characters that are output like "'x' "; and 5
546          * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
547          * NUL */
548         char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ];
549
550         /* Don't check for problems if we are suppressing the warnings */
551         bool check_for_problems = ckWARN_d(WARN_LOCALE)
552                                || UNLIKELY(DEBUG_L_TEST);
553         bool multi_byte_locale = FALSE;     /* Assume is a single-byte locale
554                                                to start */
555         unsigned int bad_count = 0;         /* Count of bad characters */
556
557         for (i = 0; i < 256; i++) {
558             if (isupper(i))
559                 PL_fold_locale[i] = (U8) tolower(i);
560             else if (islower(i))
561                 PL_fold_locale[i] = (U8) toupper(i);
562             else
563                 PL_fold_locale[i] = (U8) i;
564
565             /* If checking for locale problems, see if the native ASCII-range
566              * printables plus \n and \t are in their expected categories in
567              * the new locale.  If not, this could mean big trouble, upending
568              * Perl's and most programs' assumptions, like having a
569              * metacharacter with special meaning become a \w.  Fortunately,
570              * it's very rare to find locales that aren't supersets of ASCII
571              * nowadays.  It isn't a problem for most controls to be changed
572              * into something else; we check only \n and \t, though perhaps \r
573              * could be an issue as well. */
574             if (    check_for_problems
575                 && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
576             {
577                 if (   cBOOL(isalnum(i)) != cBOOL(isALPHANUMERIC(i))
578                     || cBOOL(isalpha(i)) != cBOOL(isALPHA_A(i))
579                     || cBOOL(isdigit(i)) != cBOOL(isDIGIT_A(i))
580                     || cBOOL(isgraph(i)) != cBOOL(isGRAPH_A(i))
581                     || cBOOL(islower(i)) != cBOOL(isLOWER_A(i))
582                     || cBOOL(isprint(i)) != cBOOL(isPRINT_A(i))
583                     || cBOOL(ispunct(i)) != cBOOL(isPUNCT_A(i))
584                     || cBOOL(isspace(i)) != cBOOL(isSPACE_A(i))
585                     || cBOOL(isupper(i)) != cBOOL(isUPPER_A(i))
586                     || cBOOL(isxdigit(i))!= cBOOL(isXDIGIT_A(i))
587                     || tolower(i) != (int) toLOWER_A(i)
588                     || toupper(i) != (int) toUPPER_A(i)
589                     || (i == '\n' && ! isCNTRL_LC(i)))
590                 {
591                     if (bad_count) {    /* Separate multiple entries with a
592                                            blank */
593                         bad_chars_list[bad_count++] = ' ';
594                     }
595                     bad_chars_list[bad_count++] = '\'';
596                     if (isPRINT_A(i)) {
597                         bad_chars_list[bad_count++] = (char) i;
598                     }
599                     else {
600                         bad_chars_list[bad_count++] = '\\';
601                         if (i == '\n') {
602                             bad_chars_list[bad_count++] = 'n';
603                         }
604                         else {
605                             assert(i == '\t');
606                             bad_chars_list[bad_count++] = 't';
607                         }
608                     }
609                     bad_chars_list[bad_count++] = '\'';
610                     bad_chars_list[bad_count] = '\0';
611                 }
612             }
613         }
614
615 #  ifdef MB_CUR_MAX
616
617         /* We only handle single-byte locales (outside of UTF-8 ones; so if
618          * this locale requires more than one byte, there are going to be
619          * problems. */
620         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
621                  "%s:%d: check_for_problems=%d, MB_CUR_MAX=%d\n",
622                  __FILE__, __LINE__, check_for_problems, (int) MB_CUR_MAX));
623
624         if (check_for_problems && MB_CUR_MAX > 1
625
626                /* Some platforms return MB_CUR_MAX > 1 for even the "C"
627                 * locale.  Just assume that the implementation for them (plus
628                 * for POSIX) is correct and the > 1 value is spurious.  (Since
629                 * these are specially handled to never be considered UTF-8
630                 * locales, as long as this is the only problem, everything
631                 * should work fine */
632             && strNE(newctype, "C") && strNE(newctype, "POSIX"))
633         {
634             multi_byte_locale = TRUE;
635         }
636
637 #  endif
638
639         if (bad_count || multi_byte_locale) {
640             PL_warn_locale = Perl_newSVpvf(aTHX_
641                              "Locale '%s' may not work well.%s%s%s\n",
642                              newctype,
643                              (multi_byte_locale)
644                               ? "  Some characters in it are not recognized by"
645                                 " Perl."
646                               : "",
647                              (bad_count)
648                               ? "\nThe following characters (and maybe others)"
649                                 " may not have the same meaning as the Perl"
650                                 " program expects:\n"
651                               : "",
652                              (bad_count)
653                               ? bad_chars_list
654                               : ""
655                             );
656             /* If we are actually in the scope of the locale or are debugging,
657              * output the message now.  If not in that scope, we save the
658              * message to be output at the first operation using this locale,
659              * if that actually happens.  Most programs don't use locales, so
660              * they are immune to bad ones.  */
661             if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
662
663                 /* We have to save 'newctype' because the setlocale() just
664                  * below may destroy it.  The next setlocale() further down
665                  * should restore it properly so that the intermediate change
666                  * here is transparent to this function's caller */
667                 const char * const badlocale = savepv(newctype);
668
669                 do_setlocale_c(LC_CTYPE, "C");
670
671                 /* The '0' below suppresses a bogus gcc compiler warning */
672                 Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale), 0);
673
674                 do_setlocale_c(LC_CTYPE, badlocale);
675                 Safefree(badlocale);
676
677                 if (IN_LC(LC_CTYPE)) {
678                     SvREFCNT_dec_NN(PL_warn_locale);
679                     PL_warn_locale = NULL;
680                 }
681             }
682         }
683     }
684
685 #endif /* USE_LOCALE_CTYPE */
686
687 }
688
689 void
690 Perl__warn_problematic_locale()
691 {
692
693 #ifdef USE_LOCALE_CTYPE
694
695     dTHX;
696
697     /* Internal-to-core function that outputs the message in PL_warn_locale,
698      * and then NULLS it.  Should be called only through the macro
699      * _CHECK_AND_WARN_PROBLEMATIC_LOCALE */
700
701     if (PL_warn_locale) {
702         Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
703                              SvPVX(PL_warn_locale),
704                              0 /* dummy to avoid compiler warning */ );
705         SvREFCNT_dec_NN(PL_warn_locale);
706         PL_warn_locale = NULL;
707     }
708
709 #endif
710
711 }
712
713 STATIC void
714 S_new_collate(pTHX_ const char *newcoll)
715 {
716
717 #ifndef USE_LOCALE_COLLATE
718
719     PERL_UNUSED_ARG(newcoll);
720     PERL_UNUSED_CONTEXT;
721
722 #else
723
724     /* Called after each libc setlocale() call affecting LC_COLLATE, to tell
725      * core Perl this and that 'newcoll' is the name of the new locale.
726      *
727      * The design of locale collation is that every locale change is given an
728      * index 'PL_collation_ix'.  The first time a string particpates in an
729      * operation that requires collation while locale collation is active, it
730      * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()).  That
731      * magic includes the collation index, and the transformation of the string
732      * by strxfrm(), q.v.  That transformation is used when doing comparisons,
733      * instead of the string itself.  If a string changes, the magic is
734      * cleared.  The next time the locale changes, the index is incremented,
735      * and so we know during a comparison that the transformation is not
736      * necessarily still valid, and so is recomputed.  Note that if the locale
737      * changes enough times, the index could wrap (a U32), and it is possible
738      * that a transformation would improperly be considered valid, leading to
739      * an unlikely bug */
740
741     if (! newcoll) {
742         if (PL_collation_name) {
743             ++PL_collation_ix;
744             Safefree(PL_collation_name);
745             PL_collation_name = NULL;
746         }
747         PL_collation_standard = TRUE;
748       is_standard_collation:
749         PL_collxfrm_base = 0;
750         PL_collxfrm_mult = 2;
751         PL_in_utf8_COLLATE_locale = FALSE;
752         PL_strxfrm_NUL_replacement = '\0';
753         PL_strxfrm_max_cp = 0;
754         return;
755     }
756
757     /* If this is not the same locale as currently, set the new one up */
758     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
759         ++PL_collation_ix;
760         Safefree(PL_collation_name);
761         PL_collation_name = stdize_locale(savepv(newcoll));
762         PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
763         if (PL_collation_standard) {
764             goto is_standard_collation;
765         }
766
767         PL_in_utf8_COLLATE_locale = _is_cur_LC_category_utf8(LC_COLLATE);
768         PL_strxfrm_NUL_replacement = '\0';
769         PL_strxfrm_max_cp = 0;
770
771         /* A locale collation definition includes primary, secondary, tertiary,
772          * etc. weights for each character.  To sort, the primary weights are
773          * used, and only if they compare equal, then the secondary weights are
774          * used, and only if they compare equal, then the tertiary, etc.
775          *
776          * strxfrm() works by taking the input string, say ABC, and creating an
777          * output transformed string consisting of first the primary weights,
778          * A¹B¹C¹ followed by the secondary ones, A²B²C²; and then the
779          * tertiary, etc, yielding A¹B¹C¹ A²B²C² A³B³C³ ....  Some characters
780          * may not have weights at every level.  In our example, let's say B
781          * doesn't have a tertiary weight, and A doesn't have a secondary
782          * weight.  The constructed string is then going to be
783          *  A¹B¹C¹ B²C² A³C³ ....
784          * This has the desired effect that strcmp() will look at the secondary
785          * or tertiary weights only if the strings compare equal at all higher
786          * priority weights.  The spaces shown here, like in
787          *  "A¹B¹C¹ A²B²C² "
788          * are not just for readability.  In the general case, these must
789          * actually be bytes, which we will call here 'separator weights'; and
790          * they must be smaller than any other weight value, but since these
791          * are C strings, only the terminating one can be a NUL (some
792          * implementations may include a non-NUL separator weight just before
793          * the NUL).  Implementations tend to reserve 01 for the separator
794          * weights.  They are needed so that a shorter string's secondary
795          * weights won't be misconstrued as primary weights of a longer string,
796          * etc.  By making them smaller than any other weight, the shorter
797          * string will sort first.  (Actually, if all secondary weights are
798          * smaller than all primary ones, there is no need for a separator
799          * weight between those two levels, etc.)
800          *
801          * The length of the transformed string is roughly a linear function of
802          * the input string.  It's not exactly linear because some characters
803          * don't have weights at all levels.  When we call strxfrm() we have to
804          * allocate some memory to hold the transformed string.  The
805          * calculations below try to find coefficients 'm' and 'b' for this
806          * locale so that m*x + b equals how much space we need, given the size
807          * of the input string in 'x'.  If we calculate too small, we increase
808          * the size as needed, and call strxfrm() again, but it is better to
809          * get it right the first time to avoid wasted expensive string
810          * transformations. */
811
812         {
813             /* We use the string below to find how long the tranformation of it
814              * is.  Almost all locales are supersets of ASCII, or at least the
815              * ASCII letters.  We use all of them, half upper half lower,
816              * because if we used fewer, we might hit just the ones that are
817              * outliers in a particular locale.  Most of the strings being
818              * collated will contain a preponderance of letters, and even if
819              * they are above-ASCII, they are likely to have the same number of
820              * weight levels as the ASCII ones.  It turns out that digits tend
821              * to have fewer levels, and some punctuation has more, but those
822              * are relatively sparse in text, and khw believes this gives a
823              * reasonable result, but it could be changed if experience so
824              * dictates. */
825             const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
826             char * x_longer;        /* Transformed 'longer' */
827             Size_t x_len_longer;    /* Length of 'x_longer' */
828
829             char * x_shorter;   /* We also transform a substring of 'longer' */
830             Size_t x_len_shorter;
831
832             /* _mem_collxfrm() is used get the transformation (though here we
833              * are interested only in its length).  It is used because it has
834              * the intelligence to handle all cases, but to work, it needs some
835              * values of 'm' and 'b' to get it started.  For the purposes of
836              * this calculation we use a very conservative estimate of 'm' and
837              * 'b'.  This assumes a weight can be multiple bytes, enough to
838              * hold any UV on the platform, and there are 5 levels, 4 weight
839              * bytes, and a trailing NUL.  */
840             PL_collxfrm_base = 5;
841             PL_collxfrm_mult = 5 * sizeof(UV);
842
843             /* Find out how long the transformation really is */
844             x_longer = _mem_collxfrm(longer,
845                                      sizeof(longer) - 1,
846                                      &x_len_longer,
847
848                                      /* We avoid converting to UTF-8 in the
849                                       * called function by telling it the
850                                       * string is in UTF-8 if the locale is a
851                                       * UTF-8 one.  Since the string passed
852                                       * here is invariant under UTF-8, we can
853                                       * claim it's UTF-8 even though it isn't.
854                                       * */
855                                      PL_in_utf8_COLLATE_locale);
856             Safefree(x_longer);
857
858             /* Find out how long the transformation of a substring of 'longer'
859              * is.  Together the lengths of these transformations are
860              * sufficient to calculate 'm' and 'b'.  The substring is all of
861              * 'longer' except the first character.  This minimizes the chances
862              * of being swayed by outliers */
863             x_shorter = _mem_collxfrm(longer + 1,
864                                       sizeof(longer) - 2,
865                                       &x_len_shorter,
866                                       PL_in_utf8_COLLATE_locale);
867             Safefree(x_shorter);
868
869             /* If the results are nonsensical for this simple test, the whole
870              * locale definition is suspect.  Mark it so that locale collation
871              * is not active at all for it.  XXX Should we warn? */
872             if (   x_len_shorter == 0
873                 || x_len_longer == 0
874                 || x_len_shorter >= x_len_longer)
875             {
876                 PL_collxfrm_mult = 0;
877                 PL_collxfrm_base = 0;
878             }
879             else {
880                 SSize_t base;       /* Temporary */
881
882                 /* We have both:    m * strlen(longer)  + b = x_len_longer
883                  *                  m * strlen(shorter) + b = x_len_shorter;
884                  * subtracting yields:
885                  *          m * (strlen(longer) - strlen(shorter))
886                  *                             = x_len_longer - x_len_shorter
887                  * But we have set things up so that 'shorter' is 1 byte smaller
888                  * than 'longer'.  Hence:
889                  *          m = x_len_longer - x_len_shorter
890                  *
891                  * But if something went wrong, make sure the multiplier is at
892                  * least 1.
893                  */
894                 if (x_len_longer > x_len_shorter) {
895                     PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
896                 }
897                 else {
898                     PL_collxfrm_mult = 1;
899                 }
900
901                 /*     mx + b = len
902                  * so:      b = len - mx
903                  * but in case something has gone wrong, make sure it is
904                  * non-negative */
905                 base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
906                 if (base < 0) {
907                     base = 0;
908                 }
909
910                 /* Add 1 for the trailing NUL */
911                 PL_collxfrm_base = base + 1;
912             }
913
914 #  ifdef DEBUGGING
915
916             if (DEBUG_L_TEST || debug_initialization) {
917                 PerlIO_printf(Perl_debug_log,
918                     "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, "
919                     "x_len_longer=%zu,"
920                     " collate multipler=%zu, collate base=%zu\n",
921                     __FILE__, __LINE__,
922                     PL_in_utf8_COLLATE_locale,
923                     x_len_shorter, x_len_longer,
924                     PL_collxfrm_mult, PL_collxfrm_base);
925             }
926 #  endif
927
928         }
929     }
930
931 #endif /* USE_LOCALE_COLLATE */
932
933 }
934
935 #ifdef WIN32
936
937 STATIC char *
938 S_win32_setlocale(pTHX_ int category, const char* locale)
939 {
940     /* This, for Windows, emulates POSIX setlocale() behavior.  There is no
941      * difference between the two unless the input locale is "", which normally
942      * means on Windows to get the machine default, which is set via the
943      * computer's "Regional and Language Options" (or its current equivalent).
944      * In POSIX, it instead means to find the locale from the user's
945      * environment.  This routine changes the Windows behavior to first look in
946      * the environment, and, if anything is found, use that instead of going to
947      * the machine default.  If there is no environment override, the machine
948      * default is used, by calling the real setlocale() with "".
949      *
950      * The POSIX behavior is to use the LC_ALL variable if set; otherwise to
951      * use the particular category's variable if set; otherwise to use the LANG
952      * variable. */
953
954     bool override_LC_ALL = FALSE;
955     char * result;
956     unsigned int i;
957
958     if (locale && strEQ(locale, "")) {
959
960 #  ifdef LC_ALL
961
962         locale = PerlEnv_getenv("LC_ALL");
963         if (! locale) {
964             if (category ==  LC_ALL) {
965                 override_LC_ALL = TRUE;
966             }
967             else {
968
969 #  endif
970
971                 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
972                     if (category == categories[i]) {
973                         locale = PerlEnv_getenv(category_names[i]);
974                         goto found_locale;
975                     }
976                 }
977
978                 locale = PerlEnv_getenv("LANG");
979                 if (! locale) {
980                     locale = "";
981                 }
982
983               found_locale: ;
984
985 #  ifdef LC_ALL
986
987             }
988         }
989
990 #  endif
991
992     }
993
994     result = setlocale(category, locale);
995     DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
996                             setlocale_debug_string(category, locale, result)));
997
998     if (! override_LC_ALL)  {
999         return result;
1000     }
1001
1002     /* Here the input category was LC_ALL, and we have set it to what is in the
1003      * LANG variable or the system default if there is no LANG.  But these have
1004      * lower priority than the other LC_foo variables, so override it for each
1005      * one that is set.  (If they are set to "", it means to use the same thing
1006      * we just set LC_ALL to, so can skip) */
1007
1008     for (i = 0; i < LC_ALL_INDEX; i++) {
1009         result = PerlEnv_getenv(category_names[i]);
1010         if (result && strNE(result, "")) {
1011             setlocale(categories[i], result);
1012             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
1013                 __FILE__, __LINE__,
1014                 setlocale_debug_string(categories[i], result, "not captured")));
1015         }
1016     }
1017
1018     result = setlocale(LC_ALL, NULL);
1019     DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
1020                                __FILE__, __LINE__,
1021                                setlocale_debug_string(LC_ALL, NULL, result)));
1022
1023     return result;
1024 }
1025
1026 #endif
1027
1028 char *
1029 Perl_setlocale(int category, const char * locale)
1030 {
1031     /* This wraps POSIX::setlocale() */
1032
1033     char * retval;
1034     char * newlocale;
1035     dTHX;
1036
1037 #ifdef USE_LOCALE_NUMERIC
1038
1039     /* A NULL locale means only query what the current one is.  We have the
1040      * LC_NUMERIC name saved, because we are normally switched into the C
1041      * locale for it.  For an LC_ALL query, switch back to get the correct
1042      * results.  All other categories don't require special handling */
1043     if (locale == NULL) {
1044         if (category == LC_NUMERIC) {
1045             return savepv(PL_numeric_name);
1046         }
1047
1048 #  ifdef LC_ALL
1049
1050         else if (category == LC_ALL) {
1051             SET_NUMERIC_UNDERLYING();
1052         }
1053
1054 #  endif
1055
1056     }
1057
1058 #endif
1059
1060     /* Save retval since subsequent setlocale() calls may overwrite it. */
1061     retval = savepv(do_setlocale_r(category, locale));
1062
1063     DEBUG_L(PerlIO_printf(Perl_debug_log,
1064         "%s:%d: %s\n", __FILE__, __LINE__,
1065             setlocale_debug_string(category, locale, retval)));
1066     if (! retval) {
1067         /* Should never happen that a query would return an error, but be
1068          * sure and reset to C locale */
1069         if (locale == 0) {
1070             SET_NUMERIC_STANDARD();
1071         }
1072
1073         return NULL;
1074     }
1075
1076     /* If locale == NULL, we are just querying the state, but may have switched
1077      * to NUMERIC_UNDERLYING.  Switch back before returning. */
1078     if (locale == NULL) {
1079         SET_NUMERIC_STANDARD();
1080         return retval;
1081     }
1082
1083     /* Now that have switched locales, we have to update our records to
1084      * correspond. */
1085
1086     switch (category) {
1087
1088 #ifdef USE_LOCALE_CTYPE
1089
1090         case LC_CTYPE:
1091             new_ctype(retval);
1092             break;
1093
1094 #endif
1095 #ifdef USE_LOCALE_COLLATE
1096
1097         case LC_COLLATE:
1098             new_collate(retval);
1099             break;
1100
1101 #endif
1102 #ifdef USE_LOCALE_NUMERIC
1103
1104         case LC_NUMERIC:
1105             new_numeric(retval);
1106             break;
1107
1108 #endif
1109 #ifdef LC_ALL
1110
1111         case LC_ALL:
1112
1113             /* LC_ALL updates all the things we care about.  The values may not
1114              * be the same as 'retval', as the locale "" may have set things
1115              * individually */
1116
1117 #  ifdef USE_LOCALE_CTYPE
1118
1119             newlocale = do_setlocale_c(LC_CTYPE, NULL);
1120             new_ctype(newlocale);
1121
1122 #  endif /* USE_LOCALE_CTYPE */
1123 #  ifdef USE_LOCALE_COLLATE
1124
1125             newlocale = do_setlocale_c(LC_COLLATE, NULL);
1126             new_collate(newlocale);
1127
1128 #  endif
1129 #  ifdef USE_LOCALE_NUMERIC
1130
1131             newlocale = do_setlocale_c(LC_NUMERIC, NULL);
1132             new_numeric(newlocale);
1133
1134 #  endif /* USE_LOCALE_NUMERIC */
1135 #endif /* LC_ALL */
1136
1137         default:
1138             break;
1139     }
1140
1141     return retval;
1142
1143
1144 }
1145
1146 PERL_STATIC_INLINE const char *
1147 S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t offset)
1148 {
1149     /* Copy the NUL-terminated 'string' to 'buf' + 'offset'.  'buf' has size 'buf_size',
1150      * growing it if necessary */
1151
1152     const Size_t string_size = strlen(string) + offset + 1;
1153
1154     PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
1155
1156     if (*buf_size == 0) {
1157         Newx(*buf, string_size, char);
1158         *buf_size = string_size;
1159     }
1160     else if (string_size > *buf_size) {
1161         Renew(*buf, string_size, char);
1162         *buf_size = string_size;
1163     }
1164
1165     Copy(string, *buf + offset, string_size - offset, char);
1166     return *buf;
1167 }
1168
1169 /*
1170
1171 =head1 Locale-related functions and macros
1172
1173 =for apidoc Perl_langinfo
1174
1175 This is an (almost ª) drop-in replacement for the system C<L<nl_langinfo(3)>>,
1176 taking the same C<item> parameter values, and returning the same information.
1177 But it is more thread-safe than regular C<nl_langinfo()>, and hides the quirks
1178 of Perl's locale handling from your code, and can be used on systems that lack
1179 a native C<nl_langinfo>.
1180
1181 Expanding on these:
1182
1183 =over
1184
1185 =item *
1186
1187 It delivers the correct results for the C<RADIXCHAR> and C<THOUSESEP> items,
1188 without you having to write extra code.  The reason for the extra code would be
1189 because these are from the C<LC_NUMERIC> locale category, which is normally
1190 kept set to the C locale by Perl, no matter what the underlying locale is
1191 supposed to be, and so to get the expected results, you have to temporarily
1192 toggle into the underlying locale, and later toggle back.  (You could use
1193 plain C<nl_langinfo> and C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this
1194 but then you wouldn't get the other advantages of C<Perl_langinfo()>; not
1195 keeping C<LC_NUMERIC> in the C locale would break a lot of CPAN, which is
1196 expecting the radix (decimal point) character to be a dot.)
1197
1198 =item *
1199
1200 Depending on C<item>, it works on systems that don't have C<nl_langinfo>, hence
1201 makes your code more portable.  Of the fifty-some possible items specified by
1202 the POSIX 2008 standard,
1203 L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
1204 only two are completely unimplemented.  It uses various techniques to recover
1205 the other items, including calling C<L<localeconv(3)>>, and C<L<strftime(3)>>,
1206 both of which are specified in C89, so should be always be available.  Later
1207 C<strftime()> versions have additional capabilities; C<""> is returned for
1208 those not available on your system.
1209
1210 The details for those items which may differ from what this emulation returns
1211 and what a native C<nl_langinfo()> would return are:
1212
1213 =over
1214
1215 =item C<CODESET>
1216
1217 =item C<ERA>
1218
1219 Unimplemented, so returns C<"">.
1220
1221 =item C<YESEXPR>
1222
1223 =item C<YESSTR>
1224
1225 =item C<NOEXPR>
1226
1227 =item C<NOSTR>
1228
1229 Only the values for English are returned.  C<YESSTR> and C<NOSTR> have been
1230 removed from POSIX 2008, and are retained for backwards compatibility.  Your
1231 platform's C<nl_langinfo> may not support them.
1232
1233 =item C<D_FMT>
1234
1235 Always evaluates to C<%x>, the locale's appropriate date representation.
1236
1237 =item C<T_FMT>
1238
1239 Always evaluates to C<%X>, the locale's appropriate time representation.
1240
1241 =item C<D_T_FMT>
1242
1243 Always evaluates to C<%c>, the locale's appropriate date and time
1244 representation.
1245
1246 =item C<CRNCYSTR>
1247
1248 The return may be incorrect for those rare locales where the currency symbol
1249 replaces the radix character.
1250 Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
1251 to work differently.
1252
1253 =item C<ALT_DIGITS>
1254
1255 Currently this gives the same results as Linux does.
1256 Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
1257 to work differently.
1258
1259 =item C<ERA_D_FMT>
1260
1261 =item C<ERA_T_FMT>
1262
1263 =item C<ERA_D_T_FMT>
1264
1265 =item C<T_FMT_AMPM>
1266
1267 These are derived by using C<strftime()>, and not all versions of that function
1268 know about them.  C<""> is returned for these on such systems.
1269
1270 =back
1271
1272 When using C<Perl_langinfo> on systems that don't have a native
1273 C<nl_langinfo()>, you must
1274
1275  #include "perl_langinfo.h"
1276
1277 before the C<perl.h> C<#include>.  You can replace your C<langinfo.h>
1278 C<#include> with this one.  (Doing it this way keeps out the symbols that plain
1279 C<langinfo.h> imports into the namespace for code that doesn't need it.)
1280
1281 You also should not use the bare C<langinfo.h> item names, but should preface
1282 them with C<PERL_>, so use C<PERL_RADIXCHAR> instead of plain C<RADIXCHAR>.
1283 The C<PERL_I<foo>> versions will also work for this function on systems that do
1284 have a native C<nl_langinfo>.
1285
1286 =item *
1287
1288 It is thread-friendly, returning its result in a buffer that won't be
1289 overwritten by another thread, so you don't have to code for that possibility.
1290 The buffer can be overwritten by the next call to C<nl_langinfo> or
1291 C<Perl_langinfo> in the same thread.
1292
1293 =item *
1294
1295 ª It returns S<C<const char *>>, whereas plain C<nl_langinfo()> returns S<C<char
1296 *>>, but you are (only by documentation) forbidden to write into the buffer.
1297 By declaring this C<const>, the compiler enforces this restriction.  The extra
1298 C<const> is why this isn't an unequivocal drop-in replacement for
1299 C<nl_langinfo>.
1300
1301 =back
1302
1303 The original impetus for C<Perl_langinfo()> was so that code that needs to
1304 find out the current currency symbol, floating point radix character, or digit
1305 grouping separator can use, on all systems, the simpler and more
1306 thread-friendly C<nl_langinfo> API instead of C<L<localeconv(3)>> which is a
1307 pain to make thread-friendly.  For other fields returned by C<localeconv>, it
1308 is better to use the methods given in L<perlcall> to call
1309 L<C<POSIX::localeconv()>|POSIX/localeconv>, which is thread-friendly.
1310
1311 =cut
1312
1313 */
1314
1315 const char *
1316 #ifdef HAS_NL_LANGINFO
1317 Perl_langinfo(const nl_item item)
1318 #else
1319 Perl_langinfo(const int item)
1320 #endif
1321 {
1322     return my_nl_langinfo(item, TRUE);
1323 }
1324
1325 const char *
1326 #ifdef HAS_NL_LANGINFO
1327 S_my_nl_langinfo(const nl_item item, bool toggle)
1328 #else
1329 S_my_nl_langinfo(const int item, bool toggle)
1330 #endif
1331 {
1332     dTHX;
1333
1334 #if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available.  */
1335 #if   ! defined(HAS_POSIX_2008_LOCALE)
1336
1337     /* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
1338      * for those items dependent on it.  This must be copied to a buffer before
1339      * switching back, as some systems destroy the buffer when setlocale() is
1340      * called */
1341
1342     LOCALE_LOCK;
1343
1344     if (toggle) {
1345         if (item == PERL_RADIXCHAR || item == PERL_THOUSEP) {
1346             do_setlocale_c(LC_NUMERIC, PL_numeric_name);
1347         }
1348         else {
1349             toggle = FALSE;
1350         }
1351     }
1352
1353     save_to_buffer(nl_langinfo(item), &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
1354
1355     if (toggle) {
1356         do_setlocale_c(LC_NUMERIC, "C");
1357     }
1358
1359     LOCALE_UNLOCK;
1360
1361 #  else /* Use nl_langinfo_l(), avoiding both a mutex and changing the locale */
1362
1363     bool do_free = FALSE;
1364     locale_t cur = uselocale((locale_t) 0);
1365
1366     if (cur == LC_GLOBAL_LOCALE) {
1367         cur = duplocale(LC_GLOBAL_LOCALE);
1368         do_free = TRUE;
1369     }
1370
1371     if (   toggle
1372         && (item == PERL_RADIXCHAR || item == PERL_THOUSEP))
1373     {
1374         cur = newlocale(LC_NUMERIC_MASK, PL_numeric_name, cur);
1375         do_free = TRUE;
1376     }
1377
1378     save_to_buffer(nl_langinfo_l(item, cur),
1379                    &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
1380     if (do_free) {
1381         freelocale(cur);
1382     }
1383
1384 #  endif
1385
1386     if (strEQ(PL_langinfo_buf, "")) {
1387         if (item == PERL_YESSTR) {
1388             return "yes";
1389         }
1390         if (item == PERL_NOSTR) {
1391             return "no";
1392         }
1393     }
1394
1395     return PL_langinfo_buf;
1396
1397 #else   /* Below, emulate nl_langinfo as best we can */
1398 #  ifdef HAS_LOCALECONV
1399
1400     const struct lconv* lc;
1401
1402 #  endif
1403 #  ifdef HAS_STRFTIME
1404
1405     struct tm tm;
1406     bool return_format = FALSE; /* Return the %format, not the value */
1407     const char * format;
1408
1409 #  endif
1410
1411     /* We copy the results to a per-thread buffer, even if not multi-threaded.
1412      * This is in part to simplify this code, and partly because we need a
1413      * buffer anyway for strftime(), and partly because a call of localeconv()
1414      * could otherwise wipe out the buffer, and the programmer would not be
1415      * expecting this, as this is a nl_langinfo() substitute after all, so s/he
1416      * might be thinking their localeconv() is safe until another localeconv()
1417      * call. */
1418
1419     switch (item) {
1420         Size_t len;
1421         const char * retval;
1422
1423         /* These 2 are unimplemented */
1424         case PERL_CODESET:
1425         case PERL_ERA:          /* For use with strftime() %E modifier */
1426
1427         default:
1428             return "";
1429
1430         /* We use only an English set, since we don't know any more */
1431         case PERL_YESEXPR:   return "^[+1yY]";
1432         case PERL_YESSTR:    return "yes";
1433         case PERL_NOEXPR:    return "^[-0nN]";
1434         case PERL_NOSTR:     return "no";
1435
1436 #  ifdef HAS_LOCALECONV
1437
1438         case PERL_CRNCYSTR:
1439
1440             LOCALE_LOCK;
1441
1442             /* We don't bother with localeconv_l() because any system that has
1443              * it is likely to also have nl_langinfo() */
1444
1445             lc = localeconv();
1446             if (! lc || ! lc->currency_symbol || strEQ("", lc->currency_symbol))
1447             {
1448                 LOCALE_UNLOCK;
1449                 return "";
1450             }
1451
1452             /* Leave the first spot empty to be filled in below */
1453             save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
1454                            &PL_langinfo_bufsize, 1);
1455             if (lc->mon_decimal_point && strEQ(lc->mon_decimal_point, ""))
1456             { /*  khw couldn't figure out how the localedef specifications
1457                   would show that the $ should replace the radix; this is
1458                   just a guess as to how it might work.*/
1459                 *PL_langinfo_buf = '.';
1460             }
1461             else if (lc->p_cs_precedes) {
1462                 *PL_langinfo_buf = '-';
1463             }
1464             else {
1465                 *PL_langinfo_buf = '+';
1466             }
1467
1468             LOCALE_UNLOCK;
1469             break;
1470
1471         case PERL_RADIXCHAR:
1472         case PERL_THOUSEP:
1473
1474             LOCALE_LOCK;
1475
1476             if (toggle) {
1477                 do_setlocale_c(LC_NUMERIC, PL_numeric_name);
1478             }
1479
1480             lc = localeconv();
1481             if (! lc) {
1482                 retval = "";
1483             }
1484             else {
1485                 retval = (item == PERL_RADIXCHAR)
1486                          ? lc->decimal_point
1487                          : lc->thousands_sep;
1488                 if (! retval) {
1489                     retval = "";
1490                 }
1491             }
1492
1493             save_to_buffer(retval, &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
1494
1495             if (toggle) {
1496                 do_setlocale_c(LC_NUMERIC, "C");
1497             }
1498
1499             LOCALE_UNLOCK;
1500
1501             break;
1502
1503 #  endif
1504 #  ifdef HAS_STRFTIME
1505
1506         /* These are defined by C89, so we assume that strftime supports them,
1507          * and so are returned unconditionally; they may not be what the locale
1508          * actually says, but should give good enough results for someone using
1509          * them as formats (as opposed to trying to parse them to figure out
1510          * what the locale says).  The other format items are actually tested to
1511          * verify they work on the platform */
1512         case PERL_D_FMT:         return "%x";
1513         case PERL_T_FMT:         return "%X";
1514         case PERL_D_T_FMT:       return "%c";
1515
1516         /* These formats are only available in later strfmtime's */
1517         case PERL_ERA_D_FMT: case PERL_ERA_T_FMT: case PERL_ERA_D_T_FMT:
1518         case PERL_T_FMT_AMPM:
1519
1520         /* The rest can be gotten from most versions of strftime(). */
1521         case PERL_ABDAY_1: case PERL_ABDAY_2: case PERL_ABDAY_3:
1522         case PERL_ABDAY_4: case PERL_ABDAY_5: case PERL_ABDAY_6:
1523         case PERL_ABDAY_7:
1524         case PERL_ALT_DIGITS:
1525         case PERL_AM_STR: case PERL_PM_STR:
1526         case PERL_ABMON_1: case PERL_ABMON_2: case PERL_ABMON_3:
1527         case PERL_ABMON_4: case PERL_ABMON_5: case PERL_ABMON_6:
1528         case PERL_ABMON_7: case PERL_ABMON_8: case PERL_ABMON_9:
1529         case PERL_ABMON_10: case PERL_ABMON_11: case PERL_ABMON_12:
1530         case PERL_DAY_1: case PERL_DAY_2: case PERL_DAY_3: case PERL_DAY_4:
1531         case PERL_DAY_5: case PERL_DAY_6: case PERL_DAY_7:
1532         case PERL_MON_1: case PERL_MON_2: case PERL_MON_3: case PERL_MON_4:
1533         case PERL_MON_5: case PERL_MON_6: case PERL_MON_7: case PERL_MON_8:
1534         case PERL_MON_9: case PERL_MON_10: case PERL_MON_11: case PERL_MON_12:
1535
1536             LOCALE_LOCK;
1537
1538             init_tm(&tm);   /* Precaution against core dumps */
1539             tm.tm_sec = 30;
1540             tm.tm_min = 30;
1541             tm.tm_hour = 6;
1542             tm.tm_year = 2017 - 1900;
1543             tm.tm_wday = 0;
1544             tm.tm_mon = 0;
1545             switch (item) {
1546                 default:
1547                     LOCALE_UNLOCK;
1548                     Perl_croak(aTHX_ "panic: %s: %d: switch case: %d problem",
1549                                              __FILE__, __LINE__, item);
1550                     NOT_REACHED; /* NOTREACHED */
1551
1552                 case PERL_PM_STR: tm.tm_hour = 18;
1553                 case PERL_AM_STR:
1554                     format = "%p";
1555                     break;
1556
1557                 case PERL_ABDAY_7: tm.tm_wday++;
1558                 case PERL_ABDAY_6: tm.tm_wday++;
1559                 case PERL_ABDAY_5: tm.tm_wday++;
1560                 case PERL_ABDAY_4: tm.tm_wday++;
1561                 case PERL_ABDAY_3: tm.tm_wday++;
1562                 case PERL_ABDAY_2: tm.tm_wday++;
1563                 case PERL_ABDAY_1:
1564                     format = "%a";
1565                     break;
1566
1567                 case PERL_DAY_7: tm.tm_wday++;
1568                 case PERL_DAY_6: tm.tm_wday++;
1569                 case PERL_DAY_5: tm.tm_wday++;
1570                 case PERL_DAY_4: tm.tm_wday++;
1571                 case PERL_DAY_3: tm.tm_wday++;
1572                 case PERL_DAY_2: tm.tm_wday++;
1573                 case PERL_DAY_1:
1574                     format = "%A";
1575                     break;
1576
1577                 case PERL_ABMON_12: tm.tm_mon++;
1578                 case PERL_ABMON_11: tm.tm_mon++;
1579                 case PERL_ABMON_10: tm.tm_mon++;
1580                 case PERL_ABMON_9: tm.tm_mon++;
1581                 case PERL_ABMON_8: tm.tm_mon++;
1582                 case PERL_ABMON_7: tm.tm_mon++;
1583                 case PERL_ABMON_6: tm.tm_mon++;
1584                 case PERL_ABMON_5: tm.tm_mon++;
1585                 case PERL_ABMON_4: tm.tm_mon++;
1586                 case PERL_ABMON_3: tm.tm_mon++;
1587                 case PERL_ABMON_2: tm.tm_mon++;
1588                 case PERL_ABMON_1:
1589                     format = "%b";
1590                     break;
1591
1592                 case PERL_MON_12: tm.tm_mon++;
1593                 case PERL_MON_11: tm.tm_mon++;
1594                 case PERL_MON_10: tm.tm_mon++;
1595                 case PERL_MON_9: tm.tm_mon++;
1596                 case PERL_MON_8: tm.tm_mon++;
1597                 case PERL_MON_7: tm.tm_mon++;
1598                 case PERL_MON_6: tm.tm_mon++;
1599                 case PERL_MON_5: tm.tm_mon++;
1600                 case PERL_MON_4: tm.tm_mon++;
1601                 case PERL_MON_3: tm.tm_mon++;
1602                 case PERL_MON_2: tm.tm_mon++;
1603                 case PERL_MON_1:
1604                     format = "%B";
1605                     break;
1606
1607                 case PERL_T_FMT_AMPM:
1608                     format = "%r";
1609                     return_format = TRUE;
1610                     break;
1611
1612                 case PERL_ERA_D_FMT:
1613                     format = "%Ex";
1614                     return_format = TRUE;
1615                     break;
1616
1617                 case PERL_ERA_T_FMT:
1618                     format = "%EX";
1619                     return_format = TRUE;
1620                     break;
1621
1622                 case PERL_ERA_D_T_FMT:
1623                     format = "%Ec";
1624                     return_format = TRUE;
1625                     break;
1626
1627                 case PERL_ALT_DIGITS:
1628                     tm.tm_wday = 0;
1629                     format = "%Ow";     /* Find the alternate digit for 0 */
1630                     break;
1631             }
1632
1633             /* We can't use my_strftime() because it doesn't look at tm_wday  */
1634             while (0 == strftime(PL_langinfo_buf, PL_langinfo_bufsize,
1635                                  format, &tm))
1636             {
1637                 /* A zero return means one of:
1638                  *  a)  there wasn't enough space in PL_langinfo_buf
1639                  *  b)  the format, like a plain %p, returns empty
1640                  *  c)  it was an illegal format, though some implementations of
1641                  *      strftime will just return the illegal format as a plain
1642                  *      character sequence.
1643                  *
1644                  *  To quickly test for case 'b)', try again but precede the
1645                  *  format with a plain character.  If that result is still
1646                  *  empty, the problem is either 'a)' or 'c)' */
1647
1648                 Size_t format_size = strlen(format) + 1;
1649                 Size_t mod_size = format_size + 1;
1650                 char * mod_format;
1651                 char * temp_result;
1652
1653                 Newx(mod_format, mod_size, char);
1654                 Newx(temp_result, PL_langinfo_bufsize, char);
1655                 *mod_format = '\a';
1656                 my_strlcpy(mod_format + 1, format, mod_size);
1657                 len = strftime(temp_result,
1658                                PL_langinfo_bufsize,
1659                                mod_format, &tm);
1660                 Safefree(mod_format);
1661                 Safefree(temp_result);
1662
1663                 /* If 'len' is non-zero, it means that we had a case like %p
1664                  * which means the current locale doesn't use a.m. or p.m., and
1665                  * that is valid */
1666                 if (len == 0) {
1667
1668                     /* Here, still didn't work.  If we get well beyond a
1669                      * reasonable size, bail out to prevent an infinite loop. */
1670
1671                     if (PL_langinfo_bufsize > 100 * format_size) {
1672                         *PL_langinfo_buf = '\0';
1673                     }
1674                     else { /* Double the buffer size to retry;  Add 1 in case
1675                               original was 0, so we aren't stuck at 0. */
1676                         PL_langinfo_bufsize *= 2;
1677                         PL_langinfo_bufsize++;
1678                         Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
1679                         continue;
1680                     }
1681                 }
1682
1683                 break;
1684             }
1685
1686             /* Here, we got a result.
1687              *
1688              * If the item is 'ALT_DIGITS', PL_langinfo_buf contains the
1689              * alternate format for wday 0.  If the value is the same as the
1690              * normal 0, there isn't an alternate, so clear the buffer. */
1691             if (   item == PERL_ALT_DIGITS
1692                 && strEQ(PL_langinfo_buf, "0"))
1693             {
1694                 *PL_langinfo_buf = '\0';
1695             }
1696
1697             /* ALT_DIGITS is problematic.  Experiments on it showed that
1698              * strftime() did not always work properly when going from alt-9 to
1699              * alt-10.  Only a few locales have this item defined, and in all
1700              * of them on Linux that khw was able to find, nl_langinfo() merely
1701              * returned the alt-0 character, possibly doubled.  Most Unicode
1702              * digits are in blocks of 10 consecutive code points, so that is
1703              * sufficient information for those scripts, as we can infer alt-1,
1704              * alt-2, ....  But for a Japanese locale, a CJK ideographic 0 is
1705              * returned, and the CJK digits are not in code point order, so you
1706              * can't really infer anything.  The localedef for this locale did
1707              * specify the succeeding digits, so that strftime() works properly
1708              * on them, without needing to infer anything.  But the
1709              * nl_langinfo() return did not give sufficient information for the
1710              * caller to understand what's going on.  So until there is
1711              * evidence that it should work differently, this returns the alt-0
1712              * string for ALT_DIGITS.
1713              *
1714              * wday was chosen because its range is all a single digit.  Things
1715              * like tm_sec have two digits as the minimum: '00' */
1716
1717             LOCALE_UNLOCK;
1718
1719             /* If to return the format, not the value, overwrite the buffer
1720              * with it.  But some strftime()s will keep the original format if
1721              * illegal, so change those to "" */
1722             if (return_format) {
1723                 if (strEQ(PL_langinfo_buf, format)) {
1724                     *PL_langinfo_buf = '\0';
1725                 }
1726                 else {
1727                     save_to_buffer(format, &PL_langinfo_buf,
1728                                     &PL_langinfo_bufsize, 0);
1729                 }
1730             }
1731
1732             break;
1733
1734 #  endif
1735
1736     }
1737
1738     return PL_langinfo_buf;
1739
1740 #endif
1741
1742 }
1743
1744 /*
1745  * Initialize locale awareness.
1746  */
1747 int
1748 Perl_init_i18nl10n(pTHX_ int printwarn)
1749 {
1750     /* printwarn is
1751      *
1752      *    0 if not to output warning when setup locale is bad
1753      *    1 if to output warning based on value of PERL_BADLANG
1754      *    >1 if to output regardless of PERL_BADLANG
1755      *
1756      * returns
1757      *    1 = set ok or not applicable,
1758      *    0 = fallback to a locale of lower priority
1759      *   -1 = fallback to all locales failed, not even to the C locale
1760      *
1761      * Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
1762      * set, debugging information is output.
1763      *
1764      * This looks more complicated than it is, mainly due to the #ifdefs.
1765      *
1766      * We try to set LC_ALL to the value determined by the environment.  If
1767      * there is no LC_ALL on this platform, we try the individual categories we
1768      * know about.  If this works, we are done.
1769      *
1770      * But if it doesn't work, we have to do something else.  We search the
1771      * environment variables ourselves instead of relying on the system to do
1772      * it.  We look at, in order, LC_ALL, LANG, a system default locale (if we
1773      * think there is one), and the ultimate fallback "C".  This is all done in
1774      * the same loop as above to avoid duplicating code, but it makes things
1775      * more complex.  The 'trial_locales' array is initialized with just one
1776      * element; it causes the behavior described in the paragraph above this to
1777      * happen.  If that fails, we add elements to 'trial_locales', and do extra
1778      * loop iterations to cause the behavior described in this paragraph.
1779      *
1780      * On Ultrix, the locale MUST come from the environment, so there is
1781      * preliminary code to set it.  I (khw) am not sure that it is necessary,
1782      * and that this couldn't be folded into the loop, but barring any real
1783      * platforms to test on, it's staying as-is
1784      *
1785      * A slight complication is that in embedded Perls, the locale may already
1786      * be set-up, and we don't want to get it from the normal environment
1787      * variables.  This is handled by having a special environment variable
1788      * indicate we're in this situation.  We simply set setlocale's 2nd
1789      * parameter to be a NULL instead of "".  That indicates to setlocale that
1790      * it is not to change anything, but to return the current value,
1791      * effectively initializing perl's db to what the locale already is.
1792      *
1793      * We play the same trick with NULL if a LC_ALL succeeds.  We call
1794      * setlocale() on the individual categores with NULL to get their existing
1795      * values for our db, instead of trying to change them.
1796      * */
1797
1798     int ok = 1;
1799
1800 #ifndef USE_LOCALE
1801
1802     PERL_UNUSED_ARG(printwarn);
1803
1804 #else  /* USE_LOCALE */
1805 #  ifdef __GLIBC__
1806
1807     const char * const language   = savepv(PerlEnv_getenv("LANGUAGE"));
1808
1809 #  endif
1810
1811     /* NULL uses the existing already set up locale */
1812     const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
1813                                         ? NULL
1814                                         : "";
1815     const char* trial_locales[5];   /* 5 = 1 each for "", LC_ALL, LANG, "", C */
1816     unsigned int trial_locales_count;
1817     const char * const lc_all     = savepv(PerlEnv_getenv("LC_ALL"));
1818     const char * const lang       = savepv(PerlEnv_getenv("LANG"));
1819     bool setlocale_failure = FALSE;
1820     unsigned int i;
1821
1822     /* A later getenv() could zap this, so only use here */
1823     const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
1824
1825     const bool locwarn = (printwarn > 1
1826                           || (          printwarn
1827                               && (    ! bad_lang_use_once
1828                                   || (
1829                                          /* disallow with "" or "0" */
1830                                          *bad_lang_use_once
1831                                        && strNE("0", bad_lang_use_once)))));
1832     bool done = FALSE;
1833     /* setlocale() return vals; not copied so must be looked at immediately */
1834     const char * sl_result[NOMINAL_LC_ALL_INDEX + 1];
1835
1836     /* current locale for given category; should have been copied so aren't
1837      * volatile */
1838     const char * curlocales[NOMINAL_LC_ALL_INDEX + 1];
1839
1840     char * locale_param;
1841
1842 #  ifdef WIN32
1843
1844     /* In some systems you can find out the system default locale
1845      * and use that as the fallback locale. */
1846 #    define SYSTEM_DEFAULT_LOCALE
1847 #  endif
1848 #  ifdef SYSTEM_DEFAULT_LOCALE
1849
1850     const char *system_default_locale = NULL;
1851
1852 #  endif
1853
1854 #  ifndef DEBUGGING
1855 #    define DEBUG_LOCALE_INIT(a,b,c)
1856 #  else
1857
1858     DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
1859
1860 #    define DEBUG_LOCALE_INIT(category, locale, result)                     \
1861         STMT_START {                                                        \
1862                 if (debug_initialization) {                                 \
1863                     PerlIO_printf(Perl_debug_log,                           \
1864                                   "%s:%d: %s\n",                            \
1865                                   __FILE__, __LINE__,                       \
1866                                   setlocale_debug_string(category,          \
1867                                                           locale,           \
1868                                                           result));         \
1869                 }                                                           \
1870         } STMT_END
1871
1872 /* Make sure the parallel arrays are properly set up */
1873 #    ifdef USE_LOCALE_NUMERIC
1874     assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
1875     assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
1876 #    endif
1877 #    ifdef USE_LOCALE_CTYPE
1878     assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
1879     assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
1880 #    endif
1881 #    ifdef USE_LOCALE_COLLATE
1882     assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
1883     assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
1884 #    endif
1885 #    ifdef USE_LOCALE_TIME
1886     assert(categories[LC_TIME_INDEX] == LC_TIME);
1887     assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
1888 #    endif
1889 #    ifdef USE_LOCALE_MESSAGES
1890     assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
1891     assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
1892 #    endif
1893 #    ifdef USE_LOCALE_MONETARY
1894     assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
1895     assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
1896 #    endif
1897 #    ifdef LC_ALL
1898     assert(categories[LC_ALL_INDEX] == LC_ALL);
1899     assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
1900     assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
1901 #    endif
1902 #  endif    /* DEBUGGING */
1903 #  ifndef LOCALE_ENVIRON_REQUIRED
1904
1905     PERL_UNUSED_VAR(done);
1906     PERL_UNUSED_VAR(locale_param);
1907
1908 #  else
1909
1910     /*
1911      * Ultrix setlocale(..., "") fails if there are no environment
1912      * variables from which to get a locale name.
1913      */
1914
1915 #    ifdef LC_ALL
1916
1917     if (lang) {
1918         sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, setlocale_init);
1919         DEBUG_LOCALE_INIT(LC_ALL, setlocale_init, sl_result[LC_ALL_INDEX]);
1920         if (sl_result[LC_ALL_INDEX])
1921             done = TRUE;
1922         else
1923             setlocale_failure = TRUE;
1924     }
1925     if (! setlocale_failure) {
1926         for (i = 0; i < LC_ALL_INDEX; i++) {
1927             locale_param = (! done && (lang || PerlEnv_getenv(category_names[i])))
1928                            ? setlocale_init
1929                            : NULL;
1930             sl_result[i] = do_setlocale_r(categories[i], locale_param);
1931             if (! sl_result[i]) {
1932                 setlocale_failure = TRUE;
1933             }
1934             DEBUG_LOCALE_INIT(categories[i], locale_param, sl_result[i]);
1935         }
1936     }
1937
1938 #    endif /* LC_ALL */
1939 #  endif /* LOCALE_ENVIRON_REQUIRED */
1940
1941     /* We try each locale in the list until we get one that works, or exhaust
1942      * the list.  Normally the loop is executed just once.  But if setting the
1943      * locale fails, inside the loop we add fallback trials to the array and so
1944      * will execute the loop multiple times */
1945     trial_locales[0] = setlocale_init;
1946     trial_locales_count = 1;
1947
1948     for (i= 0; i < trial_locales_count; i++) {
1949         const char * trial_locale = trial_locales[i];
1950
1951         if (i > 0) {
1952
1953             /* XXX This is to preserve old behavior for LOCALE_ENVIRON_REQUIRED
1954              * when i==0, but I (khw) don't think that behavior makes much
1955              * sense */
1956             setlocale_failure = FALSE;
1957
1958 #  ifdef SYSTEM_DEFAULT_LOCALE
1959 #    ifdef WIN32    /* Note that assumes Win32 has LC_ALL */
1960
1961             /* On Windows machines, an entry of "" after the 0th means to use
1962              * the system default locale, which we now proceed to get. */
1963             if (strEQ(trial_locale, "")) {
1964                 unsigned int j;
1965
1966                 /* Note that this may change the locale, but we are going to do
1967                  * that anyway just below */
1968                 system_default_locale = do_setlocale_c(LC_ALL, "");
1969                 DEBUG_LOCALE_INIT(LC_ALL, "", system_default_locale);
1970
1971                 /* Skip if invalid or if it's already on the list of locales to
1972                  * try */
1973                 if (! system_default_locale) {
1974                     goto next_iteration;
1975                 }
1976                 for (j = 0; j < trial_locales_count; j++) {
1977                     if (strEQ(system_default_locale, trial_locales[j])) {
1978                         goto next_iteration;
1979                     }
1980                 }
1981
1982                 trial_locale = system_default_locale;
1983             }
1984 #    endif /* WIN32 */
1985 #  endif /* SYSTEM_DEFAULT_LOCALE */
1986
1987         }   /* For i > 0 */
1988
1989 #  ifdef LC_ALL
1990
1991         sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, trial_locale);
1992         DEBUG_LOCALE_INIT(LC_ALL, trial_locale, sl_result[LC_ALL_INDEX]);
1993         if (! sl_result[LC_ALL_INDEX]) {
1994             setlocale_failure = TRUE;
1995         }
1996         else {
1997             /* Since LC_ALL succeeded, it should have changed all the other
1998              * categories it can to its value; so we massage things so that the
1999              * setlocales below just return their category's current values.
2000              * This adequately handles the case in NetBSD where LC_COLLATE may
2001              * not be defined for a locale, and setting it individually will
2002              * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to
2003              * the POSIX locale. */
2004             trial_locale = NULL;
2005         }
2006
2007 #  endif /* LC_ALL */
2008
2009         if (! setlocale_failure) {
2010             unsigned int j;
2011             for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2012                 curlocales[j]
2013                         = savepv(do_setlocale_r(categories[j], trial_locale));
2014                 if (! curlocales[j]) {
2015                     setlocale_failure = TRUE;
2016                 }
2017                 DEBUG_LOCALE_INIT(categories[j], trial_locale, curlocales[j]);
2018             }
2019
2020             if (! setlocale_failure) {  /* All succeeded */
2021                 break;  /* Exit trial_locales loop */
2022             }
2023         }
2024
2025         /* Here, something failed; will need to try a fallback. */
2026         ok = 0;
2027
2028         if (i == 0) {
2029             unsigned int j;
2030
2031             if (locwarn) { /* Output failure info only on the first one */
2032
2033 #  ifdef LC_ALL
2034
2035                 PerlIO_printf(Perl_error_log,
2036                 "perl: warning: Setting locale failed.\n");
2037
2038 #  else /* !LC_ALL */
2039
2040                 PerlIO_printf(Perl_error_log,
2041                 "perl: warning: Setting locale failed for the categories:\n\t");
2042
2043                 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2044                     if (! curlocales[j]) {
2045                         PerlIO_printf(Perl_error_log, category_names[j]);
2046                     }
2047                     else {
2048                         Safefree(curlocales[j]);
2049                     }
2050                 }
2051
2052                 PerlIO_printf(Perl_error_log, "and possibly others\n");
2053
2054 #  endif /* LC_ALL */
2055
2056                 PerlIO_printf(Perl_error_log,
2057                     "perl: warning: Please check that your locale settings:\n");
2058
2059 #  ifdef __GLIBC__
2060
2061                 PerlIO_printf(Perl_error_log,
2062                             "\tLANGUAGE = %c%s%c,\n",
2063                             language ? '"' : '(',
2064                             language ? language : "unset",
2065                             language ? '"' : ')');
2066 #  endif
2067
2068                 PerlIO_printf(Perl_error_log,
2069                             "\tLC_ALL = %c%s%c,\n",
2070                             lc_all ? '"' : '(',
2071                             lc_all ? lc_all : "unset",
2072                             lc_all ? '"' : ')');
2073
2074 #  if defined(USE_ENVIRON_ARRAY)
2075
2076                 {
2077                     char **e;
2078
2079                     /* Look through the environment for any variables of the
2080                      * form qr/ ^ LC_ [A-Z]+ = /x, except LC_ALL which was
2081                      * already handled above.  These are assumed to be locale
2082                      * settings.  Output them and their values. */
2083                     for (e = environ; *e; e++) {
2084                         const STRLEN prefix_len = sizeof("LC_") - 1;
2085                         STRLEN uppers_len;
2086
2087                         if (     strBEGINs(*e, "LC_")
2088                             && ! strBEGINs(*e, "LC_ALL=")
2089                             && (uppers_len = strspn(*e + prefix_len,
2090                                              "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
2091                             && ((*e)[prefix_len + uppers_len] == '='))
2092                         {
2093                             PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
2094                                 (int) (prefix_len + uppers_len), *e,
2095                                 *e + prefix_len + uppers_len + 1);
2096                         }
2097                     }
2098                 }
2099
2100 #  else
2101
2102                 PerlIO_printf(Perl_error_log,
2103                             "\t(possibly more locale environment variables)\n");
2104
2105 #  endif
2106
2107                 PerlIO_printf(Perl_error_log,
2108                             "\tLANG = %c%s%c\n",
2109                             lang ? '"' : '(',
2110                             lang ? lang : "unset",
2111                             lang ? '"' : ')');
2112
2113                 PerlIO_printf(Perl_error_log,
2114                             "    are supported and installed on your system.\n");
2115             }
2116
2117             /* Calculate what fallback locales to try.  We have avoided this
2118              * until we have to, because failure is quite unlikely.  This will
2119              * usually change the upper bound of the loop we are in.
2120              *
2121              * Since the system's default way of setting the locale has not
2122              * found one that works, We use Perl's defined ordering: LC_ALL,
2123              * LANG, and the C locale.  We don't try the same locale twice, so
2124              * don't add to the list if already there.  (On POSIX systems, the
2125              * LC_ALL element will likely be a repeat of the 0th element "",
2126              * but there's no harm done by doing it explicitly.
2127              *
2128              * Note that this tries the LC_ALL environment variable even on
2129              * systems which have no LC_ALL locale setting.  This may or may
2130              * not have been originally intentional, but there's no real need
2131              * to change the behavior. */
2132             if (lc_all) {
2133                 for (j = 0; j < trial_locales_count; j++) {
2134                     if (strEQ(lc_all, trial_locales[j])) {
2135                         goto done_lc_all;
2136                     }
2137                 }
2138                 trial_locales[trial_locales_count++] = lc_all;
2139             }
2140           done_lc_all:
2141
2142             if (lang) {
2143                 for (j = 0; j < trial_locales_count; j++) {
2144                     if (strEQ(lang, trial_locales[j])) {
2145                         goto done_lang;
2146                     }
2147                 }
2148                 trial_locales[trial_locales_count++] = lang;
2149             }
2150           done_lang:
2151
2152 #  if defined(WIN32) && defined(LC_ALL)
2153
2154             /* For Windows, we also try the system default locale before "C".
2155              * (If there exists a Windows without LC_ALL we skip this because
2156              * it gets too complicated.  For those, the "C" is the next
2157              * fallback possibility).  The "" is the same as the 0th element of
2158              * the array, but the code at the loop above knows to treat it
2159              * differently when not the 0th */
2160             trial_locales[trial_locales_count++] = "";
2161
2162 #  endif
2163
2164             for (j = 0; j < trial_locales_count; j++) {
2165                 if (strEQ("C", trial_locales[j])) {
2166                     goto done_C;
2167                 }
2168             }
2169             trial_locales[trial_locales_count++] = "C";
2170
2171           done_C: ;
2172         }   /* end of first time through the loop */
2173
2174 #  ifdef WIN32
2175
2176       next_iteration: ;
2177
2178 #  endif
2179
2180     }   /* end of looping through the trial locales */
2181
2182     if (ok < 1) {   /* If we tried to fallback */
2183         const char* msg;
2184         if (! setlocale_failure) {  /* fallback succeeded */
2185            msg = "Falling back to";
2186         }
2187         else {  /* fallback failed */
2188             unsigned int j;
2189
2190             /* We dropped off the end of the loop, so have to decrement i to
2191              * get back to the value the last time through */
2192             i--;
2193
2194             ok = -1;
2195             msg = "Failed to fall back to";
2196
2197             /* To continue, we should use whatever values we've got */
2198
2199             for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2200                 Safefree(curlocales[j]);
2201                 curlocales[j] = savepv(do_setlocale_r(categories[j], NULL));
2202                 DEBUG_LOCALE_INIT(categories[j], NULL, curlocales[j]);
2203             }
2204         }
2205
2206         if (locwarn) {
2207             const char * description;
2208             const char * name = "";
2209             if (strEQ(trial_locales[i], "C")) {
2210                 description = "the standard locale";
2211                 name = "C";
2212             }
2213
2214 #  ifdef SYSTEM_DEFAULT_LOCALE
2215
2216             else if (strEQ(trial_locales[i], "")) {
2217                 description = "the system default locale";
2218                 if (system_default_locale) {
2219                     name = system_default_locale;
2220                 }
2221             }
2222
2223 #  endif /* SYSTEM_DEFAULT_LOCALE */
2224
2225             else {
2226                 description = "a fallback locale";
2227                 name = trial_locales[i];
2228             }
2229             if (name && strNE(name, "")) {
2230                 PerlIO_printf(Perl_error_log,
2231                     "perl: warning: %s %s (\"%s\").\n", msg, description, name);
2232             }
2233             else {
2234                 PerlIO_printf(Perl_error_log,
2235                                    "perl: warning: %s %s.\n", msg, description);
2236             }
2237         }
2238     } /* End of tried to fallback */
2239
2240     /* Done with finding the locales; update our records */
2241
2242 #  ifdef USE_LOCALE_CTYPE
2243
2244     new_ctype(curlocales[LC_CTYPE_INDEX]);
2245
2246 #  endif
2247 #  ifdef USE_LOCALE_COLLATE
2248
2249     new_collate(curlocales[LC_COLLATE_INDEX]);
2250
2251 #  endif
2252 #  ifdef USE_LOCALE_NUMERIC
2253
2254     new_numeric(curlocales[LC_NUMERIC_INDEX]);
2255
2256 #  endif
2257
2258
2259     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
2260         Safefree(curlocales[i]);
2261     }
2262
2263 #  if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
2264
2265     /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
2266      * locale is UTF-8.  If PL_utf8locale and PL_unicode (set by -C or by
2267      * $ENV{PERL_UNICODE}) are true, perl.c:S_parse_body() will turn on the
2268      * PerlIO :utf8 layer on STDIN, STDOUT, STDERR, _and_ the default open
2269      * discipline.  */
2270     PL_utf8locale = _is_cur_LC_category_utf8(LC_CTYPE);
2271
2272     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
2273        This is an alternative to using the -C command line switch
2274        (the -C if present will override this). */
2275     {
2276          const char *p = PerlEnv_getenv("PERL_UNICODE");
2277          PL_unicode = p ? parse_unicode_opts(&p) : 0;
2278          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
2279              PL_utf8cache = -1;
2280     }
2281
2282 #  endif
2283 #  ifdef __GLIBC__
2284
2285     Safefree(language);
2286
2287 #  endif
2288
2289     Safefree(lc_all);
2290     Safefree(lang);
2291
2292 #endif /* USE_LOCALE */
2293 #ifdef DEBUGGING
2294
2295     /* So won't continue to output stuff */
2296     DEBUG_INITIALIZATION_set(FALSE);
2297
2298 #endif
2299
2300     return ok;
2301 }
2302
2303 #ifdef USE_LOCALE_COLLATE
2304
2305 char *
2306 Perl__mem_collxfrm(pTHX_ const char *input_string,
2307                          STRLEN len,    /* Length of 'input_string' */
2308                          STRLEN *xlen,  /* Set to length of returned string
2309                                            (not including the collation index
2310                                            prefix) */
2311                          bool utf8      /* Is the input in UTF-8? */
2312                    )
2313 {
2314
2315     /* _mem_collxfrm() is a bit like strxfrm() but with two important
2316      * differences. First, it handles embedded NULs. Second, it allocates a bit
2317      * more memory than needed for the transformed data itself.  The real
2318      * transformed data begins at offset COLLXFRM_HDR_LEN.  *xlen is set to
2319      * the length of that, and doesn't include the collation index size.
2320      * Please see sv_collxfrm() to see how this is used. */
2321
2322 #define COLLXFRM_HDR_LEN    sizeof(PL_collation_ix)
2323
2324     char * s = (char *) input_string;
2325     STRLEN s_strlen = strlen(input_string);
2326     char *xbuf = NULL;
2327     STRLEN xAlloc;          /* xalloc is a reserved word in VC */
2328     STRLEN length_in_chars;
2329     bool first_time = TRUE; /* Cleared after first loop iteration */
2330
2331     PERL_ARGS_ASSERT__MEM_COLLXFRM;
2332
2333     /* Must be NUL-terminated */
2334     assert(*(input_string + len) == '\0');
2335
2336     /* If this locale has defective collation, skip */
2337     if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
2338         DEBUG_L(PerlIO_printf(Perl_debug_log,
2339                       "_mem_collxfrm: locale's collation is defective\n"));
2340         goto bad;
2341     }
2342
2343     /* Replace any embedded NULs with the control that sorts before any others.
2344      * This will give as good as possible results on strings that don't
2345      * otherwise contain that character, but otherwise there may be
2346      * less-than-perfect results with that character and NUL.  This is
2347      * unavoidable unless we replace strxfrm with our own implementation. */
2348     if (UNLIKELY(s_strlen < len)) {   /* Only execute if there is an embedded
2349                                          NUL */
2350         char * e = s + len;
2351         char * sans_nuls;
2352         STRLEN sans_nuls_len;
2353         int try_non_controls;
2354         char this_replacement_char[] = "?\0";   /* Room for a two-byte string,
2355                                                    making sure 2nd byte is NUL.
2356                                                  */
2357         STRLEN this_replacement_len;
2358
2359         /* If we don't know what non-NUL control character sorts lowest for
2360          * this locale, find it */
2361         if (PL_strxfrm_NUL_replacement == '\0') {
2362             int j;
2363             char * cur_min_x = NULL;    /* The min_char's xfrm, (except it also
2364                                            includes the collation index
2365                                            prefixed. */
2366
2367             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
2368
2369             /* Unlikely, but it may be that no control will work to replace
2370              * NUL, in which case we instead look for any character.  Controls
2371              * are preferred because collation order is, in general, context
2372              * sensitive, with adjoining characters affecting the order, and
2373              * controls are less likely to have such interactions, allowing the
2374              * NUL-replacement to stand on its own.  (Another way to look at it
2375              * is to imagine what would happen if the NUL were replaced by a
2376              * combining character; it wouldn't work out all that well.) */
2377             for (try_non_controls = 0;
2378                  try_non_controls < 2;
2379                  try_non_controls++)
2380             {
2381                 /* Look through all legal code points (NUL isn't) */
2382                 for (j = 1; j < 256; j++) {
2383                     char * x;       /* j's xfrm plus collation index */
2384                     STRLEN x_len;   /* length of 'x' */
2385                     STRLEN trial_len = 1;
2386                     char cur_source[] = { '\0', '\0' };
2387
2388                     /* Skip non-controls the first time through the loop.  The
2389                      * controls in a UTF-8 locale are the L1 ones */
2390                     if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
2391                                                ? ! isCNTRL_L1(j)
2392                                                : ! isCNTRL_LC(j))
2393                     {
2394                         continue;
2395                     }
2396
2397                     /* Create a 1-char string of the current code point */
2398                     cur_source[0] = (char) j;
2399
2400                     /* Then transform it */
2401                     x = _mem_collxfrm(cur_source, trial_len, &x_len,
2402                                       0 /* The string is not in UTF-8 */);
2403
2404                     /* Ignore any character that didn't successfully transform.
2405                      * */
2406                     if (! x) {
2407                         continue;
2408                     }
2409
2410                     /* If this character's transformation is lower than
2411                      * the current lowest, this one becomes the lowest */
2412                     if (   cur_min_x == NULL
2413                         || strLT(x         + COLLXFRM_HDR_LEN,
2414                                  cur_min_x + COLLXFRM_HDR_LEN))
2415                     {
2416                         PL_strxfrm_NUL_replacement = j;
2417                         cur_min_x = x;
2418                     }
2419                     else {
2420                         Safefree(x);
2421                     }
2422                 } /* end of loop through all 255 characters */
2423
2424                 /* Stop looking if found */
2425                 if (cur_min_x) {
2426                     break;
2427                 }
2428
2429                 /* Unlikely, but possible, if there aren't any controls that
2430                  * work in the locale, repeat the loop, looking for any
2431                  * character that works */
2432                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2433                 "_mem_collxfrm: No control worked.  Trying non-controls\n"));
2434             } /* End of loop to try first the controls, then any char */
2435
2436             if (! cur_min_x) {
2437                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2438                     "_mem_collxfrm: Couldn't find any character to replace"
2439                     " embedded NULs in locale %s with", PL_collation_name));
2440                 goto bad;
2441             }
2442
2443             DEBUG_L(PerlIO_printf(Perl_debug_log,
2444                     "_mem_collxfrm: Replacing embedded NULs in locale %s with "
2445                     "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
2446
2447             Safefree(cur_min_x);
2448         } /* End of determining the character that is to replace NULs */
2449
2450         /* If the replacement is variant under UTF-8, it must match the
2451          * UTF8-ness of the original */
2452         if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
2453             this_replacement_char[0] =
2454                                 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
2455             this_replacement_char[1] =
2456                                 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
2457             this_replacement_len = 2;
2458         }
2459         else {
2460             this_replacement_char[0] = PL_strxfrm_NUL_replacement;
2461             /* this_replacement_char[1] = '\0' was done at initialization */
2462             this_replacement_len = 1;
2463         }
2464
2465         /* The worst case length for the replaced string would be if every
2466          * character in it is NUL.  Multiply that by the length of each
2467          * replacement, and allow for a trailing NUL */
2468         sans_nuls_len = (len * this_replacement_len) + 1;
2469         Newx(sans_nuls, sans_nuls_len, char);
2470         *sans_nuls = '\0';
2471
2472         /* Replace each NUL with the lowest collating control.  Loop until have
2473          * exhausted all the NULs */
2474         while (s + s_strlen < e) {
2475             my_strlcat(sans_nuls, s, sans_nuls_len);
2476
2477             /* Do the actual replacement */
2478             my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
2479
2480             /* Move past the input NUL */
2481             s += s_strlen + 1;
2482             s_strlen = strlen(s);
2483         }
2484
2485         /* And add anything that trails the final NUL */
2486         my_strlcat(sans_nuls, s, sans_nuls_len);
2487
2488         /* Switch so below we transform this modified string */
2489         s = sans_nuls;
2490         len = strlen(s);
2491     } /* End of replacing NULs */
2492
2493     /* Make sure the UTF8ness of the string and locale match */
2494     if (utf8 != PL_in_utf8_COLLATE_locale) {
2495         const char * const t = s;   /* Temporary so we can later find where the
2496                                        input was */
2497
2498         /* Here they don't match.  Change the string's to be what the locale is
2499          * expecting */
2500
2501         if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
2502             s = (char *) bytes_to_utf8((const U8 *) s, &len);
2503             utf8 = TRUE;
2504         }
2505         else {   /* locale is not UTF-8; but input is; downgrade the input */
2506
2507             s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
2508
2509             /* If the downgrade was successful we are done, but if the input
2510              * contains things that require UTF-8 to represent, have to do
2511              * damage control ... */
2512             if (UNLIKELY(utf8)) {
2513
2514                 /* What we do is construct a non-UTF-8 string with
2515                  *  1) the characters representable by a single byte converted
2516                  *     to be so (if necessary);
2517                  *  2) and the rest converted to collate the same as the
2518                  *     highest collating representable character.  That makes
2519                  *     them collate at the end.  This is similar to how we
2520                  *     handle embedded NULs, but we use the highest collating
2521                  *     code point instead of the smallest.  Like the NUL case,
2522                  *     this isn't perfect, but is the best we can reasonably
2523                  *     do.  Every above-255 code point will sort the same as
2524                  *     the highest-sorting 0-255 code point.  If that code
2525                  *     point can combine in a sequence with some other code
2526                  *     points for weight calculations, us changing something to
2527                  *     be it can adversely affect the results.  But in most
2528                  *     cases, it should work reasonably.  And note that this is
2529                  *     really an illegal situation: using code points above 255
2530                  *     on a locale where only 0-255 are valid.  If two strings
2531                  *     sort entirely equal, then the sort order for the
2532                  *     above-255 code points will be in code point order. */
2533
2534                 utf8 = FALSE;
2535
2536                 /* If we haven't calculated the code point with the maximum
2537                  * collating order for this locale, do so now */
2538                 if (! PL_strxfrm_max_cp) {
2539                     int j;
2540
2541                     /* The current transformed string that collates the
2542                      * highest (except it also includes the prefixed collation
2543                      * index. */
2544                     char * cur_max_x = NULL;
2545
2546                     /* Look through all legal code points (NUL isn't) */
2547                     for (j = 1; j < 256; j++) {
2548                         char * x;
2549                         STRLEN x_len;
2550                         char cur_source[] = { '\0', '\0' };
2551
2552                         /* Create a 1-char string of the current code point */
2553                         cur_source[0] = (char) j;
2554
2555                         /* Then transform it */
2556                         x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
2557
2558                         /* If something went wrong (which it shouldn't), just
2559                          * ignore this code point */
2560                         if (! x) {
2561                             continue;
2562                         }
2563
2564                         /* If this character's transformation is higher than
2565                          * the current highest, this one becomes the highest */
2566                         if (   cur_max_x == NULL
2567                             || strGT(x         + COLLXFRM_HDR_LEN,
2568                                      cur_max_x + COLLXFRM_HDR_LEN))
2569                         {
2570                             PL_strxfrm_max_cp = j;
2571                             cur_max_x = x;
2572                         }
2573                         else {
2574                             Safefree(x);
2575                         }
2576                     }
2577
2578                     if (! cur_max_x) {
2579                         DEBUG_L(PerlIO_printf(Perl_debug_log,
2580                             "_mem_collxfrm: Couldn't find any character to"
2581                             " replace above-Latin1 chars in locale %s with",
2582                             PL_collation_name));
2583                         goto bad;
2584                     }
2585
2586                     DEBUG_L(PerlIO_printf(Perl_debug_log,
2587                             "_mem_collxfrm: highest 1-byte collating character"
2588                             " in locale %s is 0x%02X\n",
2589                             PL_collation_name,
2590                             PL_strxfrm_max_cp));
2591
2592                     Safefree(cur_max_x);
2593                 }
2594
2595                 /* Here we know which legal code point collates the highest.
2596                  * We are ready to construct the non-UTF-8 string.  The length
2597                  * will be at least 1 byte smaller than the input string
2598                  * (because we changed at least one 2-byte character into a
2599                  * single byte), but that is eaten up by the trailing NUL */
2600                 Newx(s, len, char);
2601
2602                 {
2603                     STRLEN i;
2604                     STRLEN d= 0;
2605                     char * e = (char *) t + len;
2606
2607                     for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
2608                         U8 cur_char = t[i];
2609                         if (UTF8_IS_INVARIANT(cur_char)) {
2610                             s[d++] = cur_char;
2611                         }
2612                         else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
2613                             s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
2614                         }
2615                         else {  /* Replace illegal cp with highest collating
2616                                    one */
2617                             s[d++] = PL_strxfrm_max_cp;
2618                         }
2619                     }
2620                     s[d++] = '\0';
2621                     Renew(s, d, char);   /* Free up unused space */
2622                 }
2623             }
2624         }
2625
2626         /* Here, we have constructed a modified version of the input.  It could
2627          * be that we already had a modified copy before we did this version.
2628          * If so, that copy is no longer needed */
2629         if (t != input_string) {
2630             Safefree(t);
2631         }
2632     }
2633
2634     length_in_chars = (utf8)
2635                       ? utf8_length((U8 *) s, (U8 *) s + len)
2636                       : len;
2637
2638     /* The first element in the output is the collation id, used by
2639      * sv_collxfrm(); then comes the space for the transformed string.  The
2640      * equation should give us a good estimate as to how much is needed */
2641     xAlloc = COLLXFRM_HDR_LEN
2642            + PL_collxfrm_base
2643            + (PL_collxfrm_mult * length_in_chars);
2644     Newx(xbuf, xAlloc, char);
2645     if (UNLIKELY(! xbuf)) {
2646         DEBUG_L(PerlIO_printf(Perl_debug_log,
2647                       "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
2648         goto bad;
2649     }
2650
2651     /* Store the collation id */
2652     *(U32*)xbuf = PL_collation_ix;
2653
2654     /* Then the transformation of the input.  We loop until successful, or we
2655      * give up */
2656     for (;;) {
2657
2658         *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
2659
2660         /* If the transformed string occupies less space than we told strxfrm()
2661          * was available, it means it successfully transformed the whole
2662          * string. */
2663         if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
2664
2665             /* Some systems include a trailing NUL in the returned length.
2666              * Ignore it, using a loop in case multiple trailing NULs are
2667              * returned. */
2668             while (   (*xlen) > 0
2669                    && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
2670             {
2671                 (*xlen)--;
2672             }
2673
2674             /* If the first try didn't get it, it means our prediction was low.
2675              * Modify the coefficients so that we predict a larger value in any
2676              * future transformations */
2677             if (! first_time) {
2678                 STRLEN needed = *xlen + 1;   /* +1 For trailing NUL */
2679                 STRLEN computed_guess = PL_collxfrm_base
2680                                       + (PL_collxfrm_mult * length_in_chars);
2681
2682                 /* On zero-length input, just keep current slope instead of
2683                  * dividing by 0 */
2684                 const STRLEN new_m = (length_in_chars != 0)
2685                                      ? needed / length_in_chars
2686                                      : PL_collxfrm_mult;
2687
2688                 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2689                     "%s: %d: initial size of %zu bytes for a length "
2690                     "%zu string was insufficient, %zu needed\n",
2691                     __FILE__, __LINE__,
2692                     computed_guess, length_in_chars, needed));
2693
2694                 /* If slope increased, use it, but discard this result for
2695                  * length 1 strings, as we can't be sure that it's a real slope
2696                  * change */
2697                 if (length_in_chars > 1 && new_m  > PL_collxfrm_mult) {
2698
2699 #  ifdef DEBUGGING
2700
2701                     STRLEN old_m = PL_collxfrm_mult;
2702                     STRLEN old_b = PL_collxfrm_base;
2703
2704 #  endif
2705
2706                     PL_collxfrm_mult = new_m;
2707                     PL_collxfrm_base = 1;   /* +1 For trailing NUL */
2708                     computed_guess = PL_collxfrm_base
2709                                     + (PL_collxfrm_mult * length_in_chars);
2710                     if (computed_guess < needed) {
2711                         PL_collxfrm_base += needed - computed_guess;
2712                     }
2713
2714                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2715                         "%s: %d: slope is now %zu; was %zu, base "
2716                         "is now %zu; was %zu\n",
2717                         __FILE__, __LINE__,
2718                         PL_collxfrm_mult, old_m,
2719                         PL_collxfrm_base, old_b));
2720                 }
2721                 else {  /* Slope didn't change, but 'b' did */
2722                     const STRLEN new_b = needed
2723                                         - computed_guess
2724                                         + PL_collxfrm_base;
2725                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2726                         "%s: %d: base is now %zu; was %zu\n",
2727                         __FILE__, __LINE__,
2728                         new_b, PL_collxfrm_base));
2729                     PL_collxfrm_base = new_b;
2730                 }
2731             }
2732
2733             break;
2734         }
2735
2736         if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
2737             DEBUG_L(PerlIO_printf(Perl_debug_log,
2738                   "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
2739                   *xlen, PERL_INT_MAX));
2740             goto bad;
2741         }
2742
2743         /* A well-behaved strxfrm() returns exactly how much space it needs
2744          * (usually not including the trailing NUL) when it fails due to not
2745          * enough space being provided.  Assume that this is the case unless
2746          * it's been proven otherwise */
2747         if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
2748             xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
2749         }
2750         else { /* Here, either:
2751                 *  1)  The strxfrm() has previously shown bad behavior; or
2752                 *  2)  It isn't the first time through the loop, which means
2753                 *      that the strxfrm() is now showing bad behavior, because
2754                 *      we gave it what it said was needed in the previous
2755                 *      iteration, and it came back saying it needed still more.
2756                 *      (Many versions of cygwin fit this.  When the buffer size
2757                 *      isn't sufficient, they return the input size instead of
2758                 *      how much is needed.)
2759                 * Increase the buffer size by a fixed percentage and try again.
2760                 * */
2761             xAlloc += (xAlloc / 4) + 1;
2762             PL_strxfrm_is_behaved = FALSE;
2763
2764 #  ifdef DEBUGGING
2765
2766             if (DEBUG_Lv_TEST || debug_initialization) {
2767                 PerlIO_printf(Perl_debug_log,
2768                 "_mem_collxfrm required more space than previously calculated"
2769                 " for locale %s, trying again with new guess=%d+%zu\n",
2770                 PL_collation_name, (int) COLLXFRM_HDR_LEN,
2771                 xAlloc - COLLXFRM_HDR_LEN);
2772             }
2773
2774 #  endif
2775
2776         }
2777
2778         Renew(xbuf, xAlloc, char);
2779         if (UNLIKELY(! xbuf)) {
2780             DEBUG_L(PerlIO_printf(Perl_debug_log,
2781                       "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
2782             goto bad;
2783         }
2784
2785         first_time = FALSE;
2786     }
2787
2788
2789 #  ifdef DEBUGGING
2790
2791     if (DEBUG_Lv_TEST || debug_initialization) {
2792
2793         print_collxfrm_input_and_return(s, s + len, xlen, utf8);
2794         PerlIO_printf(Perl_debug_log, "Its xfrm is:");
2795         PerlIO_printf(Perl_debug_log, "%s\n",
2796                       _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
2797                        *xlen, 1));
2798     }
2799
2800 #  endif
2801
2802     /* Free up unneeded space; retain ehough for trailing NUL */
2803     Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
2804
2805     if (s != input_string) {
2806         Safefree(s);
2807     }
2808
2809     return xbuf;
2810
2811   bad:
2812     Safefree(xbuf);
2813     if (s != input_string) {
2814         Safefree(s);
2815     }
2816     *xlen = 0;
2817
2818 #  ifdef DEBUGGING
2819
2820     if (DEBUG_Lv_TEST || debug_initialization) {
2821         print_collxfrm_input_and_return(s, s + len, NULL, utf8);
2822     }
2823
2824 #  endif
2825
2826     return NULL;
2827 }
2828
2829 #  ifdef DEBUGGING
2830
2831 STATIC void
2832 S_print_collxfrm_input_and_return(pTHX_
2833                                   const char * const s,
2834                                   const char * const e,
2835                                   const STRLEN * const xlen,
2836                                   const bool is_utf8)
2837 {
2838
2839     PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
2840
2841     PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
2842                                                         (UV)PL_collation_ix);
2843     if (xlen) {
2844         PerlIO_printf(Perl_debug_log, "%zu", *xlen);
2845     }
2846     else {
2847         PerlIO_printf(Perl_debug_log, "NULL");
2848     }
2849     PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
2850                                                             PL_collation_name);
2851     print_bytes_for_locale(s, e, is_utf8);
2852
2853     PerlIO_printf(Perl_debug_log, "'\n");
2854 }
2855
2856 STATIC void
2857 S_print_bytes_for_locale(pTHX_
2858                     const char * const s,
2859                     const char * const e,
2860                     const bool is_utf8)
2861 {
2862     const char * t = s;
2863     bool prev_was_printable = TRUE;
2864     bool first_time = TRUE;
2865
2866     PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
2867
2868     while (t < e) {
2869         UV cp = (is_utf8)
2870                 ?  utf8_to_uvchr_buf((U8 *) t, e, NULL)
2871                 : * (U8 *) t;
2872         if (isPRINT(cp)) {
2873             if (! prev_was_printable) {
2874                 PerlIO_printf(Perl_debug_log, " ");
2875             }
2876             PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
2877             prev_was_printable = TRUE;
2878         }
2879         else {
2880             if (! first_time) {
2881                 PerlIO_printf(Perl_debug_log, " ");
2882             }
2883             PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
2884             prev_was_printable = FALSE;
2885         }
2886         t += (is_utf8) ? UTF8SKIP(t) : 1;
2887         first_time = FALSE;
2888     }
2889 }
2890
2891 #  endif   /* #ifdef DEBUGGING */
2892 #endif /* USE_LOCALE_COLLATE */
2893
2894 #ifdef USE_LOCALE
2895
2896 bool
2897 Perl__is_cur_LC_category_utf8(pTHX_ int category)
2898 {
2899     /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
2900      * otherwise. 'category' may not be LC_ALL.  If the platform doesn't have
2901      * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
2902      * could give the wrong result.  The result will very likely be correct for
2903      * languages that have commonly used non-ASCII characters, but for notably
2904      * English, it comes down to if the locale's name ends in something like
2905      * "UTF-8".  It errs on the side of not being a UTF-8 locale. */
2906
2907     const char *save_input_locale = NULL;
2908     STRLEN final_pos;
2909
2910 #  ifdef LC_ALL
2911
2912     assert(category != LC_ALL);
2913
2914 #  endif
2915
2916     /* First dispose of the trivial cases */
2917     save_input_locale = do_setlocale_r(category, NULL);
2918     if (! save_input_locale) {
2919         DEBUG_L(PerlIO_printf(Perl_debug_log,
2920                               "Could not find current locale for category %d\n",
2921                               category));
2922         return FALSE;   /* XXX maybe should croak */
2923     }
2924     save_input_locale = stdize_locale(savepv(save_input_locale));
2925     if (isNAME_C_OR_POSIX(save_input_locale)) {
2926         DEBUG_L(PerlIO_printf(Perl_debug_log,
2927                               "Current locale for category %d is %s\n",
2928                               category, save_input_locale));
2929         Safefree(save_input_locale);
2930         return FALSE;
2931     }
2932
2933 #  if defined(USE_LOCALE_CTYPE)    \
2934     && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET)))
2935
2936     { /* Next try nl_langinfo or MB_CUR_MAX if available */
2937
2938         char *save_ctype_locale = NULL;
2939         bool is_utf8;
2940
2941         if (category != LC_CTYPE) { /* These work only on LC_CTYPE */
2942
2943             /* Get the current LC_CTYPE locale */
2944             save_ctype_locale = do_setlocale_c(LC_CTYPE, NULL);
2945             if (! save_ctype_locale) {
2946                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2947                                "Could not find current locale for LC_CTYPE\n"));
2948                 goto cant_use_nllanginfo;
2949             }
2950             save_ctype_locale = stdize_locale(savepv(save_ctype_locale));
2951
2952             /* If LC_CTYPE and the desired category use the same locale, this
2953              * means that finding the value for LC_CTYPE is the same as finding
2954              * the value for the desired category.  Otherwise, switch LC_CTYPE
2955              * to the desired category's locale */
2956             if (strEQ(save_ctype_locale, save_input_locale)) {
2957                 Safefree(save_ctype_locale);
2958                 save_ctype_locale = NULL;
2959             }
2960             else if (! do_setlocale_c(LC_CTYPE, save_input_locale)) {
2961                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2962                                     "Could not change LC_CTYPE locale to %s\n",
2963                                     save_input_locale));
2964                 Safefree(save_ctype_locale);
2965                 goto cant_use_nllanginfo;
2966             }
2967         }
2968
2969         DEBUG_L(PerlIO_printf(Perl_debug_log, "Current LC_CTYPE locale=%s\n",
2970                                               save_input_locale));
2971
2972         /* Here the current LC_CTYPE is set to the locale of the category whose
2973          * information is desired.  This means that nl_langinfo() and MB_CUR_MAX
2974          * should give the correct results */
2975
2976 #    if defined(HAS_NL_LANGINFO) && defined(CODESET)
2977
2978         { /* The task is easiest if the platform has this POSIX 2001 function */
2979             const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE);
2980                                           /* FALSE => already in dest locale */
2981
2982             DEBUG_L(PerlIO_printf(Perl_debug_log,
2983                             "\tnllanginfo returned CODESET '%s'\n", codeset));
2984
2985             if (codeset && strNE(codeset, "")) {
2986                 /* If we switched LC_CTYPE, switch back */
2987                 if (save_ctype_locale) {
2988                     do_setlocale_c(LC_CTYPE, save_ctype_locale);
2989                     Safefree(save_ctype_locale);
2990                 }
2991
2992                 is_utf8 = (   (   strlen(codeset) == STRLENs("UTF-8")
2993                                && foldEQ(codeset, STR_WITH_LEN("UTF-8")))
2994                            || (   strlen(codeset) == STRLENs("UTF8")
2995                                && foldEQ(codeset, STR_WITH_LEN("UTF8"))));
2996
2997                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2998                        "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n",
2999                                                      codeset,         is_utf8));
3000                 Safefree(save_input_locale);
3001                 return is_utf8;
3002             }
3003         }
3004
3005 #    endif
3006 #    ifdef MB_CUR_MAX
3007
3008         /* Here, either we don't have nl_langinfo, or it didn't return a
3009          * codeset.  Try MB_CUR_MAX */
3010
3011         /* Standard UTF-8 needs at least 4 bytes to represent the maximum
3012          * Unicode code point.  Since UTF-8 is the only non-single byte
3013          * encoding we handle, we just say any such encoding is UTF-8, and if
3014          * turns out to be wrong, other things will fail */
3015         is_utf8 = (unsigned) MB_CUR_MAX >= STRLENs(MAX_UNICODE_UTF8);
3016
3017         DEBUG_L(PerlIO_printf(Perl_debug_log,
3018                               "\tMB_CUR_MAX=%d; ?UTF8 locale=%d\n",
3019                                    (int) MB_CUR_MAX,      is_utf8));
3020
3021         Safefree(save_input_locale);
3022
3023 #      ifdef HAS_MBTOWC
3024
3025         /* ... But, most system that have MB_CUR_MAX will also have mbtowc(),
3026          * since they are both in the C99 standard.  We can feed a known byte
3027          * string to the latter function, and check that it gives the expected
3028          * result */
3029         if (is_utf8) {
3030             wchar_t wc;
3031             int len;
3032
3033             PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
3034             errno = 0;
3035             len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
3036
3037
3038             if (   len != STRLENs(REPLACEMENT_CHARACTER_UTF8)
3039                 || wc != (wchar_t) UNICODE_REPLACEMENT)
3040             {
3041                 is_utf8 = FALSE;
3042                 DEBUG_L(PerlIO_printf(Perl_debug_log, "\replacement=U+%x\n",
3043                                                             (unsigned int)wc));
3044                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3045                         "\treturn from mbtowc=%d; errno=%d; ?UTF8 locale=0\n",
3046                                                len,      errno));
3047             }
3048         }
3049
3050 #      endif
3051
3052         /* If we switched LC_CTYPE, switch back */
3053         if (save_ctype_locale) {
3054             do_setlocale_c(LC_CTYPE, save_ctype_locale);
3055             Safefree(save_ctype_locale);
3056         }
3057
3058         return is_utf8;
3059
3060 #    endif
3061
3062     }
3063
3064   cant_use_nllanginfo:
3065
3066 #  else   /* nl_langinfo should work if available, so don't bother compiling this
3067            fallback code.  The final fallback of looking at the name is
3068            compiled, and will be executed if nl_langinfo fails */
3069
3070     /* nl_langinfo not available or failed somehow.  Next try looking at the
3071      * currency symbol to see if it disambiguates things.  Often that will be
3072      * in the native script, and if the symbol isn't in UTF-8, we know that the
3073      * locale isn't.  If it is non-ASCII UTF-8, we infer that the locale is
3074      * too, as the odds of a non-UTF8 string being valid UTF-8 are quite small
3075      * */
3076
3077 #    ifdef HAS_LOCALECONV
3078 #      ifdef USE_LOCALE_MONETARY
3079
3080     {
3081         char *save_monetary_locale = NULL;
3082         bool only_ascii = FALSE;
3083         bool is_utf8 = FALSE;
3084         struct lconv* lc;
3085
3086         /* Like above for LC_CTYPE, we first set LC_MONETARY to the locale of
3087          * the desired category, if it isn't that locale already */
3088
3089         if (category != LC_MONETARY) {
3090
3091             save_monetary_locale = do_setlocale_c(LC_MONETARY, NULL);
3092             if (! save_monetary_locale) {
3093                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3094                             "Could not find current locale for LC_MONETARY\n"));
3095                 goto cant_use_monetary;
3096             }
3097             save_monetary_locale = stdize_locale(savepv(save_monetary_locale));
3098
3099             if (strEQ(save_monetary_locale, save_input_locale)) {
3100                 Safefree(save_monetary_locale);
3101                 save_monetary_locale = NULL;
3102             }
3103             else if (! do_setlocale_c(LC_MONETARY, save_input_locale)) {
3104                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3105                             "Could not change LC_MONETARY locale to %s\n",
3106                                                         save_input_locale));
3107                 Safefree(save_monetary_locale);
3108                 goto cant_use_monetary;
3109             }
3110         }
3111
3112         /* Here the current LC_MONETARY is set to the locale of the category
3113          * whose information is desired. */
3114
3115         lc = localeconv();
3116         if (! lc
3117             || ! lc->currency_symbol
3118             || is_utf8_invariant_string((U8 *) lc->currency_symbol, 0))
3119         {
3120             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));
3121             only_ascii = TRUE;
3122         }
3123         else {
3124             is_utf8 = is_utf8_string((U8 *) lc->currency_symbol, 0);
3125         }
3126
3127         /* If we changed it, restore LC_MONETARY to its original locale */
3128         if (save_monetary_locale) {
3129             do_setlocale_c(LC_MONETARY, save_monetary_locale);
3130             Safefree(save_monetary_locale);
3131         }
3132
3133         if (! only_ascii) {
3134
3135             /* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
3136              * otherwise assume the locale is UTF-8 if and only if the symbol
3137              * is non-ascii UTF-8. */
3138             DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
3139                                     save_input_locale, is_utf8));
3140             Safefree(save_input_locale);
3141             return is_utf8;
3142         }
3143     }
3144   cant_use_monetary:
3145
3146 #      endif /* USE_LOCALE_MONETARY */
3147 #    endif /* HAS_LOCALECONV */
3148
3149 #    if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME)
3150
3151 /* Still haven't found a non-ASCII string to disambiguate UTF-8 or not.  Try
3152  * the names of the months and weekdays, timezone, and am/pm indicator */
3153     {
3154         char *save_time_locale = NULL;
3155         int hour = 10;
3156         bool is_dst = FALSE;
3157         int dom = 1;
3158         int month = 0;
3159         int i;
3160         char * formatted_time;
3161
3162
3163         /* Like above for LC_MONETARY, we set LC_TIME to the locale of the
3164          * desired category, if it isn't that locale already */
3165
3166         if (category != LC_TIME) {
3167
3168             save_time_locale = do_setlocale_c(LC_TIME, NULL);
3169             if (! save_time_locale) {
3170                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3171                             "Could not find current locale for LC_TIME\n"));
3172                 goto cant_use_time;
3173             }
3174             save_time_locale = stdize_locale(savepv(save_time_locale));
3175
3176             if (strEQ(save_time_locale, save_input_locale)) {
3177                 Safefree(save_time_locale);
3178                 save_time_locale = NULL;
3179             }
3180             else if (! do_setlocale_c(LC_TIME, save_input_locale)) {
3181                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3182                             "Could not change LC_TIME locale to %s\n",
3183                                                         save_input_locale));
3184                 Safefree(save_time_locale);
3185                 goto cant_use_time;
3186             }
3187         }
3188
3189         /* Here the current LC_TIME is set to the locale of the category
3190          * whose information is desired.  Look at all the days of the week and
3191          * month names, and the timezone and am/pm indicator for UTF-8 variant
3192          * characters.  The first such a one found will tell us if the locale
3193          * is UTF-8 or not */
3194
3195         for (i = 0; i < 7 + 12; i++) {  /* 7 days; 12 months */
3196             formatted_time = my_strftime("%A %B %Z %p",
3197                             0, 0, hour, dom, month, 2012 - 1900, 0, 0, is_dst);
3198             if ( ! formatted_time
3199                 || is_utf8_invariant_string((U8 *) formatted_time, 0))
3200             {
3201
3202                 /* Here, we didn't find a non-ASCII.  Try the next time through
3203                  * with the complemented dst and am/pm, and try with the next
3204                  * weekday.  After we have gotten all weekdays, try the next
3205                  * month */
3206                 is_dst = ! is_dst;
3207                 hour = (hour + 12) % 24;
3208                 dom++;
3209                 if (i > 6) {
3210                     month++;
3211                 }
3212                 continue;
3213             }
3214
3215             /* Here, we have a non-ASCII.  Return TRUE is it is valid UTF8;
3216              * false otherwise.  But first, restore LC_TIME to its original
3217              * locale if we changed it */
3218             if (save_time_locale) {
3219                 do_setlocale_c(LC_TIME, save_time_locale);
3220                 Safefree(save_time_locale);
3221             }
3222
3223             DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
3224                                 save_input_locale,
3225                                 is_utf8_string((U8 *) formatted_time, 0)));
3226             Safefree(save_input_locale);
3227             return is_utf8_string((U8 *) formatted_time, 0);
3228         }
3229
3230         /* Falling off the end of the loop indicates all the names were just
3231          * ASCII.  Go on to the next test.  If we changed it, restore LC_TIME
3232          * to its original locale */
3233         if (save_time_locale) {
3234             do_setlocale_c(LC_TIME, save_time_locale);
3235             Safefree(save_time_locale);
3236         }
3237         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));
3238     }
3239   cant_use_time:
3240
3241 #    endif
3242
3243 #    if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST)
3244
3245 /* This code is ifdefd out because it was found to not be necessary in testing
3246  * on our dromedary test machine, which has over 700 locales.  There, this
3247  * added no value to looking at the currency symbol and the time strings.  I
3248  * left it in so as to avoid rewriting it if real-world experience indicates
3249  * that dromedary is an outlier.  Essentially, instead of returning abpve if we
3250  * haven't found illegal utf8, we continue on and examine all the strerror()
3251  * messages on the platform for utf8ness.  If all are ASCII, we still don't
3252  * know the answer; but otherwise we have a pretty good indication of the
3253  * utf8ness.  The reason this doesn't help much is that the messages may not
3254  * have been translated into the locale.  The currency symbol and time strings
3255  * are much more likely to have been translated.  */
3256     {
3257         int e;
3258         bool is_utf8 = FALSE;
3259         bool non_ascii = FALSE;
3260         char *save_messages_locale = NULL;
3261         const char * errmsg = NULL;
3262
3263         /* Like above, we set LC_MESSAGES to the locale of the desired
3264          * category, if it isn't that locale already */
3265
3266         if (category != LC_MESSAGES) {
3267
3268             save_messages_locale = do_setlocale_c(LC_MESSAGES, NULL);
3269             if (! save_messages_locale) {
3270                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3271                             "Could not find current locale for LC_MESSAGES\n"));
3272                 goto cant_use_messages;
3273             }
3274             save_messages_locale = stdize_locale(savepv(save_messages_locale));
3275
3276             if (strEQ(save_messages_locale, save_input_locale)) {
3277                 Safefree(save_messages_locale);
3278                 save_messages_locale = NULL;
3279             }
3280             else if (! do_setlocale_c(LC_MESSAGES, save_input_locale)) {
3281                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3282                             "Could not change LC_MESSAGES locale to %s\n",
3283                                                         save_input_locale));
3284                 Safefree(save_messages_locale);
3285                 goto cant_use_messages;
3286             }
3287         }
3288
3289         /* Here the current LC_MESSAGES is set to the locale of the category
3290          * whose information is desired.  Look through all the messages.  We
3291          * can't use Strerror() here because it may expand to code that
3292          * segfaults in miniperl */
3293
3294         for (e = 0; e <= sys_nerr; e++) {
3295             errno = 0;
3296             errmsg = sys_errlist[e];
3297             if (errno || !errmsg) {
3298                 break;
3299             }
3300             errmsg = savepv(errmsg);
3301             if (! is_utf8_invariant_string((U8 *) errmsg, 0)) {
3302                 non_ascii = TRUE;
3303                 is_utf8 = is_utf8_string((U8 *) errmsg, 0);
3304                 break;
3305             }
3306         }
3307         Safefree(errmsg);
3308
3309         /* And, if we changed it, restore LC_MESSAGES to its original locale */
3310         if (save_messages_locale) {
3311             do_setlocale_c(LC_MESSAGES, save_messages_locale);
3312             Safefree(save_messages_locale);
3313         }
3314
3315         if (non_ascii) {
3316
3317             /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
3318              * any non-ascii means it is one; otherwise we assume it isn't */
3319             DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
3320                                 save_input_locale,
3321                                 is_utf8));
3322             Safefree(save_input_locale);
3323             return is_utf8;
3324         }
3325
3326         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));
3327     }
3328   cant_use_messages:
3329
3330 #    endif
3331 #  endif /* the code that is compiled when no nl_langinfo */
3332
3333 #  ifndef EBCDIC  /* On os390, even if the name ends with "UTF-8', it isn't a
3334                    UTF-8 locale */
3335
3336     /* As a last resort, look at the locale name to see if it matches
3337      * qr/UTF -?  * 8 /ix, or some other common locale names.  This "name", the
3338      * return of setlocale(), is actually defined to be opaque, so we can't
3339      * really rely on the absence of various substrings in the name to indicate
3340      * its UTF-8ness, but if it has UTF8 in the name, it is extremely likely to
3341      * be a UTF-8 locale.  Similarly for the other common names */
3342
3343     final_pos = strlen(save_input_locale) - 1;
3344     if (final_pos >= 3) {
3345         const char *name = save_input_locale;
3346
3347         /* Find next 'U' or 'u' and look from there */
3348         while ((name += strcspn(name, "Uu") + 1)
3349                                             <= save_input_locale + final_pos - 2)
3350         {
3351             if (   isALPHA_FOLD_NE(*name, 't')
3352                 || isALPHA_FOLD_NE(*(name + 1), 'f'))
3353             {
3354                 continue;
3355             }
3356             name += 2;
3357             if (*(name) == '-') {
3358                 if ((name > save_input_locale + final_pos - 1)) {
3359                     break;
3360                 }
3361                 name++;
3362             }
3363             if (*(name) == '8') {
3364                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3365                                       "Locale %s ends with UTF-8 in name\n",
3366                                       save_input_locale));
3367                 Safefree(save_input_locale);
3368                 return TRUE;
3369             }
3370         }
3371         DEBUG_L(PerlIO_printf(Perl_debug_log,
3372                               "Locale %s doesn't end with UTF-8 in name\n",
3373                                 save_input_locale));
3374     }
3375
3376 #  endif
3377 #  ifdef WIN32
3378
3379     /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
3380     if (memENDs(save_input_locale, final_pos, "65001")) {
3381         DEBUG_L(PerlIO_printf(Perl_debug_log,
3382                         "Locale %s ends with 65001 in name, is UTF-8 locale\n",
3383                         save_input_locale));
3384         Safefree(save_input_locale);
3385         return TRUE;
3386     }
3387
3388 #  endif
3389
3390     /* Other common encodings are the ISO 8859 series, which aren't UTF-8.  But
3391      * since we are about to return FALSE anyway, there is no point in doing
3392      * this extra work */
3393
3394 #  if 0
3395     if (instr(save_input_locale, "8859")) {
3396         DEBUG_L(PerlIO_printf(Perl_debug_log,
3397                              "Locale %s has 8859 in name, not UTF-8 locale\n",
3398                              save_input_locale));
3399         Safefree(save_input_locale);
3400         return FALSE;
3401     }
3402 #  endif
3403
3404     DEBUG_L(PerlIO_printf(Perl_debug_log,
3405                           "Assuming locale %s is not a UTF-8 locale\n",
3406                                     save_input_locale));
3407     Safefree(save_input_locale);
3408     return FALSE;
3409 }
3410
3411 #endif
3412
3413
3414 bool
3415 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
3416 {
3417     dVAR;
3418     /* Internal function which returns if we are in the scope of a pragma that
3419      * enables the locale category 'category'.  'compiling' should indicate if
3420      * this is during the compilation phase (TRUE) or not (FALSE). */
3421
3422     const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
3423
3424     SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
3425     if (! categories || categories == &PL_sv_placeholder) {
3426         return FALSE;
3427     }
3428
3429     /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
3430      * a valid unsigned */
3431     assert(category >= -1);
3432     return cBOOL(SvUV(categories) & (1U << (category + 1)));
3433 }
3434
3435 char *
3436 Perl_my_strerror(pTHX_ const int errnum)
3437 {
3438     /* Returns a mortalized copy of the text of the error message associated
3439      * with 'errnum'.  It uses the current locale's text unless the platform
3440      * doesn't have the LC_MESSAGES category or we are not being called from
3441      * within the scope of 'use locale'.  In the former case, it uses whatever
3442      * strerror returns; in the latter case it uses the text from the C locale.
3443      *
3444      * The function just calls strerror(), but temporarily switches, if needed,
3445      * to the C locale */
3446
3447     char *errstr;
3448     dVAR;
3449
3450 #ifndef USE_LOCALE_MESSAGES
3451
3452     /* If platform doesn't have messages category, we don't do any switching to
3453      * the C locale; we just use whatever strerror() returns */
3454
3455     errstr = savepv(Strerror(errnum));
3456
3457 #else   /* Has locale messages */
3458
3459     const bool within_locale_scope = IN_LC(LC_MESSAGES);
3460
3461 #  if defined(HAS_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
3462
3463     /* This function is trivial if we don't have to worry about thread safety
3464      * and have strerror_l(), as it handles the switch of locales so we don't
3465      * have to deal with that.  We don't have to worry about thread safety if
3466      * this is an unthreaded build, or if strerror_r() is also available.  Both
3467      * it and strerror_l() are thread-safe.  Plain strerror() isn't thread
3468      * safe.  But on threaded builds when strerror_r() is available, the
3469      * apparent call to strerror() below is actually a macro that
3470      * behind-the-scenes calls strerror_r().
3471      */
3472
3473 #    if ! defined(USE_ITHREADS) || defined(HAS_STRERROR_R)
3474
3475     if (within_locale_scope) {
3476         errstr = savepv(strerror(errnum));
3477     }
3478     else {
3479         errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
3480     }
3481
3482 #    else
3483
3484     /* Here we have strerror_l(), but not strerror_r() and we are on a
3485      * threaded-build.  We use strerror_l() for everything, constructing a
3486      * locale to pass to it if necessary */
3487
3488     bool do_free = FALSE;
3489     locale_t locale_to_use;
3490
3491     if (within_locale_scope) {
3492         locale_to_use = uselocale((locale_t) 0);
3493         if (locale_to_use == LC_GLOBAL_LOCALE) {
3494             locale_to_use = duplocale(LC_GLOBAL_LOCALE);
3495             do_free = TRUE;
3496         }
3497     }
3498     else {  /* Use C locale if not within 'use locale' scope */
3499         locale_to_use = PL_C_locale_obj;
3500     }
3501
3502     errstr = savepv(strerror_l(errnum, locale_to_use));
3503
3504     if (do_free) {
3505         freelocale(locale_to_use);
3506     }
3507
3508 #    endif
3509 #  else /* Doesn't have strerror_l() */
3510
3511 #    ifdef USE_POSIX_2008_LOCALE
3512
3513     locale_t save_locale = NULL;
3514
3515 #    else
3516
3517     const char * save_locale = NULL;
3518     bool locale_is_C = FALSE;
3519
3520     /* We have a critical section to prevent another thread from changing the
3521      * locale out from under us (or zapping the buffer returned from
3522      * setlocale() ) */
3523     LOCALE_LOCK;
3524
3525 #    endif
3526
3527     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3528                             "my_strerror called with errnum %d\n", errnum));
3529     if (! within_locale_scope) {
3530         errno = 0;
3531
3532 #  ifdef USE_POSIX_2008_LOCALE /* Use the thread-safe locale functions */
3533
3534         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3535                                     "Not within locale scope, about to call"
3536                                     " uselocale(0x%p)\n", PL_C_locale_obj));
3537         save_locale = uselocale(PL_C_locale_obj);
3538         if (! save_locale) {
3539             DEBUG_L(PerlIO_printf(Perl_debug_log,
3540                                     "uselocale failed, errno=%d\n", errno));
3541         }
3542         else {
3543             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3544                                     "uselocale returned 0x%p\n", save_locale));
3545         }
3546
3547 #    else    /* Not thread-safe build */
3548
3549         save_locale = do_setlocale_c(LC_MESSAGES, NULL);
3550         if (! save_locale) {
3551             DEBUG_L(PerlIO_printf(Perl_debug_log,
3552                                   "setlocale failed, errno=%d\n", errno));
3553         }
3554         else {
3555             locale_is_C = isNAME_C_OR_POSIX(save_locale);
3556
3557             /* Switch to the C locale if not already in it */
3558             if (! locale_is_C) {
3559
3560                 /* The setlocale() just below likely will zap 'save_locale', so
3561                  * create a copy.  */
3562                 save_locale = savepv(save_locale);
3563                 do_setlocale_c(LC_MESSAGES, "C");
3564             }
3565         }
3566
3567 #    endif
3568
3569     }   /* end of ! within_locale_scope */
3570     else {
3571         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
3572                                                __FILE__, __LINE__));
3573     }
3574
3575     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3576              "Any locale change has been done; about to call Strerror\n"));
3577     errstr = savepv(Strerror(errnum));
3578
3579     if (! within_locale_scope) {
3580         errno = 0;
3581
3582 #  ifdef USE_POSIX_2008_LOCALE
3583
3584         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3585                     "%s: %d: not within locale scope, restoring the locale\n",
3586                     __FILE__, __LINE__));
3587         if (save_locale && ! uselocale(save_locale)) {
3588             DEBUG_L(PerlIO_printf(Perl_debug_log,
3589                           "uselocale restore failed, errno=%d\n", errno));
3590         }
3591     }
3592
3593 #    else
3594
3595         if (save_locale && ! locale_is_C) {
3596             if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
3597                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3598                       "setlocale restore failed, errno=%d\n", errno));
3599             }
3600             Safefree(save_locale);
3601         }
3602     }
3603
3604     LOCALE_UNLOCK;
3605
3606 #    endif
3607 #  endif /* End of doesn't have strerror_l */
3608 #endif   /* End of does have locale messages */
3609
3610 #ifdef DEBUGGING
3611
3612     if (DEBUG_Lv_TEST) {
3613         PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
3614         print_bytes_for_locale(errstr, errstr + strlen(errstr), 0);
3615         PerlIO_printf(Perl_debug_log, "'\n");
3616     }
3617
3618 #endif
3619
3620     SAVEFREEPV(errstr);
3621     return errstr;
3622 }
3623
3624 /*
3625
3626 =for apidoc sync_locale
3627
3628 Changing the program's locale should be avoided by XS code.  Nevertheless,
3629 certain non-Perl libraries called from XS, such as C<Gtk> do so.  When this
3630 happens, Perl needs to be told that the locale has changed.  Use this function
3631 to do so, before returning to Perl.
3632
3633 =cut
3634 */
3635
3636 void
3637 Perl_sync_locale(pTHX)
3638 {
3639     char * newlocale;
3640
3641 #ifdef USE_LOCALE_CTYPE
3642
3643     newlocale = do_setlocale_c(LC_CTYPE, NULL);
3644     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3645         "%s:%d: %s\n", __FILE__, __LINE__,
3646         setlocale_debug_string(LC_CTYPE, NULL, newlocale)));
3647     new_ctype(newlocale);
3648
3649 #endif /* USE_LOCALE_CTYPE */
3650 #ifdef USE_LOCALE_COLLATE
3651
3652     newlocale = do_setlocale_c(LC_COLLATE, NULL);
3653     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3654         "%s:%d: %s\n", __FILE__, __LINE__,
3655         setlocale_debug_string(LC_COLLATE, NULL, newlocale)));
3656     new_collate(newlocale);
3657
3658 #endif
3659 #ifdef USE_LOCALE_NUMERIC
3660
3661     newlocale = do_setlocale_c(LC_NUMERIC, NULL);
3662     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3663         "%s:%d: %s\n", __FILE__, __LINE__,
3664         setlocale_debug_string(LC_NUMERIC, NULL, newlocale)));
3665     new_numeric(newlocale);
3666
3667 #endif /* USE_LOCALE_NUMERIC */
3668
3669 }
3670
3671 #if defined(DEBUGGING) && defined(USE_LOCALE)
3672
3673 STATIC char *
3674 S_setlocale_debug_string(const int category,        /* category number,
3675                                                            like LC_ALL */
3676                             const char* const locale,   /* locale name */
3677
3678                             /* return value from setlocale() when attempting to
3679                              * set 'category' to 'locale' */
3680                             const char* const retval)
3681 {
3682     /* Returns a pointer to a NUL-terminated string in static storage with
3683      * added text about the info passed in.  This is not thread safe and will
3684      * be overwritten by the next call, so this should be used just to
3685      * formulate a string to immediately print or savepv() on. */
3686
3687     /* initialise to a non-null value to keep it out of BSS and so keep
3688      * -DPERL_GLOBAL_STRUCT_PRIVATE happy */
3689     static char ret[128] = "If you can read this, thank your buggy C"
3690                            " library strlcpy(), and change your hints file"
3691                            " to undef it";
3692
3693     my_strlcpy(ret, "setlocale(", sizeof(ret));
3694     my_strlcat(ret, category_name(category), sizeof(ret));
3695     my_strlcat(ret, ", ", sizeof(ret));
3696
3697     if (locale) {
3698         my_strlcat(ret, "\"", sizeof(ret));
3699         my_strlcat(ret, locale, sizeof(ret));
3700         my_strlcat(ret, "\"", sizeof(ret));
3701     }
3702     else {
3703         my_strlcat(ret, "NULL", sizeof(ret));
3704     }
3705
3706     my_strlcat(ret, ") returned ", sizeof(ret));
3707
3708     if (retval) {
3709         my_strlcat(ret, "\"", sizeof(ret));
3710         my_strlcat(ret, retval, sizeof(ret));
3711         my_strlcat(ret, "\"", sizeof(ret));
3712     }
3713     else {
3714         my_strlcat(ret, "NULL", sizeof(ret));
3715     }
3716
3717     assert(strlen(ret) < sizeof(ret));
3718
3719     return ret;
3720 }
3721
3722 #endif
3723
3724
3725 /*
3726  * ex: set ts=8 sts=4 sw=4 et:
3727  */