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