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