This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8775ce095da0ac57e1c66ba19afb3ae0cb98b13e
[perl5.git] / locale.c
1 /*    locale.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *      A Elbereth Gilthoniel,
13  *      silivren penna míriel
14  *      o menel aglar elenath!
15  *      Na-chaered palan-díriel
16  *      o galadhremmin ennorath,
17  *      Fanuilos, le linnathon
18  *      nef aear, si nef aearon!
19  *
20  *     [p.238 of _The Lord of the Rings_, II/i: "Many Meetings"]
21  */
22
23 /* utility functions for handling locale-specific stuff like what
24  * character represents the decimal point.
25  *
26  * All C programs have an underlying locale.  Perl generally doesn't pay any
27  * attention to it except within the scope of a 'use locale'.  For most
28  * categories, it accomplishes this by just using different operations if it is
29  * in such scope than if not.  However, various libc functions called by Perl
30  * are affected by the LC_NUMERIC category, so there are macros in perl.h that
31  * are used to toggle between the current locale and the C locale depending on
32  * the desired behavior of those functions at the moment.
33  */
34
35 #include "EXTERN.h"
36 #define PERL_IN_LOCALE_C
37 #include "perl.h"
38
39 #ifdef I_LANGINFO
40 #   include <langinfo.h>
41 #endif
42
43 #include "reentr.h"
44
45 #ifdef USE_LOCALE
46
47 /*
48  * Standardize the locale name from a string returned by 'setlocale', possibly
49  * modifying that string.
50  *
51  * The typical return value of setlocale() is either
52  * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
53  * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
54  *     (the space-separated values represent the various sublocales,
55  *      in some unspecified order).  This is not handled by this function.
56  *
57  * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
58  * which is harmful for further use of the string in setlocale().  This
59  * function removes the trailing new line and everything up through the '='
60  *
61  */
62 STATIC char *
63 S_stdize_locale(pTHX_ char *locs)
64 {
65     const char * const s = strchr(locs, '=');
66     bool okay = TRUE;
67
68     PERL_ARGS_ASSERT_STDIZE_LOCALE;
69
70     if (s) {
71         const char * const t = strchr(s, '.');
72         okay = FALSE;
73         if (t) {
74             const char * const u = strchr(t, '\n');
75             if (u && (u[1] == 0)) {
76                 const STRLEN len = u - s;
77                 Move(s + 1, locs, len, char);
78                 locs[len] = 0;
79                 okay = TRUE;
80             }
81         }
82     }
83
84     if (!okay)
85         Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
86
87     return locs;
88 }
89
90 #endif
91
92 void
93 Perl_set_numeric_radix(pTHX)
94 {
95 #ifdef USE_LOCALE_NUMERIC
96 # ifdef HAS_LOCALECONV
97     const struct lconv* const lc = localeconv();
98
99     if (lc && lc->decimal_point) {
100         if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
101             SvREFCNT_dec(PL_numeric_radix_sv);
102             PL_numeric_radix_sv = NULL;
103         }
104         else {
105             if (PL_numeric_radix_sv)
106                 sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
107             else
108                 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
109             if (! is_ascii_string((U8 *) lc->decimal_point, 0)
110                 && is_utf8_string((U8 *) lc->decimal_point, 0)
111                 && _is_cur_LC_category_utf8(LC_NUMERIC))
112             {
113                 SvUTF8_on(PL_numeric_radix_sv);
114             }
115         }
116     }
117     else
118         PL_numeric_radix_sv = NULL;
119
120     DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is %s\n",
121                                           (PL_numeric_radix_sv)
122                                           ? lc->decimal_point
123                                           : "NULL"));
124
125 # endif /* HAS_LOCALECONV */
126 #endif /* USE_LOCALE_NUMERIC */
127 }
128
129 void
130 Perl_new_numeric(pTHX_ const char *newnum)
131 {
132 #ifdef USE_LOCALE_NUMERIC
133
134     /* Called after all libc setlocale() calls affecting LC_NUMERIC, to tell
135      * core Perl this and that 'newnum' is the name of the new locale.
136      * It installs this locale as the current underlying default.
137      *
138      * The default locale and the C locale can be toggled between by use of the
139      * set_numeric_local() and set_numeric_standard() functions, which should
140      * probably not be called directly, but only via macros like
141      * SET_NUMERIC_STANDARD() in perl.h.
142      *
143      * The toggling is necessary mainly so that a non-dot radix decimal point
144      * character can be output, while allowing internal calculations to use a
145      * dot.
146      *
147      * This sets several interpreter-level variables:
148      * PL_numeric_name  The default locale's name: a copy of 'newnum'
149      * PL_numeric_local A boolean indicating if the toggled state is such
150      *                  that the current locale is the program's underlying
151      *                  locale
152      * PL_numeric_standard An int indicating if the toggled state is such
153      *                  that the current locale is the C locale.  If non-zero,
154      *                  it is in C; if > 1, it means it may not be toggled away
155      *                  from C.
156      * Note that both of the last two variables can be true at the same time,
157      * if the underlying locale is C.  (Toggling is a no-op under these
158      * circumstances.)
159      *
160      * Any code changing the locale (outside this file) should use
161      * POSIX::setlocale, which calls this function.  Therefore this function
162      * should be called directly only from this file and from
163      * POSIX::setlocale() */
164
165     char *save_newnum;
166
167     if (! newnum) {
168         Safefree(PL_numeric_name);
169         PL_numeric_name = NULL;
170         PL_numeric_standard = TRUE;
171         PL_numeric_local = TRUE;
172         return;
173     }
174
175     save_newnum = stdize_locale(savepv(newnum));
176     if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
177         Safefree(PL_numeric_name);
178         PL_numeric_name = save_newnum;
179     }
180
181     PL_numeric_standard = ((*save_newnum == 'C' && save_newnum[1] == '\0')
182                             || strEQ(save_newnum, "POSIX"));
183     PL_numeric_local = TRUE;
184
185     /* Keep LC_NUMERIC in the C locale.  This is for XS modules, so they don't
186      * have to worry about the radix being a non-dot.  (Core operations that
187      * need the underlying locale change to it temporarily). */
188     set_numeric_standard();
189
190     set_numeric_radix();
191
192 #endif /* USE_LOCALE_NUMERIC */
193 }
194
195 void
196 Perl_set_numeric_standard(pTHX)
197 {
198 #ifdef USE_LOCALE_NUMERIC
199     /* Toggle the LC_NUMERIC locale to C, if not already there.  Probably
200      * should use the macros like SET_NUMERIC_STANDARD() in perl.h instead of
201      * calling this directly. */
202
203     if (_NOT_IN_NUMERIC_STANDARD) {
204         setlocale(LC_NUMERIC, "C");
205         PL_numeric_standard = TRUE;
206         PL_numeric_local = FALSE;
207         set_numeric_radix();
208     }
209     DEBUG_L(PerlIO_printf(Perl_debug_log,
210                           "Underlying LC_NUMERIC locale now is C\n"));
211
212 #endif /* USE_LOCALE_NUMERIC */
213 }
214
215 void
216 Perl_set_numeric_local(pTHX)
217 {
218 #ifdef USE_LOCALE_NUMERIC
219     /* Toggle the LC_NUMERIC locale to the current underlying default, if not
220      * already there.  Probably should use the macros like SET_NUMERIC_LOCAL()
221      * in perl.h instead of calling this directly. */
222
223     if (_NOT_IN_NUMERIC_LOCAL) {
224         setlocale(LC_NUMERIC, PL_numeric_name);
225         PL_numeric_standard = FALSE;
226         PL_numeric_local = TRUE;
227         set_numeric_radix();
228     }
229     DEBUG_L(PerlIO_printf(Perl_debug_log,
230                           "Underlying LC_NUMERIC locale now is %s\n",
231                           PL_numeric_name));
232
233 #endif /* USE_LOCALE_NUMERIC */
234 }
235
236 /*
237  * Set up for a new ctype locale.
238  */
239 void
240 Perl_new_ctype(pTHX_ const char *newctype)
241 {
242 #ifdef USE_LOCALE_CTYPE
243
244     /* Called after all libc setlocale() calls affecting LC_CTYPE, to tell
245      * core Perl this and that 'newctype' is the name of the new locale.
246      *
247      * This function sets up the folding arrays for all 256 bytes, assuming
248      * that tofold() is tolc() since fold case is not a concept in POSIX,
249      *
250      * Any code changing the locale (outside this file) should use
251      * POSIX::setlocale, which calls this function.  Therefore this function
252      * should be called directly only from this file and from
253      * POSIX::setlocale() */
254
255     dVAR;
256     UV i;
257
258     PERL_ARGS_ASSERT_NEW_CTYPE;
259
260     PL_in_utf8_CTYPE_locale = _is_cur_LC_category_utf8(LC_CTYPE);
261
262     /* A UTF-8 locale gets standard rules.  But note that code still has to
263      * handle this specially because of the three problematic code points */
264     if (PL_in_utf8_CTYPE_locale) {
265         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
266     }
267     else {
268         for (i = 0; i < 256; i++) {
269             if (isUPPER_LC((U8) i))
270                 PL_fold_locale[i] = (U8) toLOWER_LC((U8) i);
271             else if (isLOWER_LC((U8) i))
272                 PL_fold_locale[i] = (U8) toUPPER_LC((U8) i);
273             else
274                 PL_fold_locale[i] = (U8) i;
275         }
276     }
277
278 #endif /* USE_LOCALE_CTYPE */
279     PERL_ARGS_ASSERT_NEW_CTYPE;
280     PERL_UNUSED_ARG(newctype);
281     PERL_UNUSED_CONTEXT;
282 }
283
284 void
285 Perl_new_collate(pTHX_ const char *newcoll)
286 {
287 #ifdef USE_LOCALE_COLLATE
288
289     /* Called after all libc setlocale() calls affecting LC_COLLATE, to tell
290      * core Perl this and that 'newcoll' is the name of the new locale.
291      *
292      * Any code changing the locale (outside this file) should use
293      * POSIX::setlocale, which calls this function.  Therefore this function
294      * should be called directly only from this file and from
295      * POSIX::setlocale() */
296
297     if (! newcoll) {
298         if (PL_collation_name) {
299             ++PL_collation_ix;
300             Safefree(PL_collation_name);
301             PL_collation_name = NULL;
302         }
303         PL_collation_standard = TRUE;
304         PL_collxfrm_base = 0;
305         PL_collxfrm_mult = 2;
306         return;
307     }
308
309     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
310         ++PL_collation_ix;
311         Safefree(PL_collation_name);
312         PL_collation_name = stdize_locale(savepv(newcoll));
313         PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
314                                  || strEQ(newcoll, "POSIX"));
315
316         {
317           /*  2: at most so many chars ('a', 'b'). */
318           /* 50: surely no system expands a char more. */
319 #define XFRMBUFSIZE  (2 * 50)
320           char xbuf[XFRMBUFSIZE];
321           const Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
322           const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
323           const SSize_t mult = fb - fa;
324           if (mult < 1 && !(fa == 0 && fb == 0))
325               Perl_croak(aTHX_ "panic: strxfrm() gets absurd - a => %"UVuf", ab => %"UVuf,
326                          (UV) fa, (UV) fb);
327           PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
328           PL_collxfrm_mult = mult;
329         }
330     }
331
332 #endif /* USE_LOCALE_COLLATE */
333 }
334
335 #ifdef WIN32
336
337 char *
338 Perl_my_setlocale(pTHX_ int category, const char* locale)
339 {
340     /* This, for Windows, emulates POSIX setlocale() behavior.  There is no
341      * difference unless the input locale is "", which means on Windows to get
342      * the machine default, which is set via the computer's "Regional and
343      * Language Options" (or its current equivalent).  In POSIX, it instead
344      * means to find the locale from the user's environment.  This routine
345      * looks in the environment, and, if anything is found, uses that instead
346      * of going to the machine default.  If there is no environment override,
347      * the machine default is used, as normal, by calling the real setlocale()
348      * with "".  The POSIX behavior is to use the LC_ALL variable if set;
349      * otherwise to use the particular category's variable if set; otherwise to
350      * use the LANG variable. */
351
352     bool override_LC_ALL = 0;
353     char * result;
354
355     if (locale && strEQ(locale, "")) {
356 #   ifdef LC_ALL
357         locale = PerlEnv_getenv("LC_ALL");
358         if (! locale) {
359 #endif
360             switch (category) {
361 #   ifdef LC_ALL
362                 case LC_ALL:
363                     override_LC_ALL = TRUE;
364                     break;  /* We already know its variable isn't set */
365 #   endif
366 #   ifdef USE_LOCALE_TIME
367                 case LC_TIME:
368                     locale = PerlEnv_getenv("LC_TIME");
369                     break;
370 #   endif
371 #   ifdef USE_LOCALE_CTYPE
372                 case LC_CTYPE:
373                     locale = PerlEnv_getenv("LC_CTYPE");
374                     break;
375 #   endif
376 #   ifdef USE_LOCALE_COLLATE
377                 case LC_COLLATE:
378                     locale = PerlEnv_getenv("LC_COLLATE");
379                     break;
380 #   endif
381 #   ifdef USE_LOCALE_MONETARY
382                 case LC_MONETARY:
383                     locale = PerlEnv_getenv("LC_MONETARY");
384                     break;
385 #   endif
386 #   ifdef USE_LOCALE_NUMERIC
387                 case LC_NUMERIC:
388                     locale = PerlEnv_getenv("LC_NUMERIC");
389                     break;
390 #   endif
391 #   ifdef USE_LOCALE_MESSAGES
392                 case LC_MESSAGES:
393                     locale = PerlEnv_getenv("LC_MESSAGES");
394                     break;
395 #   endif
396                 default:
397                     /* This is a category, like PAPER_SIZE that we don't
398                      * know about; and so can't provide a wrapper. */
399                     break;
400             }
401             if (! locale) {
402                 locale = PerlEnv_getenv("LANG");
403                 if (! locale) {
404                     locale = "";
405                 }
406             }
407 #   ifdef LC_ALL
408         }
409 #   endif
410     }
411
412     result = setlocale(category, locale);
413
414     if (! override_LC_ALL)  {
415         return result;
416     }
417
418     /* Here the input locale was LC_ALL, and we have set it to what is in the
419      * LANG variable or the system default if there is no LANG.  But these have
420      * lower priority than the other LC_foo variables, so override it for each
421      * one that is set.  (If they are set to "", it means to use the same thing
422      * we just set LC_ALL to, so can skip) */
423 #   ifdef USE_LOCALE_TIME
424     result = PerlEnv_getenv("LC_TIME");
425     if (result && strNE(result, "")) {
426         setlocale(LC_TIME, result);
427     }
428 #   endif
429 #   ifdef USE_LOCALE_CTYPE
430     result = PerlEnv_getenv("LC_CTYPE");
431     if (result && strNE(result, "")) {
432         setlocale(LC_CTYPE, result);
433     }
434 #   endif
435 #   ifdef USE_LOCALE_COLLATE
436     result = PerlEnv_getenv("LC_COLLATE");
437     if (result && strNE(result, "")) {
438         setlocale(LC_COLLATE, result);
439     }
440 #   endif
441 #   ifdef USE_LOCALE_MONETARY
442     result = PerlEnv_getenv("LC_MONETARY");
443     if (result && strNE(result, "")) {
444         setlocale(LC_MONETARY, result);
445     }
446 #   endif
447 #   ifdef USE_LOCALE_NUMERIC
448     result = PerlEnv_getenv("LC_NUMERIC");
449     if (result && strNE(result, "")) {
450         setlocale(LC_NUMERIC, result);
451     }
452 #   endif
453 #   ifdef USE_LOCALE_MESSAGES
454     result = PerlEnv_getenv("LC_MESSAGES");
455     if (result && strNE(result, "")) {
456         setlocale(LC_MESSAGES, result);
457     }
458 #   endif
459
460     return setlocale(LC_ALL, NULL);
461
462 }
463
464 #endif
465
466
467 /*
468  * Initialize locale awareness.
469  */
470 int
471 Perl_init_i18nl10n(pTHX_ int printwarn)
472 {
473     /* printwarn is
474      *
475      *    0 if not to output warning when setup locale is bad
476      *    1 if to output warning based on value of PERL_BADLANG
477      *    >1 if to output regardless of PERL_BADLANG
478      *
479      * returns
480      *    1 = set ok or not applicable,
481      *    0 = fallback to a locale of lower priority
482      *   -1 = fallback to all locales failed, not even to the C locale
483      */
484
485     int ok = 1;
486
487 #if defined(USE_LOCALE)
488 #ifdef USE_LOCALE_CTYPE
489     char *curctype   = NULL;
490 #endif /* USE_LOCALE_CTYPE */
491 #ifdef USE_LOCALE_COLLATE
492     char *curcoll    = NULL;
493 #endif /* USE_LOCALE_COLLATE */
494 #ifdef USE_LOCALE_NUMERIC
495     char *curnum     = NULL;
496 #endif /* USE_LOCALE_NUMERIC */
497 #ifdef __GLIBC__
498     char * const language   = PerlEnv_getenv("LANGUAGE");
499 #endif
500
501     /* NULL uses the existing already set up locale */
502     const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
503                                         ? NULL
504                                         : "";
505     const char* trial_locales[5];   /* 5 = 1 each for "", LC_ALL, LANG, "", C */
506     unsigned int trial_locales_count;
507     char * const lc_all     = PerlEnv_getenv("LC_ALL");
508     char * const lang       = PerlEnv_getenv("LANG");
509     bool setlocale_failure = FALSE;
510     unsigned int i;
511     char *p;
512     const bool locwarn = (printwarn > 1 ||
513                     (printwarn &&
514                      (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
515     bool done = FALSE;
516 #ifdef WIN32
517     /* In some systems you can find out the system default locale
518      * and use that as the fallback locale. */
519 #   define SYSTEM_DEFAULT_LOCALE
520 #endif
521 #ifdef SYSTEM_DEFAULT_LOCALE
522     const char *system_default_locale = NULL;
523 #endif
524
525 #ifndef LOCALE_ENVIRON_REQUIRED
526     PERL_UNUSED_VAR(done);
527 #else
528
529     /*
530      * Ultrix setlocale(..., "") fails if there are no environment
531      * variables from which to get a locale name.
532      */
533
534 #   ifdef LC_ALL
535     if (lang) {
536         if (my_setlocale(LC_ALL, setlocale_init))
537             done = TRUE;
538         else
539             setlocale_failure = TRUE;
540     }
541     if (!setlocale_failure) {
542 #       ifdef USE_LOCALE_CTYPE
543         Safefree(curctype);
544         if (! (curctype =
545                my_setlocale(LC_CTYPE,
546                          (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
547                                     ? setlocale_init : NULL)))
548             setlocale_failure = TRUE;
549         else
550             curctype = savepv(curctype);
551 #       endif /* USE_LOCALE_CTYPE */
552 #       ifdef USE_LOCALE_COLLATE
553         Safefree(curcoll);
554         if (! (curcoll =
555                my_setlocale(LC_COLLATE,
556                          (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
557                                    ? setlocale_init : NULL)))
558             setlocale_failure = TRUE;
559         else
560             curcoll = savepv(curcoll);
561 #       endif /* USE_LOCALE_COLLATE */
562 #       ifdef USE_LOCALE_NUMERIC
563         Safefree(curnum);
564         if (! (curnum =
565                my_setlocale(LC_NUMERIC,
566                          (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
567                                   ? setlocale_init : NULL)))
568             setlocale_failure = TRUE;
569         else
570             curnum = savepv(curnum);
571 #       endif /* USE_LOCALE_NUMERIC */
572 #       ifdef USE_LOCALE_MESSAGES
573         if (! my_setlocale(LC_MESSAGES,
574                          (!done && (lang || PerlEnv_getenv("LC_MESSAGES")))
575                                   ? setlocale_init : NULL))
576         {
577             setlocale_failure = TRUE;
578         }
579 #       endif /* USE_LOCALE_MESSAGES */
580 #       ifdef USE_LOCALE_MONETARY
581         if (! my_setlocale(LC_MONETARY,
582                          (!done && (lang || PerlEnv_getenv("LC_MONETARY")))
583                                   ? setlocale_init : NULL))
584         {
585             setlocale_failure = TRUE;
586         }
587 #       endif /* USE_LOCALE_MONETARY */
588     }
589
590 #   endif /* LC_ALL */
591
592 #endif /* !LOCALE_ENVIRON_REQUIRED */
593
594     /* We try each locale in the list until we get one that works, or exhaust
595      * the list */
596     trial_locales[0] = setlocale_init;
597     trial_locales_count = 1;
598     for (i= 0; i < trial_locales_count; i++) {
599         const char * trial_locale = trial_locales[i];
600
601         if (i > 0) {
602
603             /* XXX This is to preserve old behavior for LOCALE_ENVIRON_REQUIRED
604              * when i==0, but I (khw) don't think that behavior makes much
605              * sense */
606             setlocale_failure = FALSE;
607
608 #ifdef SYSTEM_DEFAULT_LOCALE
609 #  ifdef WIN32
610             /* On Windows machines, an entry of "" after the 0th means to use
611              * the system default locale, which we now proceed to get. */
612             if (strEQ(trial_locale, "")) {
613                 unsigned int j;
614
615                 /* Note that this may change the locale, but we are going to do
616                  * that anyway just below */
617                 system_default_locale = setlocale(LC_ALL, "");
618
619                 /* Skip if invalid or it's already on the list of locales to
620                  * try */
621                 if (! system_default_locale) {
622                     goto next_iteration;
623                 }
624                 for (j = 0; j < trial_locales_count; j++) {
625                     if (strEQ(system_default_locale, trial_locales[j])) {
626                         goto next_iteration;
627                     }
628                 }
629
630                 trial_locale = system_default_locale;
631             }
632 #  endif /* WIN32 */
633 #endif /* SYSTEM_DEFAULT_LOCALE */
634         }
635
636 #ifdef LC_ALL
637         if (! my_setlocale(LC_ALL, trial_locale)) {
638             setlocale_failure = TRUE;
639         }
640         else {
641             /* Since LC_ALL succeeded, it should have changed all the other
642              * categories it can to its value; so we massage things so that the
643              * setlocales below just return their category's current values.
644              * This adequately handles the case in NetBSD where LC_COLLATE may
645              * not be defined for a locale, and setting it individually will
646              * fail, whereas setting LC_ALL suceeds, leaving LC_COLLATE set to
647              * the POSIX locale. */
648             trial_locale = NULL;
649         }
650 #endif /* LC_ALL */
651
652         if (!setlocale_failure) {
653 #ifdef USE_LOCALE_CTYPE
654             Safefree(curctype);
655             if (! (curctype = my_setlocale(LC_CTYPE, trial_locale)))
656                 setlocale_failure = TRUE;
657             else
658                 curctype = savepv(curctype);
659 #endif /* USE_LOCALE_CTYPE */
660 #ifdef USE_LOCALE_COLLATE
661             Safefree(curcoll);
662             if (! (curcoll = my_setlocale(LC_COLLATE, trial_locale)))
663                 setlocale_failure = TRUE;
664             else
665                 curcoll = savepv(curcoll);
666 #endif /* USE_LOCALE_COLLATE */
667 #ifdef USE_LOCALE_NUMERIC
668             Safefree(curnum);
669             if (! (curnum = my_setlocale(LC_NUMERIC, trial_locale)))
670                 setlocale_failure = TRUE;
671             else
672                 curnum = savepv(curnum);
673 #endif /* USE_LOCALE_NUMERIC */
674 #ifdef USE_LOCALE_MESSAGES
675             if (! (my_setlocale(LC_MESSAGES, trial_locale)))
676                 setlocale_failure = TRUE;
677 #endif /* USE_LOCALE_MESSAGES */
678 #ifdef USE_LOCALE_MONETARY
679             if (! (my_setlocale(LC_MONETARY, trial_locale)))
680                 setlocale_failure = TRUE;
681 #endif /* USE_LOCALE_MONETARY */
682
683             if (! setlocale_failure) {  /* Success */
684                 break;
685             }
686         }
687
688         /* Here, something failed; will need to try a fallback. */
689         ok = 0;
690
691         if (i == 0) {
692             unsigned int j;
693
694             if (locwarn) { /* Output failure info only on the first one */
695 #ifdef LC_ALL
696
697                 PerlIO_printf(Perl_error_log,
698                 "perl: warning: Setting locale failed.\n");
699
700 #else /* !LC_ALL */
701
702                 PerlIO_printf(Perl_error_log,
703                 "perl: warning: Setting locale failed for the categories:\n\t");
704 #ifdef USE_LOCALE_CTYPE
705                 if (! curctype)
706                     PerlIO_printf(Perl_error_log, "LC_CTYPE ");
707 #endif /* USE_LOCALE_CTYPE */
708 #ifdef USE_LOCALE_COLLATE
709                 if (! curcoll)
710                     PerlIO_printf(Perl_error_log, "LC_COLLATE ");
711 #endif /* USE_LOCALE_COLLATE */
712 #ifdef USE_LOCALE_NUMERIC
713                 if (! curnum)
714                     PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
715 #endif /* USE_LOCALE_NUMERIC */
716                 PerlIO_printf(Perl_error_log, "and possibly others\n");
717
718 #endif /* LC_ALL */
719
720                 PerlIO_printf(Perl_error_log,
721                     "perl: warning: Please check that your locale settings:\n");
722
723 #ifdef __GLIBC__
724                 PerlIO_printf(Perl_error_log,
725                             "\tLANGUAGE = %c%s%c,\n",
726                             language ? '"' : '(',
727                             language ? language : "unset",
728                             language ? '"' : ')');
729 #endif
730
731                 PerlIO_printf(Perl_error_log,
732                             "\tLC_ALL = %c%s%c,\n",
733                             lc_all ? '"' : '(',
734                             lc_all ? lc_all : "unset",
735                             lc_all ? '"' : ')');
736
737 #if defined(USE_ENVIRON_ARRAY)
738                 {
739                 char **e;
740                 for (e = environ; *e; e++) {
741                     if (strnEQ(*e, "LC_", 3)
742                             && strnNE(*e, "LC_ALL=", 7)
743                             && (p = strchr(*e, '=')))
744                         PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
745                                         (int)(p - *e), *e, p + 1);
746                 }
747                 }
748 #else
749                 PerlIO_printf(Perl_error_log,
750                             "\t(possibly more locale environment variables)\n");
751 #endif
752
753                 PerlIO_printf(Perl_error_log,
754                             "\tLANG = %c%s%c\n",
755                             lang ? '"' : '(',
756                             lang ? lang : "unset",
757                             lang ? '"' : ')');
758
759                 PerlIO_printf(Perl_error_log,
760                             "    are supported and installed on your system.\n");
761             }
762
763             /* Calculate what fallback locales to try.  We have avoided this
764              * until we have to, becuase failure is quite unlikely.  This will
765              * usually change the upper bound of the loop we are in.
766              *
767              * Since the system's default way of setting the locale has not
768              * found one that works, We use Perl's defined ordering: LC_ALL,
769              * LANG, and the C locale.  We don't try the same locale twice, so
770              * don't add to the list if already there.  (On POSIX systems, the
771              * LC_ALL element will likely be a repeat of the 0th element "",
772              * but there's no harm done by doing it explicitly */
773             if (lc_all) {
774                 for (j = 0; j < trial_locales_count; j++) {
775                     if (strEQ(lc_all, trial_locales[j])) {
776                         goto done_lc_all;
777                     }
778                 }
779                 trial_locales[trial_locales_count++] = lc_all;
780             }
781           done_lc_all:
782
783             if (lang) {
784                 for (j = 0; j < trial_locales_count; j++) {
785                     if (strEQ(lang, trial_locales[j])) {
786                         goto done_lang;
787                     }
788                 }
789                 trial_locales[trial_locales_count++] = lang;
790             }
791           done_lang:
792
793 #if defined(WIN32) && defined(LC_ALL)
794             /* For Windows, we also try the system default locale before "C".
795              * (If there exists a Windows without LC_ALL we skip this because
796              * it gets too complicated.  For those, the "C" is the next
797              * fallback possibility).  The "" is the same as the 0th element of
798              * the array, but the code at the loop above knows to treat it
799              * differently when not the 0th */
800             trial_locales[trial_locales_count++] = "";
801 #endif
802
803             for (j = 0; j < trial_locales_count; j++) {
804                 if (strEQ("C", trial_locales[j])) {
805                     goto done_C;
806                 }
807             }
808             trial_locales[trial_locales_count++] = "C";
809
810           done_C: ;
811         }   /* end of first time through the loop */
812
813 #ifdef WIN32
814       next_iteration: ;
815 #endif
816
817     }   /* end of looping through the trial locales */
818
819     if (ok < 1) {   /* If we tried to fallback */
820         const char* msg;
821         if (! setlocale_failure) {  /* fallback succeeded */
822            msg = "Falling back to";
823         }
824         else {  /* fallback failed */
825
826             /* We dropped off the end of the loop, so have to decrement i to
827              * get back to the value the last time through */
828             i--;
829
830             ok = -1;
831             msg = "Failed to fall back to";
832
833             /* To continue, we should use whatever values we've got */
834 #ifdef USE_LOCALE_CTYPE
835             Safefree(curctype);
836             curctype = savepv(setlocale(LC_CTYPE, NULL));
837 #endif /* USE_LOCALE_CTYPE */
838 #ifdef USE_LOCALE_COLLATE
839             Safefree(curcoll);
840             curcoll = savepv(setlocale(LC_COLLATE, NULL));
841 #endif /* USE_LOCALE_COLLATE */
842 #ifdef USE_LOCALE_NUMERIC
843             Safefree(curnum);
844             curnum = savepv(setlocale(LC_NUMERIC, NULL));
845 #endif /* USE_LOCALE_NUMERIC */
846         }
847
848         if (locwarn) {
849             const char * description;
850             const char * name = "";
851             if (strEQ(trial_locales[i], "C")) {
852                 description = "the standard locale";
853                 name = "C";
854             }
855 #ifdef SYSTEM_DEFAULT_LOCALE
856             else if (strEQ(trial_locales[i], "")) {
857                 description = "the system default locale";
858                 if (system_default_locale) {
859                     name = system_default_locale;
860                 }
861             }
862 #endif /* SYSTEM_DEFAULT_LOCALE */
863             else {
864                 description = "a fallback locale";
865                 name = trial_locales[i];
866             }
867             if (name && strNE(name, "")) {
868                 PerlIO_printf(Perl_error_log,
869                     "perl: warning: %s %s (\"%s\").\n", msg, description, name);
870             }
871             else {
872                 PerlIO_printf(Perl_error_log,
873                                    "perl: warning: %s %s.\n", msg, description);
874             }
875         }
876     } /* End of tried to fallback */
877
878 #ifdef USE_LOCALE_CTYPE
879     new_ctype(curctype);
880 #endif /* USE_LOCALE_CTYPE */
881
882 #ifdef USE_LOCALE_COLLATE
883     new_collate(curcoll);
884 #endif /* USE_LOCALE_COLLATE */
885
886 #ifdef USE_LOCALE_NUMERIC
887     new_numeric(curnum);
888 #endif /* USE_LOCALE_NUMERIC */
889
890 #if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
891     /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
892      * locale is UTF-8.  If PL_utf8locale and PL_unicode (set by -C or by
893      * $ENV{PERL_UNICODE}) are true, perl.c:S_parse_body() will turn on the
894      * PerlIO :utf8 layer on STDIN, STDOUT, STDERR, _and_ the default open
895      * discipline.  */
896     PL_utf8locale = _is_cur_LC_category_utf8(LC_CTYPE);
897
898     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
899        This is an alternative to using the -C command line switch
900        (the -C if present will override this). */
901     {
902          const char *p = PerlEnv_getenv("PERL_UNICODE");
903          PL_unicode = p ? parse_unicode_opts(&p) : 0;
904          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
905              PL_utf8cache = -1;
906     }
907 #endif
908
909 #ifdef USE_LOCALE_CTYPE
910     Safefree(curctype);
911 #endif /* USE_LOCALE_CTYPE */
912 #ifdef USE_LOCALE_COLLATE
913     Safefree(curcoll);
914 #endif /* USE_LOCALE_COLLATE */
915 #ifdef USE_LOCALE_NUMERIC
916     Safefree(curnum);
917 #endif /* USE_LOCALE_NUMERIC */
918
919 #endif /* USE_LOCALE */
920
921     return ok;
922 }
923
924
925 #ifdef USE_LOCALE_COLLATE
926
927 /*
928  * mem_collxfrm() is a bit like strxfrm() but with two important
929  * differences. First, it handles embedded NULs. Second, it allocates
930  * a bit more memory than needed for the transformed data itself.
931  * The real transformed data begins at offset sizeof(collationix).
932  * Please see sv_collxfrm() to see how this is used.
933  */
934
935 char *
936 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
937 {
938     char *xbuf;
939     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
940
941     PERL_ARGS_ASSERT_MEM_COLLXFRM;
942
943     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
944     /* the +1 is for the terminating NUL. */
945
946     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
947     Newx(xbuf, xAlloc, char);
948     if (! xbuf)
949         goto bad;
950
951     *(U32*)xbuf = PL_collation_ix;
952     xout = sizeof(PL_collation_ix);
953     for (xin = 0; xin < len; ) {
954         Size_t xused;
955
956         for (;;) {
957             xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
958             if (xused >= PERL_INT_MAX)
959                 goto bad;
960             if ((STRLEN)xused < xAlloc - xout)
961                 break;
962             xAlloc = (2 * xAlloc) + 1;
963             Renew(xbuf, xAlloc, char);
964             if (! xbuf)
965                 goto bad;
966         }
967
968         xin += strlen(s + xin) + 1;
969         xout += xused;
970
971         /* Embedded NULs are understood but silently skipped
972          * because they make no sense in locale collation. */
973     }
974
975     xbuf[xout] = '\0';
976     *xlen = xout - sizeof(PL_collation_ix);
977     return xbuf;
978
979   bad:
980     Safefree(xbuf);
981     *xlen = 0;
982     return NULL;
983 }
984
985 #endif /* USE_LOCALE_COLLATE */
986
987 #ifdef USE_LOCALE
988
989 bool
990 Perl__is_cur_LC_category_utf8(pTHX_ int category)
991 {
992     /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
993      * otherwise. 'category' may not be LC_ALL.  If the platform doesn't have
994      * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
995      * could give the wrong result.  It errs on the side of not being a UTF-8
996      * locale. */
997
998     char *save_input_locale = NULL;
999     STRLEN final_pos;
1000
1001 #ifdef LC_ALL
1002     assert(category != LC_ALL);
1003 #endif
1004
1005     /* First dispose of the trivial cases */
1006     save_input_locale = setlocale(category, NULL);
1007     if (! save_input_locale) {
1008         DEBUG_L(PerlIO_printf(Perl_debug_log,
1009                               "Could not find current locale for category %d\n",
1010                               category));
1011         return FALSE;   /* XXX maybe should croak */
1012     }
1013     save_input_locale = stdize_locale(savepv(save_input_locale));
1014     if ((*save_input_locale == 'C' && save_input_locale[1] == '\0')
1015         || strEQ(save_input_locale, "POSIX"))
1016     {
1017         DEBUG_L(PerlIO_printf(Perl_debug_log,
1018                               "Current locale for category %d is %s\n",
1019                               category, save_input_locale));
1020         Safefree(save_input_locale);
1021         return FALSE;
1022     }
1023
1024 #if defined(USE_LOCALE_CTYPE)    \
1025     && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET)))
1026
1027     { /* Next try nl_langinfo or MB_CUR_MAX if available */
1028
1029         char *save_ctype_locale = NULL;
1030         bool is_utf8;
1031
1032         if (category != LC_CTYPE) { /* These work only on LC_CTYPE */
1033
1034             /* Get the current LC_CTYPE locale */
1035             save_ctype_locale = stdize_locale(savepv(setlocale(LC_CTYPE, NULL)));
1036             if (! save_ctype_locale) {
1037                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1038                                "Could not find current locale for LC_CTYPE\n"));
1039                 goto cant_use_nllanginfo;
1040             }
1041
1042             /* If LC_CTYPE and the desired category use the same locale, this
1043              * means that finding the value for LC_CTYPE is the same as finding
1044              * the value for the desired category.  Otherwise, switch LC_CTYPE
1045              * to the desired category's locale */
1046             if (strEQ(save_ctype_locale, save_input_locale)) {
1047                 Safefree(save_ctype_locale);
1048                 save_ctype_locale = NULL;
1049             }
1050             else if (! setlocale(LC_CTYPE, save_input_locale)) {
1051                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1052                                     "Could not change LC_CTYPE locale to %s\n",
1053                                     save_input_locale));
1054                 Safefree(save_ctype_locale);
1055                 goto cant_use_nllanginfo;
1056             }
1057         }
1058
1059         DEBUG_L(PerlIO_printf(Perl_debug_log, "Current LC_CTYPE locale=%s\n",
1060                                               save_input_locale));
1061
1062         /* Here the current LC_CTYPE is set to the locale of the category whose
1063          * information is desired.  This means that nl_langinfo() and MB_CUR_MAX
1064          * should give the correct results */
1065
1066 #   if defined(HAS_NL_LANGINFO) && defined(CODESET)
1067         {
1068             char *codeset = savepv(nl_langinfo(CODESET));
1069             if (codeset && strNE(codeset, "")) {
1070
1071                 /* If we switched LC_CTYPE, switch back */
1072                 if (save_ctype_locale) {
1073                     setlocale(LC_CTYPE, save_ctype_locale);
1074                     Safefree(save_ctype_locale);
1075                 }
1076
1077                 is_utf8 = foldEQ(codeset, STR_WITH_LEN("UTF-8"))
1078                         || foldEQ(codeset, STR_WITH_LEN("UTF8"));
1079
1080                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1081                        "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n",
1082                                                      codeset,         is_utf8));
1083                 Safefree(codeset);
1084                 Safefree(save_input_locale);
1085                 return is_utf8;
1086             }
1087             Safefree(codeset);
1088         }
1089
1090 #   endif
1091 #   ifdef MB_CUR_MAX
1092
1093         /* Here, either we don't have nl_langinfo, or it didn't return a
1094          * codeset.  Try MB_CUR_MAX */
1095
1096         /* Standard UTF-8 needs at least 4 bytes to represent the maximum
1097          * Unicode code point.  Since UTF-8 is the only non-single byte
1098          * encoding we handle, we just say any such encoding is UTF-8, and if
1099          * turns out to be wrong, other things will fail */
1100         is_utf8 = MB_CUR_MAX >= 4;
1101
1102         DEBUG_L(PerlIO_printf(Perl_debug_log,
1103                               "\tMB_CUR_MAX=%d; ?UTF8 locale=%d\n",
1104                                    (int) MB_CUR_MAX,      is_utf8));
1105
1106         Safefree(save_input_locale);
1107
1108 #       ifdef HAS_MBTOWC
1109
1110         /* ... But, most system that have MB_CUR_MAX will also have mbtowc(),
1111          * since they are both in the C99 standard.  We can feed a known byte
1112          * string to the latter function, and check that it gives the expected
1113          * result */
1114         if (is_utf8) {
1115             wchar_t wc;
1116             GCC_DIAG_IGNORE(-Wunused-result);
1117             (void) mbtowc(&wc, NULL, 0);    /* Reset any shift state */
1118             GCC_DIAG_RESTORE;
1119             errno = 0;
1120             if ((size_t)mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8))
1121                                                         != strlen(HYPHEN_UTF8)
1122                 || wc != (wchar_t) 0x2010)
1123             {
1124                 is_utf8 = FALSE;
1125                 DEBUG_L(PerlIO_printf(Perl_debug_log, "\thyphen=U+%x\n", wc));
1126                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1127                         "\treturn from mbtowc=%d; errno=%d; ?UTF8 locale=0\n",
1128                         mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8)), errno));
1129             }
1130         }
1131 #       endif
1132
1133         /* If we switched LC_CTYPE, switch back */
1134         if (save_ctype_locale) {
1135             setlocale(LC_CTYPE, save_ctype_locale);
1136             Safefree(save_ctype_locale);
1137         }
1138
1139         return is_utf8;
1140 #   endif
1141     }
1142
1143   cant_use_nllanginfo:
1144
1145 #endif /* HAS_NL_LANGINFO etc */
1146
1147     /* nl_langinfo not available or failed somehow.  Look at the locale name to
1148      * see if it matches qr/UTF -? 8 /ix  */
1149
1150     final_pos = strlen(save_input_locale) - 1;
1151     if (final_pos >= 3) {
1152         char *name = save_input_locale;
1153
1154         /* Find next 'U' or 'u' and look from there */
1155         while ((name += strcspn(name, "Uu") + 1)
1156                                             <= save_input_locale + final_pos - 2)
1157         {
1158             if (toFOLD(*(name)) != 't'
1159                 || toFOLD(*(name + 1)) != 'f')
1160             {
1161                 continue;
1162             }
1163             name += 2;
1164             if (*(name) == '-') {
1165                 if ((name > save_input_locale + final_pos - 1)) {
1166                     break;
1167                 }
1168                 name++;
1169             }
1170             if (*(name) == '8') {
1171                 Safefree(save_input_locale);
1172                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1173                                       "Locale %s ends with UTF-8 in name\n",
1174                                       save_input_locale));
1175                 return TRUE;
1176             }
1177         }
1178         DEBUG_L(PerlIO_printf(Perl_debug_log,
1179                               "Locale %s doesn't end with UTF-8 in name\n",
1180                                 save_input_locale));
1181     }
1182
1183 #ifdef WIN32
1184     /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
1185     if (final_pos >= 4
1186         && *(save_input_locale + final_pos - 0) == '1'
1187         && *(save_input_locale + final_pos - 1) == '0'
1188         && *(save_input_locale + final_pos - 2) == '0'
1189         && *(save_input_locale + final_pos - 3) == '5'
1190         && *(save_input_locale + final_pos - 4) == '6')
1191     {
1192         DEBUG_L(PerlIO_printf(Perl_debug_log,
1193                         "Locale %s ends with 10056 in name, is UTF-8 locale\n",
1194                         save_input_locale));
1195         Safefree(save_input_locale);
1196         return TRUE;
1197     }
1198 #endif
1199
1200     /* Other common encodings are the ISO 8859 series, which aren't UTF-8 */
1201     if (instr(save_input_locale, "8859")) {
1202         DEBUG_L(PerlIO_printf(Perl_debug_log,
1203                              "Locale %s has 8859 in name, not UTF-8 locale\n",
1204                              save_input_locale));
1205         Safefree(save_input_locale);
1206         return FALSE;
1207     }
1208
1209 #ifdef HAS_LOCALECONV
1210
1211 #   ifdef USE_LOCALE_MONETARY
1212
1213     /* Here, there is nothing in the locale name to indicate whether the locale
1214      * is UTF-8 or not.  This "name", the return of setlocale(), is actually
1215      * defined to be opaque, so we can't really rely on the absence of various
1216      * substrings in the name to indicate its UTF-8ness.  Look at the locale's
1217      * currency symbol.  Often that will be in the native script, and if the
1218      * symbol isn't in UTF-8, we know that the locale isn't.  If it is
1219      * non-ASCII UTF-8, we infer that the locale is too.
1220      * To do this, like above for LC_CTYPE, we first set LC_MONETARY to the
1221      * locale of the desired category, if it isn't that locale already */
1222
1223     {
1224         char *save_monetary_locale = NULL;
1225         bool illegal_utf8 = FALSE;
1226         bool only_ascii = FALSE;
1227         const struct lconv* const lc = localeconv();
1228
1229         if (category != LC_MONETARY) {
1230
1231             save_monetary_locale = stdize_locale(savepv(setlocale(LC_MONETARY,
1232                                                                   NULL)));
1233             if (! save_monetary_locale) {
1234                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1235                             "Could not find current locale for LC_MONETARY\n"));
1236                 goto cant_use_monetary;
1237             }
1238
1239             if (strNE(save_monetary_locale, save_input_locale)) {
1240                 if (! setlocale(LC_MONETARY, save_input_locale)) {
1241                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1242                                 "Could not change LC_MONETARY locale to %s\n",
1243                                                             save_input_locale));
1244                     Safefree(save_monetary_locale);
1245                     goto cant_use_monetary;
1246                 }
1247             }
1248         }
1249
1250         /* Here the current LC_MONETARY is set to the locale of the category
1251          * whose information is desired. */
1252
1253         if (lc && lc->currency_symbol) {
1254             if (! is_utf8_string((U8 *) lc->currency_symbol, 0)) {
1255                 DEBUG_L(PerlIO_printf(Perl_debug_log,
1256                             "Currency symbol for %s is not legal UTF-8\n",
1257                                         save_input_locale));
1258                 illegal_utf8 = TRUE;
1259             }
1260             else if (is_ascii_string((U8 *) lc->currency_symbol, 0)) {
1261                 DEBUG_L(PerlIO_printf(Perl_debug_log, "Currency symbol for %s contains only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale));
1262                 only_ascii = TRUE;
1263             }
1264         }
1265
1266         /* If we changed it, restore LC_MONETARY to its original locale */
1267         if (save_monetary_locale) {
1268             setlocale(LC_MONETARY, save_monetary_locale);
1269             Safefree(save_monetary_locale);
1270         }
1271
1272         Safefree(save_input_locale);
1273
1274         /* It isn't a UTF-8 locale if the symbol is not legal UTF-8; otherwise
1275          * assume the locale is UTF-8 if and only if the symbol is non-ascii
1276          * UTF-8.  (We can't really tell if the locale is UTF-8 or not if the
1277          * symbol is just a '$', so we err on the side of it not being UTF-8)
1278          * */
1279         DEBUG_L(PerlIO_printf(Perl_debug_log, "\tis_utf8=%d\n", (illegal_utf8)
1280                                                                ? FALSE
1281                                                                : ! only_ascii));
1282         return (illegal_utf8)
1283                 ? FALSE
1284                 : ! only_ascii;
1285
1286     }
1287   cant_use_monetary:
1288
1289 #   endif /* USE_LOCALE_MONETARY */
1290 #endif /* HAS_LOCALECONV */
1291
1292 #if 0 && defined(HAS_STRERROR) && defined(USE_LOCALE_MESSAGES)
1293
1294 /* This code is ifdefd out because it was found to not be necessary in testing
1295  * on our dromedary test machine, which has over 700 locales.  There, looking
1296  * at just the currency symbol gave essentially the same results as doing this
1297  * extra work.  Executing this also caused segfaults in miniperl.  I left it in
1298  * so as to avoid rewriting it if real-world experience indicates that
1299  * dromedary is an outlier.  Essentially, instead of returning abpve if we
1300  * haven't found illegal utf8, we continue on and examine all the strerror()
1301  * messages on the platform for utf8ness.  If all are ASCII, we still don't
1302  * know the answer; but otherwise we have a pretty good indication of the
1303  * utf8ness.  The reason this doesn't necessarily help much is that the
1304  * messages may not have been translated into the locale.  The currency symbol
1305  * is much more likely to have been translated.  The code below would need to
1306  * be altered somewhat to just be a continuation of testing the currency
1307  * symbol. */
1308         int e;
1309         unsigned int failures = 0, non_ascii = 0;
1310         char *save_messages_locale = NULL;
1311
1312         /* Like above for LC_CTYPE, we set LC_MESSAGES to the locale of the
1313          * desired category, if it isn't that locale already */
1314
1315         if (category != LC_MESSAGES) {
1316
1317             save_messages_locale = stdize_locale(savepv(setlocale(LC_MESSAGES,
1318                                                                   NULL)));
1319             if (! save_messages_locale) {
1320                 goto cant_use_messages;
1321             }
1322
1323             if (strEQ(save_messages_locale, save_input_locale)) {
1324                 Safefree(save_input_locale);
1325             }
1326             else if (! setlocale(LC_MESSAGES, save_input_locale)) {
1327                 Safefree(save_messages_locale);
1328                 goto cant_use_messages;
1329             }
1330         }
1331
1332         /* Here the current LC_MESSAGES is set to the locale of the category
1333          * whose information is desired.  Look through all the messages */
1334
1335         for (e = 0;
1336 #ifdef HAS_SYS_ERRLIST
1337              e <= sys_nerr
1338 #endif
1339              ; e++)
1340         {
1341             const U8* const errmsg = (U8 *) Strerror(e) ;
1342             if (!errmsg)
1343                 break;
1344             if (! is_utf8_string(errmsg, 0)) {
1345                 failures++;
1346                 break;
1347             }
1348             else if (! is_ascii_string(errmsg, 0)) {
1349                 non_ascii++;
1350             }
1351         }
1352
1353         /* And, if we changed it, restore LC_MESSAGES to its original locale */
1354         if (save_messages_locale) {
1355             setlocale(LC_MESSAGES, save_messages_locale);
1356             Safefree(save_messages_locale);
1357         }
1358
1359         /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
1360          * any non-ascii means it is one; otherwise we assume it isn't */
1361         return (failures) ? FALSE : non_ascii;
1362
1363     }
1364   cant_use_messages:
1365
1366 #endif
1367
1368     DEBUG_L(PerlIO_printf(Perl_debug_log,
1369                           "Assuming locale %s is not a UTF-8 locale\n",
1370                                     save_input_locale));
1371     Safefree(save_input_locale);
1372     return FALSE;
1373 }
1374
1375 #endif
1376
1377
1378 bool
1379 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
1380 {
1381     dVAR;
1382     /* Internal function which returns if we are in the scope of a pragma that
1383      * enables the locale category 'category'.  'compiling' should indicate if
1384      * this is during the compilation phase (TRUE) or not (FALSE). */
1385
1386     const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
1387
1388     SV *categories = cop_hints_fetch_pvs(cop, "locale", 0);
1389     if (! categories || categories == &PL_sv_placeholder) {
1390         return FALSE;
1391     }
1392
1393     /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
1394      * a valid unsigned */
1395     assert(category >= -1);
1396     return cBOOL(SvUV(categories) & (1U << (category + 1)));
1397 }
1398
1399 char *
1400 Perl_my_strerror(pTHX_ const int errnum) {
1401
1402     /* Uses C locale for the error text unless within scope of 'use locale' for
1403      * LC_MESSAGES */
1404
1405 #ifdef USE_LOCALE_MESSAGES
1406     if (! IN_LC(LC_MESSAGES)) {
1407         char * save_locale = setlocale(LC_MESSAGES, NULL);
1408         if (! ((*save_locale == 'C' && save_locale[1] == '\0')
1409                 || strEQ(save_locale, "POSIX")))
1410         {
1411             char *errstr;
1412
1413             /* The next setlocale likely will zap this, so create a copy */
1414             save_locale = savepv(save_locale);
1415
1416             setlocale(LC_MESSAGES, "C");
1417
1418             /* This points to the static space in Strerror, with all its
1419              * limitations */
1420             errstr = Strerror(errnum);
1421
1422             setlocale(LC_MESSAGES, save_locale);
1423             Safefree(save_locale);
1424             return errstr;
1425         }
1426     }
1427 #endif
1428
1429     return Strerror(errnum);
1430 }
1431
1432 /*
1433  * Local variables:
1434  * c-indentation-style: bsd
1435  * c-basic-offset: 4
1436  * indent-tabs-mode: nil
1437  * End:
1438  *
1439  * ex: set ts=8 sts=4 sw=4 et:
1440  */