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