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