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