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