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