This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
locale.c: Refactor Ultrix code
[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     /* setlocale() return vals; not copied so must be looked at immediately */
1833     const char * sl_result[NOMINAL_LC_ALL_INDEX + 1];
1834
1835     /* current locale for given category; should have been copied so aren't
1836      * volatile */
1837     const char * curlocales[NOMINAL_LC_ALL_INDEX + 1];
1838
1839 #  ifdef WIN32
1840
1841     /* In some systems you can find out the system default locale
1842      * and use that as the fallback locale. */
1843 #    define SYSTEM_DEFAULT_LOCALE
1844 #  endif
1845 #  ifdef SYSTEM_DEFAULT_LOCALE
1846
1847     const char *system_default_locale = NULL;
1848
1849 #  endif
1850
1851 #  ifndef DEBUGGING
1852 #    define DEBUG_LOCALE_INIT(a,b,c)
1853 #  else
1854
1855     DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
1856
1857 #    define DEBUG_LOCALE_INIT(category, locale, result)                     \
1858         STMT_START {                                                        \
1859                 if (debug_initialization) {                                 \
1860                     PerlIO_printf(Perl_debug_log,                           \
1861                                   "%s:%d: %s\n",                            \
1862                                   __FILE__, __LINE__,                       \
1863                                   setlocale_debug_string(category,          \
1864                                                           locale,           \
1865                                                           result));         \
1866                 }                                                           \
1867         } STMT_END
1868
1869 /* Make sure the parallel arrays are properly set up */
1870 #    ifdef USE_LOCALE_NUMERIC
1871     assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
1872     assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
1873 #    endif
1874 #    ifdef USE_LOCALE_CTYPE
1875     assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
1876     assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
1877 #    endif
1878 #    ifdef USE_LOCALE_COLLATE
1879     assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
1880     assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
1881 #    endif
1882 #    ifdef USE_LOCALE_TIME
1883     assert(categories[LC_TIME_INDEX] == LC_TIME);
1884     assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
1885 #    endif
1886 #    ifdef USE_LOCALE_MESSAGES
1887     assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
1888     assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
1889 #    endif
1890 #    ifdef USE_LOCALE_MONETARY
1891     assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
1892     assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
1893 #    endif
1894 #    ifdef LC_ALL
1895     assert(categories[LC_ALL_INDEX] == LC_ALL);
1896     assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
1897     assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
1898 #    endif
1899 #  endif    /* DEBUGGING */
1900 #  ifdef LOCALE_ENVIRON_REQUIRED
1901
1902     /*
1903      * Ultrix setlocale(..., "") fails if there are no environment
1904      * variables from which to get a locale name.
1905      */
1906
1907 #    ifndef LC_ALL
1908 #      error Ultrix without LC_ALL not implemented
1909 #    else
1910
1911     {
1912         bool done = FALSE;
1913     if (lang) {
1914         sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, setlocale_init);
1915         DEBUG_LOCALE_INIT(LC_ALL, setlocale_init, sl_result[LC_ALL_INDEX]);
1916         if (sl_result[LC_ALL_INDEX])
1917             done = TRUE;
1918         else
1919             setlocale_failure = TRUE;
1920     }
1921     if (! setlocale_failure) {
1922         const char * locale_param;
1923         for (i = 0; i < LC_ALL_INDEX; i++) {
1924             locale_param = (! done && (lang || PerlEnv_getenv(category_names[i])))
1925                            ? setlocale_init
1926                            : NULL;
1927             sl_result[i] = do_setlocale_r(categories[i], locale_param);
1928             if (! sl_result[i]) {
1929                 setlocale_failure = TRUE;
1930             }
1931             DEBUG_LOCALE_INIT(categories[i], locale_param, sl_result[i]);
1932         }
1933     }
1934     }
1935
1936 #    endif /* LC_ALL */
1937 #  endif /* LOCALE_ENVIRON_REQUIRED */
1938
1939     /* We try each locale in the list until we get one that works, or exhaust
1940      * the list.  Normally the loop is executed just once.  But if setting the
1941      * locale fails, inside the loop we add fallback trials to the array and so
1942      * will execute the loop multiple times */
1943     trial_locales[0] = setlocale_init;
1944     trial_locales_count = 1;
1945
1946     for (i= 0; i < trial_locales_count; i++) {
1947         const char * trial_locale = trial_locales[i];
1948
1949         if (i > 0) {
1950
1951             /* XXX This is to preserve old behavior for LOCALE_ENVIRON_REQUIRED
1952              * when i==0, but I (khw) don't think that behavior makes much
1953              * sense */
1954             setlocale_failure = FALSE;
1955
1956 #  ifdef SYSTEM_DEFAULT_LOCALE
1957 #    ifdef WIN32    /* Note that assumes Win32 has LC_ALL */
1958
1959             /* On Windows machines, an entry of "" after the 0th means to use
1960              * the system default locale, which we now proceed to get. */
1961             if (strEQ(trial_locale, "")) {
1962                 unsigned int j;
1963
1964                 /* Note that this may change the locale, but we are going to do
1965                  * that anyway just below */
1966                 system_default_locale = do_setlocale_c(LC_ALL, "");
1967                 DEBUG_LOCALE_INIT(LC_ALL, "", system_default_locale);
1968
1969                 /* Skip if invalid or if it's already on the list of locales to
1970                  * try */
1971                 if (! system_default_locale) {
1972                     goto next_iteration;
1973                 }
1974                 for (j = 0; j < trial_locales_count; j++) {
1975                     if (strEQ(system_default_locale, trial_locales[j])) {
1976                         goto next_iteration;
1977                     }
1978                 }
1979
1980                 trial_locale = system_default_locale;
1981             }
1982 #    endif /* WIN32 */
1983 #  endif /* SYSTEM_DEFAULT_LOCALE */
1984
1985         }   /* For i > 0 */
1986
1987 #  ifdef LC_ALL
1988
1989         sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, trial_locale);
1990         DEBUG_LOCALE_INIT(LC_ALL, trial_locale, sl_result[LC_ALL_INDEX]);
1991         if (! sl_result[LC_ALL_INDEX]) {
1992             setlocale_failure = TRUE;
1993         }
1994         else {
1995             /* Since LC_ALL succeeded, it should have changed all the other
1996              * categories it can to its value; so we massage things so that the
1997              * setlocales below just return their category's current values.
1998              * This adequately handles the case in NetBSD where LC_COLLATE may
1999              * not be defined for a locale, and setting it individually will
2000              * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to
2001              * the POSIX locale. */
2002             trial_locale = NULL;
2003         }
2004
2005 #  endif /* LC_ALL */
2006
2007         if (! setlocale_failure) {
2008             unsigned int j;
2009             for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2010                 curlocales[j]
2011                         = savepv(do_setlocale_r(categories[j], trial_locale));
2012                 if (! curlocales[j]) {
2013                     setlocale_failure = TRUE;
2014                 }
2015                 DEBUG_LOCALE_INIT(categories[j], trial_locale, curlocales[j]);
2016             }
2017
2018             if (! setlocale_failure) {  /* All succeeded */
2019                 break;  /* Exit trial_locales loop */
2020             }
2021         }
2022
2023         /* Here, something failed; will need to try a fallback. */
2024         ok = 0;
2025
2026         if (i == 0) {
2027             unsigned int j;
2028
2029             if (locwarn) { /* Output failure info only on the first one */
2030
2031 #  ifdef LC_ALL
2032
2033                 PerlIO_printf(Perl_error_log,
2034                 "perl: warning: Setting locale failed.\n");
2035
2036 #  else /* !LC_ALL */
2037
2038                 PerlIO_printf(Perl_error_log,
2039                 "perl: warning: Setting locale failed for the categories:\n\t");
2040
2041                 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2042                     if (! curlocales[j]) {
2043                         PerlIO_printf(Perl_error_log, category_names[j]);
2044                     }
2045                     else {
2046                         Safefree(curlocales[j]);
2047                     }
2048                 }
2049
2050                 PerlIO_printf(Perl_error_log, "and possibly others\n");
2051
2052 #  endif /* LC_ALL */
2053
2054                 PerlIO_printf(Perl_error_log,
2055                     "perl: warning: Please check that your locale settings:\n");
2056
2057 #  ifdef __GLIBC__
2058
2059                 PerlIO_printf(Perl_error_log,
2060                             "\tLANGUAGE = %c%s%c,\n",
2061                             language ? '"' : '(',
2062                             language ? language : "unset",
2063                             language ? '"' : ')');
2064 #  endif
2065
2066                 PerlIO_printf(Perl_error_log,
2067                             "\tLC_ALL = %c%s%c,\n",
2068                             lc_all ? '"' : '(',
2069                             lc_all ? lc_all : "unset",
2070                             lc_all ? '"' : ')');
2071
2072 #  if defined(USE_ENVIRON_ARRAY)
2073
2074                 {
2075                     char **e;
2076
2077                     /* Look through the environment for any variables of the
2078                      * form qr/ ^ LC_ [A-Z]+ = /x, except LC_ALL which was
2079                      * already handled above.  These are assumed to be locale
2080                      * settings.  Output them and their values. */
2081                     for (e = environ; *e; e++) {
2082                         const STRLEN prefix_len = sizeof("LC_") - 1;
2083                         STRLEN uppers_len;
2084
2085                         if (     strBEGINs(*e, "LC_")
2086                             && ! strBEGINs(*e, "LC_ALL=")
2087                             && (uppers_len = strspn(*e + prefix_len,
2088                                              "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
2089                             && ((*e)[prefix_len + uppers_len] == '='))
2090                         {
2091                             PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
2092                                 (int) (prefix_len + uppers_len), *e,
2093                                 *e + prefix_len + uppers_len + 1);
2094                         }
2095                     }
2096                 }
2097
2098 #  else
2099
2100                 PerlIO_printf(Perl_error_log,
2101                             "\t(possibly more locale environment variables)\n");
2102
2103 #  endif
2104
2105                 PerlIO_printf(Perl_error_log,
2106                             "\tLANG = %c%s%c\n",
2107                             lang ? '"' : '(',
2108                             lang ? lang : "unset",
2109                             lang ? '"' : ')');
2110
2111                 PerlIO_printf(Perl_error_log,
2112                             "    are supported and installed on your system.\n");
2113             }
2114
2115             /* Calculate what fallback locales to try.  We have avoided this
2116              * until we have to, because failure is quite unlikely.  This will
2117              * usually change the upper bound of the loop we are in.
2118              *
2119              * Since the system's default way of setting the locale has not
2120              * found one that works, We use Perl's defined ordering: LC_ALL,
2121              * LANG, and the C locale.  We don't try the same locale twice, so
2122              * don't add to the list if already there.  (On POSIX systems, the
2123              * LC_ALL element will likely be a repeat of the 0th element "",
2124              * but there's no harm done by doing it explicitly.
2125              *
2126              * Note that this tries the LC_ALL environment variable even on
2127              * systems which have no LC_ALL locale setting.  This may or may
2128              * not have been originally intentional, but there's no real need
2129              * to change the behavior. */
2130             if (lc_all) {
2131                 for (j = 0; j < trial_locales_count; j++) {
2132                     if (strEQ(lc_all, trial_locales[j])) {
2133                         goto done_lc_all;
2134                     }
2135                 }
2136                 trial_locales[trial_locales_count++] = lc_all;
2137             }
2138           done_lc_all:
2139
2140             if (lang) {
2141                 for (j = 0; j < trial_locales_count; j++) {
2142                     if (strEQ(lang, trial_locales[j])) {
2143                         goto done_lang;
2144                     }
2145                 }
2146                 trial_locales[trial_locales_count++] = lang;
2147             }
2148           done_lang:
2149
2150 #  if defined(WIN32) && defined(LC_ALL)
2151
2152             /* For Windows, we also try the system default locale before "C".
2153              * (If there exists a Windows without LC_ALL we skip this because
2154              * it gets too complicated.  For those, the "C" is the next
2155              * fallback possibility).  The "" is the same as the 0th element of
2156              * the array, but the code at the loop above knows to treat it
2157              * differently when not the 0th */
2158             trial_locales[trial_locales_count++] = "";
2159
2160 #  endif
2161
2162             for (j = 0; j < trial_locales_count; j++) {
2163                 if (strEQ("C", trial_locales[j])) {
2164                     goto done_C;
2165                 }
2166             }
2167             trial_locales[trial_locales_count++] = "C";
2168
2169           done_C: ;
2170         }   /* end of first time through the loop */
2171
2172 #  ifdef WIN32
2173
2174       next_iteration: ;
2175
2176 #  endif
2177
2178     }   /* end of looping through the trial locales */
2179
2180     if (ok < 1) {   /* If we tried to fallback */
2181         const char* msg;
2182         if (! setlocale_failure) {  /* fallback succeeded */
2183            msg = "Falling back to";
2184         }
2185         else {  /* fallback failed */
2186             unsigned int j;
2187
2188             /* We dropped off the end of the loop, so have to decrement i to
2189              * get back to the value the last time through */
2190             i--;
2191
2192             ok = -1;
2193             msg = "Failed to fall back to";
2194
2195             /* To continue, we should use whatever values we've got */
2196
2197             for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
2198                 Safefree(curlocales[j]);
2199                 curlocales[j] = savepv(do_setlocale_r(categories[j], NULL));
2200                 DEBUG_LOCALE_INIT(categories[j], NULL, curlocales[j]);
2201             }
2202         }
2203
2204         if (locwarn) {
2205             const char * description;
2206             const char * name = "";
2207             if (strEQ(trial_locales[i], "C")) {
2208                 description = "the standard locale";
2209                 name = "C";
2210             }
2211
2212 #  ifdef SYSTEM_DEFAULT_LOCALE
2213
2214             else if (strEQ(trial_locales[i], "")) {
2215                 description = "the system default locale";
2216                 if (system_default_locale) {
2217                     name = system_default_locale;
2218                 }
2219             }
2220
2221 #  endif /* SYSTEM_DEFAULT_LOCALE */
2222
2223             else {
2224                 description = "a fallback locale";
2225                 name = trial_locales[i];
2226             }
2227             if (name && strNE(name, "")) {
2228                 PerlIO_printf(Perl_error_log,
2229                     "perl: warning: %s %s (\"%s\").\n", msg, description, name);
2230             }
2231             else {
2232                 PerlIO_printf(Perl_error_log,
2233                                    "perl: warning: %s %s.\n", msg, description);
2234             }
2235         }
2236     } /* End of tried to fallback */
2237
2238     /* Done with finding the locales; update our records */
2239
2240 #  ifdef USE_LOCALE_CTYPE
2241
2242     new_ctype(curlocales[LC_CTYPE_INDEX]);
2243
2244 #  endif
2245 #  ifdef USE_LOCALE_COLLATE
2246
2247     new_collate(curlocales[LC_COLLATE_INDEX]);
2248
2249 #  endif
2250 #  ifdef USE_LOCALE_NUMERIC
2251
2252     new_numeric(curlocales[LC_NUMERIC_INDEX]);
2253
2254 #  endif
2255
2256
2257     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
2258         Safefree(curlocales[i]);
2259     }
2260
2261 #  if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
2262
2263     /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
2264      * locale is UTF-8.  If PL_utf8locale and PL_unicode (set by -C or by
2265      * $ENV{PERL_UNICODE}) are true, perl.c:S_parse_body() will turn on the
2266      * PerlIO :utf8 layer on STDIN, STDOUT, STDERR, _and_ the default open
2267      * discipline.  */
2268     PL_utf8locale = _is_cur_LC_category_utf8(LC_CTYPE);
2269
2270     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
2271        This is an alternative to using the -C command line switch
2272        (the -C if present will override this). */
2273     {
2274          const char *p = PerlEnv_getenv("PERL_UNICODE");
2275          PL_unicode = p ? parse_unicode_opts(&p) : 0;
2276          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
2277              PL_utf8cache = -1;
2278     }
2279
2280 #  endif
2281 #  ifdef __GLIBC__
2282
2283     Safefree(language);
2284
2285 #  endif
2286
2287     Safefree(lc_all);
2288     Safefree(lang);
2289
2290 #endif /* USE_LOCALE */
2291 #ifdef DEBUGGING
2292
2293     /* So won't continue to output stuff */
2294     DEBUG_INITIALIZATION_set(FALSE);
2295
2296 #endif
2297
2298     return ok;
2299 }
2300
2301 #ifdef USE_LOCALE_COLLATE
2302
2303 char *
2304 Perl__mem_collxfrm(pTHX_ const char *input_string,
2305                          STRLEN len,    /* Length of 'input_string' */
2306                          STRLEN *xlen,  /* Set to length of returned string
2307                                            (not including the collation index
2308                                            prefix) */
2309                          bool utf8      /* Is the input in UTF-8? */
2310                    )
2311 {
2312
2313     /* _mem_collxfrm() is a bit like strxfrm() but with two important
2314      * differences. First, it handles embedded NULs. Second, it allocates a bit
2315      * more memory than needed for the transformed data itself.  The real
2316      * transformed data begins at offset COLLXFRM_HDR_LEN.  *xlen is set to
2317      * the length of that, and doesn't include the collation index size.
2318      * Please see sv_collxfrm() to see how this is used. */
2319
2320 #define COLLXFRM_HDR_LEN    sizeof(PL_collation_ix)
2321
2322     char * s = (char *) input_string;
2323     STRLEN s_strlen = strlen(input_string);
2324     char *xbuf = NULL;
2325     STRLEN xAlloc;          /* xalloc is a reserved word in VC */
2326     STRLEN length_in_chars;
2327     bool first_time = TRUE; /* Cleared after first loop iteration */
2328
2329     PERL_ARGS_ASSERT__MEM_COLLXFRM;
2330
2331     /* Must be NUL-terminated */
2332     assert(*(input_string + len) == '\0');
2333
2334     /* If this locale has defective collation, skip */
2335     if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
2336         DEBUG_L(PerlIO_printf(Perl_debug_log,
2337                       "_mem_collxfrm: locale's collation is defective\n"));
2338         goto bad;
2339     }
2340
2341     /* Replace any embedded NULs with the control that sorts before any others.
2342      * This will give as good as possible results on strings that don't
2343      * otherwise contain that character, but otherwise there may be
2344      * less-than-perfect results with that character and NUL.  This is
2345      * unavoidable unless we replace strxfrm with our own implementation. */
2346     if (UNLIKELY(s_strlen < len)) {   /* Only execute if there is an embedded
2347                                          NUL */
2348         char * e = s + len;
2349         char * sans_nuls;
2350         STRLEN sans_nuls_len;
2351         int try_non_controls;
2352         char this_replacement_char[] = "?\0";   /* Room for a two-byte string,
2353                                                    making sure 2nd byte is NUL.
2354                                                  */
2355         STRLEN this_replacement_len;
2356
2357         /* If we don't know what non-NUL control character sorts lowest for
2358          * this locale, find it */
2359         if (PL_strxfrm_NUL_replacement == '\0') {
2360             int j;
2361             char * cur_min_x = NULL;    /* The min_char's xfrm, (except it also
2362                                            includes the collation index
2363                                            prefixed. */
2364
2365             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
2366
2367             /* Unlikely, but it may be that no control will work to replace
2368              * NUL, in which case we instead look for any character.  Controls
2369              * are preferred because collation order is, in general, context
2370              * sensitive, with adjoining characters affecting the order, and
2371              * controls are less likely to have such interactions, allowing the
2372              * NUL-replacement to stand on its own.  (Another way to look at it
2373              * is to imagine what would happen if the NUL were replaced by a
2374              * combining character; it wouldn't work out all that well.) */
2375             for (try_non_controls = 0;
2376                  try_non_controls < 2;
2377                  try_non_controls++)
2378             {
2379                 /* Look through all legal code points (NUL isn't) */
2380                 for (j = 1; j < 256; j++) {
2381                     char * x;       /* j's xfrm plus collation index */
2382                     STRLEN x_len;   /* length of 'x' */
2383                     STRLEN trial_len = 1;
2384                     char cur_source[] = { '\0', '\0' };
2385
2386                     /* Skip non-controls the first time through the loop.  The
2387                      * controls in a UTF-8 locale are the L1 ones */
2388                     if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
2389                                                ? ! isCNTRL_L1(j)
2390                                                : ! isCNTRL_LC(j))
2391                     {
2392                         continue;
2393                     }
2394
2395                     /* Create a 1-char string of the current code point */
2396                     cur_source[0] = (char) j;
2397
2398                     /* Then transform it */
2399                     x = _mem_collxfrm(cur_source, trial_len, &x_len,
2400                                       0 /* The string is not in UTF-8 */);
2401
2402                     /* Ignore any character that didn't successfully transform.
2403                      * */
2404                     if (! x) {
2405                         continue;
2406                     }
2407
2408                     /* If this character's transformation is lower than
2409                      * the current lowest, this one becomes the lowest */
2410                     if (   cur_min_x == NULL
2411                         || strLT(x         + COLLXFRM_HDR_LEN,
2412                                  cur_min_x + COLLXFRM_HDR_LEN))
2413                     {
2414                         PL_strxfrm_NUL_replacement = j;
2415                         cur_min_x = x;
2416                     }
2417                     else {
2418                         Safefree(x);
2419                     }
2420                 } /* end of loop through all 255 characters */
2421
2422                 /* Stop looking if found */
2423                 if (cur_min_x) {
2424                     break;
2425                 }
2426
2427                 /* Unlikely, but possible, if there aren't any controls that
2428                  * work in the locale, repeat the loop, looking for any
2429                  * character that works */
2430                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2431                 "_mem_collxfrm: No control worked.  Trying non-controls\n"));
2432             } /* End of loop to try first the controls, then any char */
2433
2434             if (! cur_min_x) {
2435                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2436                     "_mem_collxfrm: Couldn't find any character to replace"
2437                     " embedded NULs in locale %s with", PL_collation_name));
2438                 goto bad;
2439             }
2440
2441             DEBUG_L(PerlIO_printf(Perl_debug_log,
2442                     "_mem_collxfrm: Replacing embedded NULs in locale %s with "
2443                     "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
2444
2445             Safefree(cur_min_x);
2446         } /* End of determining the character that is to replace NULs */
2447
2448         /* If the replacement is variant under UTF-8, it must match the
2449          * UTF8-ness of the original */
2450         if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
2451             this_replacement_char[0] =
2452                                 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
2453             this_replacement_char[1] =
2454                                 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
2455             this_replacement_len = 2;
2456         }
2457         else {
2458             this_replacement_char[0] = PL_strxfrm_NUL_replacement;
2459             /* this_replacement_char[1] = '\0' was done at initialization */
2460             this_replacement_len = 1;
2461         }
2462
2463         /* The worst case length for the replaced string would be if every
2464          * character in it is NUL.  Multiply that by the length of each
2465          * replacement, and allow for a trailing NUL */
2466         sans_nuls_len = (len * this_replacement_len) + 1;
2467         Newx(sans_nuls, sans_nuls_len, char);
2468         *sans_nuls = '\0';
2469
2470         /* Replace each NUL with the lowest collating control.  Loop until have
2471          * exhausted all the NULs */
2472         while (s + s_strlen < e) {
2473             my_strlcat(sans_nuls, s, sans_nuls_len);
2474
2475             /* Do the actual replacement */
2476             my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
2477
2478             /* Move past the input NUL */
2479             s += s_strlen + 1;
2480             s_strlen = strlen(s);
2481         }
2482
2483         /* And add anything that trails the final NUL */
2484         my_strlcat(sans_nuls, s, sans_nuls_len);
2485
2486         /* Switch so below we transform this modified string */
2487         s = sans_nuls;
2488         len = strlen(s);
2489     } /* End of replacing NULs */
2490
2491     /* Make sure the UTF8ness of the string and locale match */
2492     if (utf8 != PL_in_utf8_COLLATE_locale) {
2493         const char * const t = s;   /* Temporary so we can later find where the
2494                                        input was */
2495
2496         /* Here they don't match.  Change the string's to be what the locale is
2497          * expecting */
2498
2499         if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
2500             s = (char *) bytes_to_utf8((const U8 *) s, &len);
2501             utf8 = TRUE;
2502         }
2503         else {   /* locale is not UTF-8; but input is; downgrade the input */
2504
2505             s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
2506
2507             /* If the downgrade was successful we are done, but if the input
2508              * contains things that require UTF-8 to represent, have to do
2509              * damage control ... */
2510             if (UNLIKELY(utf8)) {
2511
2512                 /* What we do is construct a non-UTF-8 string with
2513                  *  1) the characters representable by a single byte converted
2514                  *     to be so (if necessary);
2515                  *  2) and the rest converted to collate the same as the
2516                  *     highest collating representable character.  That makes
2517                  *     them collate at the end.  This is similar to how we
2518                  *     handle embedded NULs, but we use the highest collating
2519                  *     code point instead of the smallest.  Like the NUL case,
2520                  *     this isn't perfect, but is the best we can reasonably
2521                  *     do.  Every above-255 code point will sort the same as
2522                  *     the highest-sorting 0-255 code point.  If that code
2523                  *     point can combine in a sequence with some other code
2524                  *     points for weight calculations, us changing something to
2525                  *     be it can adversely affect the results.  But in most
2526                  *     cases, it should work reasonably.  And note that this is
2527                  *     really an illegal situation: using code points above 255
2528                  *     on a locale where only 0-255 are valid.  If two strings
2529                  *     sort entirely equal, then the sort order for the
2530                  *     above-255 code points will be in code point order. */
2531
2532                 utf8 = FALSE;
2533
2534                 /* If we haven't calculated the code point with the maximum
2535                  * collating order for this locale, do so now */
2536                 if (! PL_strxfrm_max_cp) {
2537                     int j;
2538
2539                     /* The current transformed string that collates the
2540                      * highest (except it also includes the prefixed collation
2541                      * index. */
2542                     char * cur_max_x = NULL;
2543
2544                     /* Look through all legal code points (NUL isn't) */
2545                     for (j = 1; j < 256; j++) {
2546                         char * x;
2547                         STRLEN x_len;
2548                         char cur_source[] = { '\0', '\0' };
2549
2550                         /* Create a 1-char string of the current code point */
2551                         cur_source[0] = (char) j;
2552
2553                         /* Then transform it */
2554                         x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
2555
2556                         /* If something went wrong (which it shouldn't), just
2557                          * ignore this code point */
2558                         if (! x) {
2559                             continue;
2560                         }
2561
2562                         /* If this character's transformation is higher than
2563                          * the current highest, this one becomes the highest */
2564                         if (   cur_max_x == NULL
2565                             || strGT(x         + COLLXFRM_HDR_LEN,
2566                                      cur_max_x + COLLXFRM_HDR_LEN))
2567                         {
2568                             PL_strxfrm_max_cp = j;
2569                             cur_max_x = x;
2570                         }
2571                         else {
2572                             Safefree(x);
2573                         }
2574                     }
2575
2576                     if (! cur_max_x) {
2577                         DEBUG_L(PerlIO_printf(Perl_debug_log,
2578                             "_mem_collxfrm: Couldn't find any character to"
2579                             " replace above-Latin1 chars in locale %s with",
2580                             PL_collation_name));
2581                         goto bad;
2582                     }
2583
2584                     DEBUG_L(PerlIO_printf(Perl_debug_log,
2585                             "_mem_collxfrm: highest 1-byte collating character"
2586                             " in locale %s is 0x%02X\n",
2587                             PL_collation_name,
2588                             PL_strxfrm_max_cp));
2589
2590                     Safefree(cur_max_x);
2591                 }
2592
2593                 /* Here we know which legal code point collates the highest.
2594                  * We are ready to construct the non-UTF-8 string.  The length
2595                  * will be at least 1 byte smaller than the input string
2596                  * (because we changed at least one 2-byte character into a
2597                  * single byte), but that is eaten up by the trailing NUL */
2598                 Newx(s, len, char);
2599
2600                 {
2601                     STRLEN i;
2602                     STRLEN d= 0;
2603                     char * e = (char *) t + len;
2604
2605                     for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
2606                         U8 cur_char = t[i];
2607                         if (UTF8_IS_INVARIANT(cur_char)) {
2608                             s[d++] = cur_char;
2609                         }
2610                         else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
2611                             s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
2612                         }
2613                         else {  /* Replace illegal cp with highest collating
2614                                    one */
2615                             s[d++] = PL_strxfrm_max_cp;
2616                         }
2617                     }
2618                     s[d++] = '\0';
2619                     Renew(s, d, char);   /* Free up unused space */
2620                 }
2621             }
2622         }
2623
2624         /* Here, we have constructed a modified version of the input.  It could
2625          * be that we already had a modified copy before we did this version.
2626          * If so, that copy is no longer needed */
2627         if (t != input_string) {
2628             Safefree(t);
2629         }
2630     }
2631
2632     length_in_chars = (utf8)
2633                       ? utf8_length((U8 *) s, (U8 *) s + len)
2634                       : len;
2635
2636     /* The first element in the output is the collation id, used by
2637      * sv_collxfrm(); then comes the space for the transformed string.  The
2638      * equation should give us a good estimate as to how much is needed */
2639     xAlloc = COLLXFRM_HDR_LEN
2640            + PL_collxfrm_base
2641            + (PL_collxfrm_mult * length_in_chars);
2642     Newx(xbuf, xAlloc, char);
2643     if (UNLIKELY(! xbuf)) {
2644         DEBUG_L(PerlIO_printf(Perl_debug_log,
2645                       "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
2646         goto bad;
2647     }
2648
2649     /* Store the collation id */
2650     *(U32*)xbuf = PL_collation_ix;
2651
2652     /* Then the transformation of the input.  We loop until successful, or we
2653      * give up */
2654     for (;;) {
2655
2656         *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
2657
2658         /* If the transformed string occupies less space than we told strxfrm()
2659          * was available, it means it successfully transformed the whole
2660          * string. */
2661         if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
2662
2663             /* Some systems include a trailing NUL in the returned length.
2664              * Ignore it, using a loop in case multiple trailing NULs are
2665              * returned. */
2666             while (   (*xlen) > 0
2667                    && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
2668             {
2669                 (*xlen)--;
2670             }
2671
2672             /* If the first try didn't get it, it means our prediction was low.
2673              * Modify the coefficients so that we predict a larger value in any
2674              * future transformations */
2675             if (! first_time) {
2676                 STRLEN needed = *xlen + 1;   /* +1 For trailing NUL */
2677                 STRLEN computed_guess = PL_collxfrm_base
2678                                       + (PL_collxfrm_mult * length_in_chars);
2679
2680                 /* On zero-length input, just keep current slope instead of
2681                  * dividing by 0 */
2682                 const STRLEN new_m = (length_in_chars != 0)
2683                                      ? needed / length_in_chars
2684                                      : PL_collxfrm_mult;
2685
2686                 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2687                     "%s: %d: initial size of %zu bytes for a length "
2688                     "%zu string was insufficient, %zu needed\n",
2689                     __FILE__, __LINE__,
2690                     computed_guess, length_in_chars, needed));
2691
2692                 /* If slope increased, use it, but discard this result for
2693                  * length 1 strings, as we can't be sure that it's a real slope
2694                  * change */
2695                 if (length_in_chars > 1 && new_m  > PL_collxfrm_mult) {
2696
2697 #  ifdef DEBUGGING
2698
2699                     STRLEN old_m = PL_collxfrm_mult;
2700                     STRLEN old_b = PL_collxfrm_base;
2701
2702 #  endif
2703
2704                     PL_collxfrm_mult = new_m;
2705                     PL_collxfrm_base = 1;   /* +1 For trailing NUL */
2706                     computed_guess = PL_collxfrm_base
2707                                     + (PL_collxfrm_mult * length_in_chars);
2708                     if (computed_guess < needed) {
2709                         PL_collxfrm_base += needed - computed_guess;
2710                     }
2711
2712                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2713                         "%s: %d: slope is now %zu; was %zu, base "
2714                         "is now %zu; was %zu\n",
2715                         __FILE__, __LINE__,
2716                         PL_collxfrm_mult, old_m,
2717                         PL_collxfrm_base, old_b));
2718                 }
2719                 else {  /* Slope didn't change, but 'b' did */
2720                     const STRLEN new_b = needed
2721                                         - computed_guess
2722                                         + PL_collxfrm_base;
2723                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2724                         "%s: %d: base is now %zu; was %zu\n",
2725                         __FILE__, __LINE__,
2726                         new_b, PL_collxfrm_base));
2727                     PL_collxfrm_base = new_b;
2728                 }
2729             }
2730
2731             break;
2732         }
2733
2734         if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
2735             DEBUG_L(PerlIO_printf(Perl_debug_log,
2736                   "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
2737                   *xlen, PERL_INT_MAX));
2738             goto bad;
2739         }
2740
2741         /* A well-behaved strxfrm() returns exactly how much space it needs
2742          * (usually not including the trailing NUL) when it fails due to not
2743          * enough space being provided.  Assume that this is the case unless
2744          * it's been proven otherwise */
2745         if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
2746             xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
2747         }
2748         else { /* Here, either:
2749                 *  1)  The strxfrm() has previously shown bad behavior; or
2750                 *  2)  It isn't the first time through the loop, which means
2751                 *      that the strxfrm() is now showing bad behavior, because
2752                 *      we gave it what it said was needed in the previous
2753                 *      iteration, and it came back saying it needed still more.
2754                 *      (Many versions of cygwin fit this.  When the buffer size
2755                 *      isn't sufficient, they return the input size instead of
2756                 *      how much is needed.)
2757                 * Increase the buffer size by a fixed percentage and try again.
2758                 * */
2759             xAlloc += (xAlloc / 4) + 1;
2760             PL_strxfrm_is_behaved = FALSE;
2761
2762 #  ifdef DEBUGGING
2763
2764             if (DEBUG_Lv_TEST || debug_initialization) {
2765                 PerlIO_printf(Perl_debug_log,
2766                 "_mem_collxfrm required more space than previously calculated"
2767                 " for locale %s, trying again with new guess=%d+%zu\n",
2768                 PL_collation_name, (int) COLLXFRM_HDR_LEN,
2769                 xAlloc - COLLXFRM_HDR_LEN);
2770             }
2771
2772 #  endif
2773
2774         }
2775
2776         Renew(xbuf, xAlloc, char);
2777         if (UNLIKELY(! xbuf)) {
2778             DEBUG_L(PerlIO_printf(Perl_debug_log,
2779                       "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
2780             goto bad;
2781         }
2782
2783         first_time = FALSE;
2784     }
2785
2786
2787 #  ifdef DEBUGGING
2788
2789     if (DEBUG_Lv_TEST || debug_initialization) {
2790
2791         print_collxfrm_input_and_return(s, s + len, xlen, utf8);
2792         PerlIO_printf(Perl_debug_log, "Its xfrm is:");
2793         PerlIO_printf(Perl_debug_log, "%s\n",
2794                       _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
2795                        *xlen, 1));
2796     }
2797
2798 #  endif
2799
2800     /* Free up unneeded space; retain ehough for trailing NUL */
2801     Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
2802
2803     if (s != input_string) {
2804         Safefree(s);
2805     }
2806
2807     return xbuf;
2808
2809   bad:
2810     Safefree(xbuf);
2811     if (s != input_string) {
2812         Safefree(s);
2813     }
2814     *xlen = 0;
2815
2816 #  ifdef DEBUGGING
2817
2818     if (DEBUG_Lv_TEST || debug_initialization) {
2819         print_collxfrm_input_and_return(s, s + len, NULL, utf8);
2820     }
2821
2822 #  endif
2823
2824     return NULL;
2825 }
2826
2827 #  ifdef DEBUGGING
2828
2829 STATIC void
2830 S_print_collxfrm_input_and_return(pTHX_
2831                                   const char * const s,
2832                                   const char * const e,
2833                                   const STRLEN * const xlen,
2834                                   const bool is_utf8)
2835 {
2836
2837     PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
2838
2839     PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
2840                                                         (UV)PL_collation_ix);
2841     if (xlen) {
2842         PerlIO_printf(Perl_debug_log, "%zu", *xlen);
2843     }
2844     else {
2845         PerlIO_printf(Perl_debug_log, "NULL");
2846     }
2847     PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
2848                                                             PL_collation_name);
2849     print_bytes_for_locale(s, e, is_utf8);
2850
2851     PerlIO_printf(Perl_debug_log, "'\n");
2852 }
2853
2854 STATIC void
2855 S_print_bytes_for_locale(pTHX_
2856                     const char * const s,
2857                     const char * const e,
2858                     const bool is_utf8)
2859 {
2860     const char * t = s;
2861     bool prev_was_printable = TRUE;
2862     bool first_time = TRUE;
2863
2864     PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
2865
2866     while (t < e) {
2867         UV cp = (is_utf8)
2868                 ?  utf8_to_uvchr_buf((U8 *) t, e, NULL)
2869                 : * (U8 *) t;
2870         if (isPRINT(cp)) {
2871             if (! prev_was_printable) {
2872                 PerlIO_printf(Perl_debug_log, " ");
2873             }
2874             PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
2875             prev_was_printable = TRUE;
2876         }
2877         else {
2878             if (! first_time) {
2879                 PerlIO_printf(Perl_debug_log, " ");
2880             }
2881             PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
2882             prev_was_printable = FALSE;
2883         }
2884         t += (is_utf8) ? UTF8SKIP(t) : 1;
2885         first_time = FALSE;
2886     }
2887 }
2888
2889 #  endif   /* #ifdef DEBUGGING */
2890 #endif /* USE_LOCALE_COLLATE */
2891
2892 #ifdef USE_LOCALE
2893
2894 bool
2895 Perl__is_cur_LC_category_utf8(pTHX_ int category)
2896 {
2897     /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
2898      * otherwise. 'category' may not be LC_ALL.  If the platform doesn't have
2899      * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
2900      * could give the wrong result.  The result will very likely be correct for
2901      * languages that have commonly used non-ASCII characters, but for notably
2902      * English, it comes down to if the locale's name ends in something like
2903      * "UTF-8".  It errs on the side of not being a UTF-8 locale. */
2904
2905     const char *save_input_locale = NULL;
2906     STRLEN final_pos;
2907
2908 #  ifdef LC_ALL
2909
2910     assert(category != LC_ALL);
2911
2912 #  endif
2913
2914     /* First dispose of the trivial cases */
2915     save_input_locale = do_setlocale_r(category, NULL);
2916     if (! save_input_locale) {
2917         DEBUG_L(PerlIO_printf(Perl_debug_log,
2918                               "Could not find current locale for category %d\n",
2919                               category));
2920         return FALSE;   /* XXX maybe should croak */
2921     }
2922     save_input_locale = stdize_locale(savepv(save_input_locale));
2923     if (isNAME_C_OR_POSIX(save_input_locale)) {
2924         DEBUG_L(PerlIO_printf(Perl_debug_log,
2925                               "Current locale for category %d is %s\n",
2926                               category, save_input_locale));
2927         Safefree(save_input_locale);
2928         return FALSE;
2929     }
2930
2931 #  if defined(USE_LOCALE_CTYPE)    \
2932     && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET)))
2933
2934     { /* Next try nl_langinfo or MB_CUR_MAX if available */
2935
2936         char *save_ctype_locale = NULL;
2937         bool is_utf8;
2938
2939         if (category != LC_CTYPE) { /* These work only on LC_CTYPE */
2940
2941             /* Get the current LC_CTYPE locale */
2942             save_ctype_locale = do_setlocale_c(LC_CTYPE, NULL);
2943             if (! save_ctype_locale) {
2944                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2945                                "Could not find current locale for LC_CTYPE\n"));
2946                 goto cant_use_nllanginfo;
2947             }
2948             save_ctype_locale = stdize_locale(savepv(save_ctype_locale));
2949
2950             /* If LC_CTYPE and the desired category use the same locale, this
2951              * means that finding the value for LC_CTYPE is the same as finding
2952              * the value for the desired category.  Otherwise, switch LC_CTYPE
2953              * to the desired category's locale */
2954             if (strEQ(save_ctype_locale, save_input_locale)) {
2955                 Safefree(save_ctype_locale);
2956                 save_ctype_locale = NULL;
2957             }
2958             else if (! do_setlocale_c(LC_CTYPE, save_input_locale)) {
2959                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2960                                     "Could not change LC_CTYPE locale to %s\n",
2961                                     save_input_locale));
2962                 Safefree(save_ctype_locale);
2963                 goto cant_use_nllanginfo;
2964             }
2965         }
2966
2967         DEBUG_L(PerlIO_printf(Perl_debug_log, "Current LC_CTYPE locale=%s\n",
2968                                               save_input_locale));
2969
2970         /* Here the current LC_CTYPE is set to the locale of the category whose
2971          * information is desired.  This means that nl_langinfo() and MB_CUR_MAX
2972          * should give the correct results */
2973
2974 #    if defined(HAS_NL_LANGINFO) && defined(CODESET)
2975
2976         { /* The task is easiest if the platform has this POSIX 2001 function */
2977             const char *codeset = my_nl_langinfo(PERL_CODESET, FALSE);
2978                                           /* FALSE => already in dest locale */
2979
2980             DEBUG_L(PerlIO_printf(Perl_debug_log,
2981                             "\tnllanginfo returned CODESET '%s'\n", codeset));
2982
2983             if (codeset && strNE(codeset, "")) {
2984                 /* If we switched LC_CTYPE, switch back */
2985                 if (save_ctype_locale) {
2986                     do_setlocale_c(LC_CTYPE, save_ctype_locale);
2987                     Safefree(save_ctype_locale);
2988                 }
2989
2990                 is_utf8 = (   (   strlen(codeset) == STRLENs("UTF-8")
2991                                && foldEQ(codeset, STR_WITH_LEN("UTF-8")))
2992                            || (   strlen(codeset) == STRLENs("UTF8")
2993                                && foldEQ(codeset, STR_WITH_LEN("UTF8"))));
2994
2995                 DEBUG_L(PerlIO_printf(Perl_debug_log,
2996                        "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n",
2997                                                      codeset,         is_utf8));
2998                 Safefree(save_input_locale);
2999                 return is_utf8;
3000             }
3001         }
3002
3003 #    endif
3004 #    ifdef MB_CUR_MAX
3005
3006         /* Here, either we don't have nl_langinfo, or it didn't return a
3007          * codeset.  Try MB_CUR_MAX */
3008
3009         /* Standard UTF-8 needs at least 4 bytes to represent the maximum
3010          * Unicode code point.  Since UTF-8 is the only non-single byte
3011          * encoding we handle, we just say any such encoding is UTF-8, and if
3012          * turns out to be wrong, other things will fail */
3013         is_utf8 = (unsigned) MB_CUR_MAX >= STRLENs(MAX_UNICODE_UTF8);
3014
3015         DEBUG_L(PerlIO_printf(Perl_debug_log,
3016                               "\tMB_CUR_MAX=%d; ?UTF8 locale=%d\n",
3017                                    (int) MB_CUR_MAX,      is_utf8));
3018
3019         Safefree(save_input_locale);
3020
3021 #      ifdef HAS_MBTOWC
3022
3023         /* ... But, most system that have MB_CUR_MAX will also have mbtowc(),
3024          * since they are both in the C99 standard.  We can feed a known byte
3025          * string to the latter function, and check that it gives the expected
3026          * result */
3027         if (is_utf8) {
3028             wchar_t wc;
3029             int len;
3030
3031             PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
3032             errno = 0;
3033             len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
3034
3035
3036             if (   len != STRLENs(REPLACEMENT_CHARACTER_UTF8)
3037                 || wc != (wchar_t) UNICODE_REPLACEMENT)
3038             {
3039                 is_utf8 = FALSE;
3040                 DEBUG_L(PerlIO_printf(Perl_debug_log, "\replacement=U+%x\n",
3041                                                             (unsigned int)wc));
3042                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3043                         "\treturn from mbtowc=%d; errno=%d; ?UTF8 locale=0\n",
3044                                                len,      errno));
3045             }
3046         }
3047
3048 #      endif
3049
3050         /* If we switched LC_CTYPE, switch back */
3051         if (save_ctype_locale) {
3052             do_setlocale_c(LC_CTYPE, save_ctype_locale);
3053             Safefree(save_ctype_locale);
3054         }
3055
3056         return is_utf8;
3057
3058 #    endif
3059
3060     }
3061
3062   cant_use_nllanginfo:
3063
3064 #  else   /* nl_langinfo should work if available, so don't bother compiling this
3065            fallback code.  The final fallback of looking at the name is
3066            compiled, and will be executed if nl_langinfo fails */
3067
3068     /* nl_langinfo not available or failed somehow.  Next try looking at the
3069      * currency symbol to see if it disambiguates things.  Often that will be
3070      * in the native script, and if the symbol isn't in UTF-8, we know that the
3071      * locale isn't.  If it is non-ASCII UTF-8, we infer that the locale is
3072      * too, as the odds of a non-UTF8 string being valid UTF-8 are quite small
3073      * */
3074
3075 #    ifdef HAS_LOCALECONV
3076 #      ifdef USE_LOCALE_MONETARY
3077
3078     {
3079         char *save_monetary_locale = NULL;
3080         bool only_ascii = FALSE;
3081         bool is_utf8 = FALSE;
3082         struct lconv* lc;
3083
3084         /* Like above for LC_CTYPE, we first set LC_MONETARY to the locale of
3085          * the desired category, if it isn't that locale already */
3086
3087         if (category != LC_MONETARY) {
3088
3089             save_monetary_locale = do_setlocale_c(LC_MONETARY, NULL);
3090             if (! save_monetary_locale) {
3091                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3092                             "Could not find current locale for LC_MONETARY\n"));
3093                 goto cant_use_monetary;
3094             }
3095             save_monetary_locale = stdize_locale(savepv(save_monetary_locale));
3096
3097             if (strEQ(save_monetary_locale, save_input_locale)) {
3098                 Safefree(save_monetary_locale);
3099                 save_monetary_locale = NULL;
3100             }
3101             else if (! do_setlocale_c(LC_MONETARY, save_input_locale)) {
3102                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3103                             "Could not change LC_MONETARY locale to %s\n",
3104                                                         save_input_locale));
3105                 Safefree(save_monetary_locale);
3106                 goto cant_use_monetary;
3107             }
3108         }
3109
3110         /* Here the current LC_MONETARY is set to the locale of the category
3111          * whose information is desired. */
3112
3113         lc = localeconv();
3114         if (! lc
3115             || ! lc->currency_symbol
3116             || is_utf8_invariant_string((U8 *) lc->currency_symbol, 0))
3117         {
3118             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));
3119             only_ascii = TRUE;
3120         }
3121         else {
3122             is_utf8 = is_utf8_string((U8 *) lc->currency_symbol, 0);
3123         }
3124
3125         /* If we changed it, restore LC_MONETARY to its original locale */
3126         if (save_monetary_locale) {
3127             do_setlocale_c(LC_MONETARY, save_monetary_locale);
3128             Safefree(save_monetary_locale);
3129         }
3130
3131         if (! only_ascii) {
3132
3133             /* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
3134              * otherwise assume the locale is UTF-8 if and only if the symbol
3135              * is non-ascii UTF-8. */
3136             DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
3137                                     save_input_locale, is_utf8));
3138             Safefree(save_input_locale);
3139             return is_utf8;
3140         }
3141     }
3142   cant_use_monetary:
3143
3144 #      endif /* USE_LOCALE_MONETARY */
3145 #    endif /* HAS_LOCALECONV */
3146
3147 #    if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME)
3148
3149 /* Still haven't found a non-ASCII string to disambiguate UTF-8 or not.  Try
3150  * the names of the months and weekdays, timezone, and am/pm indicator */
3151     {
3152         char *save_time_locale = NULL;
3153         int hour = 10;
3154         bool is_dst = FALSE;
3155         int dom = 1;
3156         int month = 0;
3157         int i;
3158         char * formatted_time;
3159
3160
3161         /* Like above for LC_MONETARY, we set LC_TIME to the locale of the
3162          * desired category, if it isn't that locale already */
3163
3164         if (category != LC_TIME) {
3165
3166             save_time_locale = do_setlocale_c(LC_TIME, NULL);
3167             if (! save_time_locale) {
3168                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3169                             "Could not find current locale for LC_TIME\n"));
3170                 goto cant_use_time;
3171             }
3172             save_time_locale = stdize_locale(savepv(save_time_locale));
3173
3174             if (strEQ(save_time_locale, save_input_locale)) {
3175                 Safefree(save_time_locale);
3176                 save_time_locale = NULL;
3177             }
3178             else if (! do_setlocale_c(LC_TIME, save_input_locale)) {
3179                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3180                             "Could not change LC_TIME locale to %s\n",
3181                                                         save_input_locale));
3182                 Safefree(save_time_locale);
3183                 goto cant_use_time;
3184             }
3185         }
3186
3187         /* Here the current LC_TIME is set to the locale of the category
3188          * whose information is desired.  Look at all the days of the week and
3189          * month names, and the timezone and am/pm indicator for UTF-8 variant
3190          * characters.  The first such a one found will tell us if the locale
3191          * is UTF-8 or not */
3192
3193         for (i = 0; i < 7 + 12; i++) {  /* 7 days; 12 months */
3194             formatted_time = my_strftime("%A %B %Z %p",
3195                             0, 0, hour, dom, month, 2012 - 1900, 0, 0, is_dst);
3196             if ( ! formatted_time
3197                 || is_utf8_invariant_string((U8 *) formatted_time, 0))
3198             {
3199
3200                 /* Here, we didn't find a non-ASCII.  Try the next time through
3201                  * with the complemented dst and am/pm, and try with the next
3202                  * weekday.  After we have gotten all weekdays, try the next
3203                  * month */
3204                 is_dst = ! is_dst;
3205                 hour = (hour + 12) % 24;
3206                 dom++;
3207                 if (i > 6) {
3208                     month++;
3209                 }
3210                 continue;
3211             }
3212
3213             /* Here, we have a non-ASCII.  Return TRUE is it is valid UTF8;
3214              * false otherwise.  But first, restore LC_TIME to its original
3215              * locale if we changed it */
3216             if (save_time_locale) {
3217                 do_setlocale_c(LC_TIME, save_time_locale);
3218                 Safefree(save_time_locale);
3219             }
3220
3221             DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
3222                                 save_input_locale,
3223                                 is_utf8_string((U8 *) formatted_time, 0)));
3224             Safefree(save_input_locale);
3225             return is_utf8_string((U8 *) formatted_time, 0);
3226         }
3227
3228         /* Falling off the end of the loop indicates all the names were just
3229          * ASCII.  Go on to the next test.  If we changed it, restore LC_TIME
3230          * to its original locale */
3231         if (save_time_locale) {
3232             do_setlocale_c(LC_TIME, save_time_locale);
3233             Safefree(save_time_locale);
3234         }
3235         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));
3236     }
3237   cant_use_time:
3238
3239 #    endif
3240
3241 #    if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST)
3242
3243 /* This code is ifdefd out because it was found to not be necessary in testing
3244  * on our dromedary test machine, which has over 700 locales.  There, this
3245  * added no value to looking at the currency symbol and the time strings.  I
3246  * left it in so as to avoid rewriting it if real-world experience indicates
3247  * that dromedary is an outlier.  Essentially, instead of returning abpve if we
3248  * haven't found illegal utf8, we continue on and examine all the strerror()
3249  * messages on the platform for utf8ness.  If all are ASCII, we still don't
3250  * know the answer; but otherwise we have a pretty good indication of the
3251  * utf8ness.  The reason this doesn't help much is that the messages may not
3252  * have been translated into the locale.  The currency symbol and time strings
3253  * are much more likely to have been translated.  */
3254     {
3255         int e;
3256         bool is_utf8 = FALSE;
3257         bool non_ascii = FALSE;
3258         char *save_messages_locale = NULL;
3259         const char * errmsg = NULL;
3260
3261         /* Like above, we set LC_MESSAGES to the locale of the desired
3262          * category, if it isn't that locale already */
3263
3264         if (category != LC_MESSAGES) {
3265
3266             save_messages_locale = do_setlocale_c(LC_MESSAGES, NULL);
3267             if (! save_messages_locale) {
3268                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3269                             "Could not find current locale for LC_MESSAGES\n"));
3270                 goto cant_use_messages;
3271             }
3272             save_messages_locale = stdize_locale(savepv(save_messages_locale));
3273
3274             if (strEQ(save_messages_locale, save_input_locale)) {
3275                 Safefree(save_messages_locale);
3276                 save_messages_locale = NULL;
3277             }
3278             else if (! do_setlocale_c(LC_MESSAGES, save_input_locale)) {
3279                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3280                             "Could not change LC_MESSAGES locale to %s\n",
3281                                                         save_input_locale));
3282                 Safefree(save_messages_locale);
3283                 goto cant_use_messages;
3284             }
3285         }
3286
3287         /* Here the current LC_MESSAGES is set to the locale of the category
3288          * whose information is desired.  Look through all the messages.  We
3289          * can't use Strerror() here because it may expand to code that
3290          * segfaults in miniperl */
3291
3292         for (e = 0; e <= sys_nerr; e++) {
3293             errno = 0;
3294             errmsg = sys_errlist[e];
3295             if (errno || !errmsg) {
3296                 break;
3297             }
3298             errmsg = savepv(errmsg);
3299             if (! is_utf8_invariant_string((U8 *) errmsg, 0)) {
3300                 non_ascii = TRUE;
3301                 is_utf8 = is_utf8_string((U8 *) errmsg, 0);
3302                 break;
3303             }
3304         }
3305         Safefree(errmsg);
3306
3307         /* And, if we changed it, restore LC_MESSAGES to its original locale */
3308         if (save_messages_locale) {
3309             do_setlocale_c(LC_MESSAGES, save_messages_locale);
3310             Safefree(save_messages_locale);
3311         }
3312
3313         if (non_ascii) {
3314
3315             /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
3316              * any non-ascii means it is one; otherwise we assume it isn't */
3317             DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
3318                                 save_input_locale,
3319                                 is_utf8));
3320             Safefree(save_input_locale);
3321             return is_utf8;
3322         }
3323
3324         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));
3325     }
3326   cant_use_messages:
3327
3328 #    endif
3329 #  endif /* the code that is compiled when no nl_langinfo */
3330
3331 #  ifndef EBCDIC  /* On os390, even if the name ends with "UTF-8', it isn't a
3332                    UTF-8 locale */
3333
3334     /* As a last resort, look at the locale name to see if it matches
3335      * qr/UTF -?  * 8 /ix, or some other common locale names.  This "name", the
3336      * return of setlocale(), is actually defined to be opaque, so we can't
3337      * really rely on the absence of various substrings in the name to indicate
3338      * its UTF-8ness, but if it has UTF8 in the name, it is extremely likely to
3339      * be a UTF-8 locale.  Similarly for the other common names */
3340
3341     final_pos = strlen(save_input_locale) - 1;
3342     if (final_pos >= 3) {
3343         const char *name = save_input_locale;
3344
3345         /* Find next 'U' or 'u' and look from there */
3346         while ((name += strcspn(name, "Uu") + 1)
3347                                             <= save_input_locale + final_pos - 2)
3348         {
3349             if (   isALPHA_FOLD_NE(*name, 't')
3350                 || isALPHA_FOLD_NE(*(name + 1), 'f'))
3351             {
3352                 continue;
3353             }
3354             name += 2;
3355             if (*(name) == '-') {
3356                 if ((name > save_input_locale + final_pos - 1)) {
3357                     break;
3358                 }
3359                 name++;
3360             }
3361             if (*(name) == '8') {
3362                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3363                                       "Locale %s ends with UTF-8 in name\n",
3364                                       save_input_locale));
3365                 Safefree(save_input_locale);
3366                 return TRUE;
3367             }
3368         }
3369         DEBUG_L(PerlIO_printf(Perl_debug_log,
3370                               "Locale %s doesn't end with UTF-8 in name\n",
3371                                 save_input_locale));
3372     }
3373
3374 #  endif
3375 #  ifdef WIN32
3376
3377     /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
3378     if (memENDs(save_input_locale, final_pos, "65001")) {
3379         DEBUG_L(PerlIO_printf(Perl_debug_log,
3380                         "Locale %s ends with 65001 in name, is UTF-8 locale\n",
3381                         save_input_locale));
3382         Safefree(save_input_locale);
3383         return TRUE;
3384     }
3385
3386 #  endif
3387
3388     /* Other common encodings are the ISO 8859 series, which aren't UTF-8.  But
3389      * since we are about to return FALSE anyway, there is no point in doing
3390      * this extra work */
3391
3392 #  if 0
3393     if (instr(save_input_locale, "8859")) {
3394         DEBUG_L(PerlIO_printf(Perl_debug_log,
3395                              "Locale %s has 8859 in name, not UTF-8 locale\n",
3396                              save_input_locale));
3397         Safefree(save_input_locale);
3398         return FALSE;
3399     }
3400 #  endif
3401
3402     DEBUG_L(PerlIO_printf(Perl_debug_log,
3403                           "Assuming locale %s is not a UTF-8 locale\n",
3404                                     save_input_locale));
3405     Safefree(save_input_locale);
3406     return FALSE;
3407 }
3408
3409 #endif
3410
3411
3412 bool
3413 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
3414 {
3415     dVAR;
3416     /* Internal function which returns if we are in the scope of a pragma that
3417      * enables the locale category 'category'.  'compiling' should indicate if
3418      * this is during the compilation phase (TRUE) or not (FALSE). */
3419
3420     const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
3421
3422     SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
3423     if (! categories || categories == &PL_sv_placeholder) {
3424         return FALSE;
3425     }
3426
3427     /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
3428      * a valid unsigned */
3429     assert(category >= -1);
3430     return cBOOL(SvUV(categories) & (1U << (category + 1)));
3431 }
3432
3433 char *
3434 Perl_my_strerror(pTHX_ const int errnum)
3435 {
3436     /* Returns a mortalized copy of the text of the error message associated
3437      * with 'errnum'.  It uses the current locale's text unless the platform
3438      * doesn't have the LC_MESSAGES category or we are not being called from
3439      * within the scope of 'use locale'.  In the former case, it uses whatever
3440      * strerror returns; in the latter case it uses the text from the C locale.
3441      *
3442      * The function just calls strerror(), but temporarily switches, if needed,
3443      * to the C locale */
3444
3445     char *errstr;
3446     dVAR;
3447
3448 #ifndef USE_LOCALE_MESSAGES
3449
3450     /* If platform doesn't have messages category, we don't do any switching to
3451      * the C locale; we just use whatever strerror() returns */
3452
3453     errstr = savepv(Strerror(errnum));
3454
3455 #else   /* Has locale messages */
3456
3457     const bool within_locale_scope = IN_LC(LC_MESSAGES);
3458
3459 #  if defined(HAS_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
3460
3461     /* This function is trivial if we don't have to worry about thread safety
3462      * and have strerror_l(), as it handles the switch of locales so we don't
3463      * have to deal with that.  We don't have to worry about thread safety if
3464      * this is an unthreaded build, or if strerror_r() is also available.  Both
3465      * it and strerror_l() are thread-safe.  Plain strerror() isn't thread
3466      * safe.  But on threaded builds when strerror_r() is available, the
3467      * apparent call to strerror() below is actually a macro that
3468      * behind-the-scenes calls strerror_r().
3469      */
3470
3471 #    if ! defined(USE_ITHREADS) || defined(HAS_STRERROR_R)
3472
3473     if (within_locale_scope) {
3474         errstr = savepv(strerror(errnum));
3475     }
3476     else {
3477         errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
3478     }
3479
3480 #    else
3481
3482     /* Here we have strerror_l(), but not strerror_r() and we are on a
3483      * threaded-build.  We use strerror_l() for everything, constructing a
3484      * locale to pass to it if necessary */
3485
3486     bool do_free = FALSE;
3487     locale_t locale_to_use;
3488
3489     if (within_locale_scope) {
3490         locale_to_use = uselocale((locale_t) 0);
3491         if (locale_to_use == LC_GLOBAL_LOCALE) {
3492             locale_to_use = duplocale(LC_GLOBAL_LOCALE);
3493             do_free = TRUE;
3494         }
3495     }
3496     else {  /* Use C locale if not within 'use locale' scope */
3497         locale_to_use = PL_C_locale_obj;
3498     }
3499
3500     errstr = savepv(strerror_l(errnum, locale_to_use));
3501
3502     if (do_free) {
3503         freelocale(locale_to_use);
3504     }
3505
3506 #    endif
3507 #  else /* Doesn't have strerror_l() */
3508
3509 #    ifdef USE_POSIX_2008_LOCALE
3510
3511     locale_t save_locale = NULL;
3512
3513 #    else
3514
3515     const char * save_locale = NULL;
3516     bool locale_is_C = FALSE;
3517
3518     /* We have a critical section to prevent another thread from changing the
3519      * locale out from under us (or zapping the buffer returned from
3520      * setlocale() ) */
3521     LOCALE_LOCK;
3522
3523 #    endif
3524
3525     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3526                             "my_strerror called with errnum %d\n", errnum));
3527     if (! within_locale_scope) {
3528         errno = 0;
3529
3530 #  ifdef USE_POSIX_2008_LOCALE /* Use the thread-safe locale functions */
3531
3532         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3533                                     "Not within locale scope, about to call"
3534                                     " uselocale(0x%p)\n", PL_C_locale_obj));
3535         save_locale = uselocale(PL_C_locale_obj);
3536         if (! save_locale) {
3537             DEBUG_L(PerlIO_printf(Perl_debug_log,
3538                                     "uselocale failed, errno=%d\n", errno));
3539         }
3540         else {
3541             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3542                                     "uselocale returned 0x%p\n", save_locale));
3543         }
3544
3545 #    else    /* Not thread-safe build */
3546
3547         save_locale = do_setlocale_c(LC_MESSAGES, NULL);
3548         if (! save_locale) {
3549             DEBUG_L(PerlIO_printf(Perl_debug_log,
3550                                   "setlocale failed, errno=%d\n", errno));
3551         }
3552         else {
3553             locale_is_C = isNAME_C_OR_POSIX(save_locale);
3554
3555             /* Switch to the C locale if not already in it */
3556             if (! locale_is_C) {
3557
3558                 /* The setlocale() just below likely will zap 'save_locale', so
3559                  * create a copy.  */
3560                 save_locale = savepv(save_locale);
3561                 do_setlocale_c(LC_MESSAGES, "C");
3562             }
3563         }
3564
3565 #    endif
3566
3567     }   /* end of ! within_locale_scope */
3568     else {
3569         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
3570                                                __FILE__, __LINE__));
3571     }
3572
3573     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3574              "Any locale change has been done; about to call Strerror\n"));
3575     errstr = savepv(Strerror(errnum));
3576
3577     if (! within_locale_scope) {
3578         errno = 0;
3579
3580 #  ifdef USE_POSIX_2008_LOCALE
3581
3582         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3583                     "%s: %d: not within locale scope, restoring the locale\n",
3584                     __FILE__, __LINE__));
3585         if (save_locale && ! uselocale(save_locale)) {
3586             DEBUG_L(PerlIO_printf(Perl_debug_log,
3587                           "uselocale restore failed, errno=%d\n", errno));
3588         }
3589     }
3590
3591 #    else
3592
3593         if (save_locale && ! locale_is_C) {
3594             if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
3595                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3596                       "setlocale restore failed, errno=%d\n", errno));
3597             }
3598             Safefree(save_locale);
3599         }
3600     }
3601
3602     LOCALE_UNLOCK;
3603
3604 #    endif
3605 #  endif /* End of doesn't have strerror_l */
3606 #endif   /* End of does have locale messages */
3607
3608 #ifdef DEBUGGING
3609
3610     if (DEBUG_Lv_TEST) {
3611         PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
3612         print_bytes_for_locale(errstr, errstr + strlen(errstr), 0);
3613         PerlIO_printf(Perl_debug_log, "'\n");
3614     }
3615
3616 #endif
3617
3618     SAVEFREEPV(errstr);
3619     return errstr;
3620 }
3621
3622 /*
3623
3624 =for apidoc sync_locale
3625
3626 Changing the program's locale should be avoided by XS code.  Nevertheless,
3627 certain non-Perl libraries called from XS, such as C<Gtk> do so.  When this
3628 happens, Perl needs to be told that the locale has changed.  Use this function
3629 to do so, before returning to Perl.
3630
3631 =cut
3632 */
3633
3634 void
3635 Perl_sync_locale(pTHX)
3636 {
3637     char * newlocale;
3638
3639 #ifdef USE_LOCALE_CTYPE
3640
3641     newlocale = do_setlocale_c(LC_CTYPE, NULL);
3642     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3643         "%s:%d: %s\n", __FILE__, __LINE__,
3644         setlocale_debug_string(LC_CTYPE, NULL, newlocale)));
3645     new_ctype(newlocale);
3646
3647 #endif /* USE_LOCALE_CTYPE */
3648 #ifdef USE_LOCALE_COLLATE
3649
3650     newlocale = do_setlocale_c(LC_COLLATE, NULL);
3651     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3652         "%s:%d: %s\n", __FILE__, __LINE__,
3653         setlocale_debug_string(LC_COLLATE, NULL, newlocale)));
3654     new_collate(newlocale);
3655
3656 #endif
3657 #ifdef USE_LOCALE_NUMERIC
3658
3659     newlocale = do_setlocale_c(LC_NUMERIC, NULL);
3660     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3661         "%s:%d: %s\n", __FILE__, __LINE__,
3662         setlocale_debug_string(LC_NUMERIC, NULL, newlocale)));
3663     new_numeric(newlocale);
3664
3665 #endif /* USE_LOCALE_NUMERIC */
3666
3667 }
3668
3669 #if defined(DEBUGGING) && defined(USE_LOCALE)
3670
3671 STATIC char *
3672 S_setlocale_debug_string(const int category,        /* category number,
3673                                                            like LC_ALL */
3674                             const char* const locale,   /* locale name */
3675
3676                             /* return value from setlocale() when attempting to
3677                              * set 'category' to 'locale' */
3678                             const char* const retval)
3679 {
3680     /* Returns a pointer to a NUL-terminated string in static storage with
3681      * added text about the info passed in.  This is not thread safe and will
3682      * be overwritten by the next call, so this should be used just to
3683      * formulate a string to immediately print or savepv() on. */
3684
3685     /* initialise to a non-null value to keep it out of BSS and so keep
3686      * -DPERL_GLOBAL_STRUCT_PRIVATE happy */
3687     static char ret[128] = "If you can read this, thank your buggy C"
3688                            " library strlcpy(), and change your hints file"
3689                            " to undef it";
3690
3691     my_strlcpy(ret, "setlocale(", sizeof(ret));
3692     my_strlcat(ret, category_name(category), sizeof(ret));
3693     my_strlcat(ret, ", ", sizeof(ret));
3694
3695     if (locale) {
3696         my_strlcat(ret, "\"", sizeof(ret));
3697         my_strlcat(ret, locale, sizeof(ret));
3698         my_strlcat(ret, "\"", sizeof(ret));
3699     }
3700     else {
3701         my_strlcat(ret, "NULL", sizeof(ret));
3702     }
3703
3704     my_strlcat(ret, ") returned ", sizeof(ret));
3705
3706     if (retval) {
3707         my_strlcat(ret, "\"", sizeof(ret));
3708         my_strlcat(ret, retval, sizeof(ret));
3709         my_strlcat(ret, "\"", sizeof(ret));
3710     }
3711     else {
3712         my_strlcat(ret, "NULL", sizeof(ret));
3713     }
3714
3715     assert(strlen(ret) < sizeof(ret));
3716
3717     return ret;
3718 }
3719
3720 #endif
3721
3722
3723 /*
3724  * ex: set ts=8 sts=4 sw=4 et:
3725  */