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