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