Update perldelta_template.pod to include an "Errata From Previous Releases" section
[perl.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     dVAR;
97 # ifdef HAS_LOCALECONV
98     const struct lconv* const lc = localeconv();
99
100     if (lc && lc->decimal_point) {
101         if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
102             SvREFCNT_dec(PL_numeric_radix_sv);
103             PL_numeric_radix_sv = NULL;
104         }
105         else {
106             if (PL_numeric_radix_sv)
107                 sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
108             else
109                 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
110             if (! is_ascii_string((U8 *) lc->decimal_point, 0)
111                 && is_utf8_string((U8 *) lc->decimal_point, 0)
112                 && is_cur_LC_category_utf8(LC_NUMERIC))
113             {
114                 SvUTF8_on(PL_numeric_radix_sv);
115             }
116         }
117     }
118     else
119         PL_numeric_radix_sv = NULL;
120 # endif /* HAS_LOCALECONV */
121 #endif /* USE_LOCALE_NUMERIC */
122 }
123
124 void
125 Perl_new_numeric(pTHX_ const char *newnum)
126 {
127 #ifdef USE_LOCALE_NUMERIC
128
129     /* Called after all libc setlocale() calls affecting LC_NUMERIC, to tell
130      * core Perl this and that 'newnum' is the name of the new locale.
131      * It installs this locale as the current underlying default.
132      *
133      * The default locale and the C locale can be toggled between by use of the
134      * set_numeric_local() and set_numeric_standard() functions, which should
135      * probably not be called directly, but only via macros like
136      * SET_NUMERIC_STANDARD() in perl.h.
137      *
138      * The toggling is necessary mainly so that a non-dot radix decimal point
139      * character can be output, while allowing internal calculations to use a
140      * dot.
141      *
142      * This sets several interpreter-level variables:
143      * PL_numeric_name  The default locale's name: a copy of 'newnum'
144      * PL_numeric_local A boolean indicating if the toggled state is such
145      *                  that the current locale is the default locale
146      * PL_numeric_standard A boolean indicating if the toggled state is such
147      *                  that the current locale is the C locale
148      * Note that both of the last two variables can be true at the same time,
149      * if the underlying locale is C.  (Toggling is a no-op under these
150      * circumstances.)
151      *
152      * Any code changing the locale (outside this file) should use
153      * POSIX::setlocale, which calls this function.  Therefore this function
154      * should be called directly only from this file and from
155      * POSIX::setlocale() */
156
157     char *save_newnum;
158     dVAR;
159
160     if (! newnum) {
161         Safefree(PL_numeric_name);
162         PL_numeric_name = NULL;
163         PL_numeric_standard = TRUE;
164         PL_numeric_local = TRUE;
165         return;
166     }
167
168     save_newnum = stdize_locale(savepv(newnum));
169     if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
170         Safefree(PL_numeric_name);
171         PL_numeric_name = save_newnum;
172     }
173
174     PL_numeric_standard = ((*save_newnum == 'C' && save_newnum[1] == '\0')
175                             || strEQ(save_newnum, "POSIX"));
176     PL_numeric_local = TRUE;
177     set_numeric_radix();
178
179 #endif /* USE_LOCALE_NUMERIC */
180 }
181
182 void
183 Perl_set_numeric_standard(pTHX)
184 {
185 #ifdef USE_LOCALE_NUMERIC
186     dVAR;
187
188     /* Toggle the LC_NUMERIC locale to C, if not already there.  Probably
189      * should use the macros like SET_NUMERIC_STANDARD() in perl.h instead of
190      * calling this directly. */
191
192     if (! PL_numeric_standard) {
193         setlocale(LC_NUMERIC, "C");
194         PL_numeric_standard = TRUE;
195         PL_numeric_local = FALSE;
196         set_numeric_radix();
197     }
198
199 #endif /* USE_LOCALE_NUMERIC */
200 }
201
202 void
203 Perl_set_numeric_local(pTHX)
204 {
205 #ifdef USE_LOCALE_NUMERIC
206     dVAR;
207
208     /* Toggle the LC_NUMERIC locale to the current underlying default, if not
209      * already there.  Probably should use the macros like SET_NUMERIC_LOCAL()
210      * in perl.h instead of calling this directly. */
211
212     if (! PL_numeric_local) {
213         setlocale(LC_NUMERIC, PL_numeric_name);
214         PL_numeric_standard = FALSE;
215         PL_numeric_local = TRUE;
216         set_numeric_radix();
217     }
218
219 #endif /* USE_LOCALE_NUMERIC */
220 }
221
222 /*
223  * Set up for a new ctype locale.
224  */
225 void
226 Perl_new_ctype(pTHX_ const char *newctype)
227 {
228 #ifdef USE_LOCALE_CTYPE
229
230     /* Called after all libc setlocale() calls affecting LC_CTYPE, to tell
231      * core Perl this and that 'newctype' is the name of the new locale.
232      *
233      * This function sets up the folding arrays for all 256 bytes, assuming
234      * that tofold() is tolc() since fold case is not a concept in POSIX,
235      *
236      * Any code changing the locale (outside this file) should use
237      * POSIX::setlocale, which calls this function.  Therefore this function
238      * should be called directly only from this file and from
239      * POSIX::setlocale() */
240
241     dVAR;
242     UV i;
243
244     PERL_ARGS_ASSERT_NEW_CTYPE;
245
246     PL_in_utf8_CTYPE_locale = is_cur_LC_category_utf8(LC_CTYPE);
247
248     /* A UTF-8 locale gets standard rules.  But note that code still has to
249      * handle this specially because of the three problematic code points */
250     if (PL_in_utf8_CTYPE_locale) {
251         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
252     }
253     else {
254         for (i = 0; i < 256; i++) {
255             if (isUPPER_LC((U8) i))
256                 PL_fold_locale[i] = (U8) toLOWER_LC((U8) i);
257             else if (isLOWER_LC((U8) i))
258                 PL_fold_locale[i] = (U8) toUPPER_LC((U8) i);
259             else
260                 PL_fold_locale[i] = (U8) i;
261         }
262     }
263
264 #endif /* USE_LOCALE_CTYPE */
265     PERL_ARGS_ASSERT_NEW_CTYPE;
266     PERL_UNUSED_ARG(newctype);
267     PERL_UNUSED_CONTEXT;
268 }
269
270 void
271 Perl_new_collate(pTHX_ const char *newcoll)
272 {
273 #ifdef USE_LOCALE_COLLATE
274
275     /* Called after all libc setlocale() calls affecting LC_COLLATE, to tell
276      * core Perl this and that 'newcoll' is the name of the new locale.
277      *
278      * Any code changing the locale (outside this file) should use
279      * POSIX::setlocale, which calls this function.  Therefore this function
280      * should be called directly only from this file and from
281      * POSIX::setlocale() */
282
283     dVAR;
284
285     if (! newcoll) {
286         if (PL_collation_name) {
287             ++PL_collation_ix;
288             Safefree(PL_collation_name);
289             PL_collation_name = NULL;
290         }
291         PL_collation_standard = TRUE;
292         PL_collxfrm_base = 0;
293         PL_collxfrm_mult = 2;
294         return;
295     }
296
297     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
298         ++PL_collation_ix;
299         Safefree(PL_collation_name);
300         PL_collation_name = stdize_locale(savepv(newcoll));
301         PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
302                                  || strEQ(newcoll, "POSIX"));
303
304         {
305           /*  2: at most so many chars ('a', 'b'). */
306           /* 50: surely no system expands a char more. */
307 #define XFRMBUFSIZE  (2 * 50)
308           char xbuf[XFRMBUFSIZE];
309           const Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
310           const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
311           const SSize_t mult = fb - fa;
312           if (mult < 1 && !(fa == 0 && fb == 0))
313               Perl_croak(aTHX_ "panic: strxfrm() gets absurd - a => %"UVuf", ab => %"UVuf,
314                          (UV) fa, (UV) fb);
315           PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
316           PL_collxfrm_mult = mult;
317         }
318     }
319
320 #endif /* USE_LOCALE_COLLATE */
321 }
322
323 /*
324  * Initialize locale awareness.
325  */
326 int
327 Perl_init_i18nl10n(pTHX_ int printwarn)
328 {
329     int ok = 1;
330     /* returns
331      *    1 = set ok or not applicable,
332      *    0 = fallback to C locale,
333      *   -1 = fallback to C locale failed
334      */
335
336 #if defined(USE_LOCALE)
337     dVAR;
338
339 #ifdef USE_LOCALE_CTYPE
340     char *curctype   = NULL;
341 #endif /* USE_LOCALE_CTYPE */
342 #ifdef USE_LOCALE_COLLATE
343     char *curcoll    = NULL;
344 #endif /* USE_LOCALE_COLLATE */
345 #ifdef USE_LOCALE_NUMERIC
346     char *curnum     = NULL;
347 #endif /* USE_LOCALE_NUMERIC */
348 #ifdef __GLIBC__
349     char * const language   = PerlEnv_getenv("LANGUAGE");
350 #endif
351     /* NULL uses the existing already set up locale */
352     const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
353                                         ? NULL
354                                         : "";
355     char * const lc_all     = PerlEnv_getenv("LC_ALL");
356     char * const lang       = PerlEnv_getenv("LANG");
357     bool setlocale_failure = FALSE;
358
359 #ifdef LOCALE_ENVIRON_REQUIRED
360
361     /*
362      * Ultrix setlocale(..., "") fails if there are no environment
363      * variables from which to get a locale name.
364      */
365
366     bool done = FALSE;
367
368 #   ifdef LC_ALL
369     if (lang) {
370         if (setlocale(LC_ALL, setlocale_init))
371             done = TRUE;
372         else
373             setlocale_failure = TRUE;
374     }
375     if (!setlocale_failure) {
376 #       ifdef USE_LOCALE_CTYPE
377         Safefree(curctype);
378         if (! (curctype =
379                setlocale(LC_CTYPE,
380                          (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
381                                     ? setlocale_init : NULL)))
382             setlocale_failure = TRUE;
383         else
384             curctype = savepv(curctype);
385 #       endif /* USE_LOCALE_CTYPE */
386 #       ifdef USE_LOCALE_COLLATE
387         Safefree(curcoll);
388         if (! (curcoll =
389                setlocale(LC_COLLATE,
390                          (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
391                                    ? setlocale_init : NULL)))
392             setlocale_failure = TRUE;
393         else
394             curcoll = savepv(curcoll);
395 #       endif /* USE_LOCALE_COLLATE */
396 #       ifdef USE_LOCALE_NUMERIC
397         Safefree(curnum);
398         if (! (curnum =
399                setlocale(LC_NUMERIC,
400                          (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
401                                   ? setlocale_init : NULL)))
402             setlocale_failure = TRUE;
403         else
404             curnum = savepv(curnum);
405 #       endif /* USE_LOCALE_NUMERIC */
406     }
407
408 #   endif /* LC_ALL */
409
410 #endif /* !LOCALE_ENVIRON_REQUIRED */
411
412 #ifdef LC_ALL
413     if (! setlocale(LC_ALL, setlocale_init))
414         setlocale_failure = TRUE;
415 #endif /* LC_ALL */
416
417     if (!setlocale_failure) {
418 #ifdef USE_LOCALE_CTYPE
419         Safefree(curctype);
420         if (! (curctype = setlocale(LC_CTYPE, setlocale_init)))
421             setlocale_failure = TRUE;
422         else
423             curctype = savepv(curctype);
424 #endif /* USE_LOCALE_CTYPE */
425 #ifdef USE_LOCALE_COLLATE
426         Safefree(curcoll);
427         if (! (curcoll = setlocale(LC_COLLATE, setlocale_init)))
428             setlocale_failure = TRUE;
429         else
430             curcoll = savepv(curcoll);
431 #endif /* USE_LOCALE_COLLATE */
432 #ifdef USE_LOCALE_NUMERIC
433         Safefree(curnum);
434         if (! (curnum = setlocale(LC_NUMERIC, setlocale_init)))
435             setlocale_failure = TRUE;
436         else
437             curnum = savepv(curnum);
438 #endif /* USE_LOCALE_NUMERIC */
439     }
440
441     if (setlocale_failure) {
442         char *p;
443         const bool locwarn = (printwarn > 1 ||
444                         (printwarn &&
445                          (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
446
447         if (locwarn) {
448 #ifdef LC_ALL
449
450             PerlIO_printf(Perl_error_log,
451                "perl: warning: Setting locale failed.\n");
452
453 #else /* !LC_ALL */
454
455             PerlIO_printf(Perl_error_log,
456                "perl: warning: Setting locale failed for the categories:\n\t");
457 #ifdef USE_LOCALE_CTYPE
458             if (! curctype)
459                 PerlIO_printf(Perl_error_log, "LC_CTYPE ");
460 #endif /* USE_LOCALE_CTYPE */
461 #ifdef USE_LOCALE_COLLATE
462             if (! curcoll)
463                 PerlIO_printf(Perl_error_log, "LC_COLLATE ");
464 #endif /* USE_LOCALE_COLLATE */
465 #ifdef USE_LOCALE_NUMERIC
466             if (! curnum)
467                 PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
468 #endif /* USE_LOCALE_NUMERIC */
469             PerlIO_printf(Perl_error_log, "\n");
470
471 #endif /* LC_ALL */
472
473             PerlIO_printf(Perl_error_log,
474                 "perl: warning: Please check that your locale settings:\n");
475
476 #ifdef __GLIBC__
477             PerlIO_printf(Perl_error_log,
478                           "\tLANGUAGE = %c%s%c,\n",
479                           language ? '"' : '(',
480                           language ? language : "unset",
481                           language ? '"' : ')');
482 #endif
483
484             PerlIO_printf(Perl_error_log,
485                           "\tLC_ALL = %c%s%c,\n",
486                           lc_all ? '"' : '(',
487                           lc_all ? lc_all : "unset",
488                           lc_all ? '"' : ')');
489
490 #if defined(USE_ENVIRON_ARRAY)
491             {
492               char **e;
493               for (e = environ; *e; e++) {
494                   if (strnEQ(*e, "LC_", 3)
495                         && strnNE(*e, "LC_ALL=", 7)
496                         && (p = strchr(*e, '=')))
497                       PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
498                                     (int)(p - *e), *e, p + 1);
499               }
500             }
501 #else
502             PerlIO_printf(Perl_error_log,
503                           "\t(possibly more locale environment variables)\n");
504 #endif
505
506             PerlIO_printf(Perl_error_log,
507                           "\tLANG = %c%s%c\n",
508                           lang ? '"' : '(',
509                           lang ? lang : "unset",
510                           lang ? '"' : ')');
511
512             PerlIO_printf(Perl_error_log,
513                           "    are supported and installed on your system.\n");
514         }
515
516 #ifdef LC_ALL
517
518         if (setlocale(LC_ALL, "C")) {
519             if (locwarn)
520                 PerlIO_printf(Perl_error_log,
521       "perl: warning: Falling back to the standard locale (\"C\").\n");
522             ok = 0;
523         }
524         else {
525             if (locwarn)
526                 PerlIO_printf(Perl_error_log,
527       "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
528             ok = -1;
529         }
530
531 #else /* ! LC_ALL */
532
533         if (0
534 #ifdef USE_LOCALE_CTYPE
535             || !(curctype || setlocale(LC_CTYPE, "C"))
536 #endif /* USE_LOCALE_CTYPE */
537 #ifdef USE_LOCALE_COLLATE
538             || !(curcoll || setlocale(LC_COLLATE, "C"))
539 #endif /* USE_LOCALE_COLLATE */
540 #ifdef USE_LOCALE_NUMERIC
541             || !(curnum || setlocale(LC_NUMERIC, "C"))
542 #endif /* USE_LOCALE_NUMERIC */
543             )
544         {
545             if (locwarn)
546                 PerlIO_printf(Perl_error_log,
547       "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
548             ok = -1;
549         }
550
551 #endif /* ! LC_ALL */
552
553 #ifdef USE_LOCALE_CTYPE
554         Safefree(curctype);
555         curctype = savepv(setlocale(LC_CTYPE, NULL));
556 #endif /* USE_LOCALE_CTYPE */
557 #ifdef USE_LOCALE_COLLATE
558         Safefree(curcoll);
559         curcoll = savepv(setlocale(LC_COLLATE, NULL));
560 #endif /* USE_LOCALE_COLLATE */
561 #ifdef USE_LOCALE_NUMERIC
562         Safefree(curnum);
563         curnum = savepv(setlocale(LC_NUMERIC, NULL));
564 #endif /* USE_LOCALE_NUMERIC */
565     }
566     else {
567
568 #ifdef USE_LOCALE_CTYPE
569     new_ctype(curctype);
570 #endif /* USE_LOCALE_CTYPE */
571
572 #ifdef USE_LOCALE_COLLATE
573     new_collate(curcoll);
574 #endif /* USE_LOCALE_COLLATE */
575
576 #ifdef USE_LOCALE_NUMERIC
577     new_numeric(curnum);
578 #endif /* USE_LOCALE_NUMERIC */
579
580     }
581
582 #if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
583     {
584       /* Set PL_utf8locale to TRUE if using PerlIO _and_
585          the current LC_CTYPE locale is UTF-8.
586          If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
587          are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
588          on STDIN, STDOUT, STDERR, _and_ the default open discipline.
589       */
590         PL_utf8locale = is_cur_LC_category_utf8(LC_CTYPE);
591     }
592     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
593        This is an alternative to using the -C command line switch
594        (the -C if present will override this). */
595     {
596          const char *p = PerlEnv_getenv("PERL_UNICODE");
597          PL_unicode = p ? parse_unicode_opts(&p) : 0;
598          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
599              PL_utf8cache = -1;
600     }
601 #endif
602
603 #ifdef USE_LOCALE_CTYPE
604     Safefree(curctype);
605 #endif /* USE_LOCALE_CTYPE */
606 #ifdef USE_LOCALE_COLLATE
607     Safefree(curcoll);
608 #endif /* USE_LOCALE_COLLATE */
609 #ifdef USE_LOCALE_NUMERIC
610     Safefree(curnum);
611 #endif /* USE_LOCALE_NUMERIC */
612
613 #endif /* USE_LOCALE */
614
615     return ok;
616 }
617
618 #ifdef USE_LOCALE_COLLATE
619
620 /*
621  * mem_collxfrm() is a bit like strxfrm() but with two important
622  * differences. First, it handles embedded NULs. Second, it allocates
623  * a bit more memory than needed for the transformed data itself.
624  * The real transformed data begins at offset sizeof(collationix).
625  * Please see sv_collxfrm() to see how this is used.
626  */
627
628 char *
629 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
630 {
631     dVAR;
632     char *xbuf;
633     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
634
635     PERL_ARGS_ASSERT_MEM_COLLXFRM;
636
637     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
638     /* the +1 is for the terminating NUL. */
639
640     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
641     Newx(xbuf, xAlloc, char);
642     if (! xbuf)
643         goto bad;
644
645     *(U32*)xbuf = PL_collation_ix;
646     xout = sizeof(PL_collation_ix);
647     for (xin = 0; xin < len; ) {
648         Size_t xused;
649
650         for (;;) {
651             xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
652             if (xused >= PERL_INT_MAX)
653                 goto bad;
654             if ((STRLEN)xused < xAlloc - xout)
655                 break;
656             xAlloc = (2 * xAlloc) + 1;
657             Renew(xbuf, xAlloc, char);
658             if (! xbuf)
659                 goto bad;
660         }
661
662         xin += strlen(s + xin) + 1;
663         xout += xused;
664
665         /* Embedded NULs are understood but silently skipped
666          * because they make no sense in locale collation. */
667     }
668
669     xbuf[xout] = '\0';
670     *xlen = xout - sizeof(PL_collation_ix);
671     return xbuf;
672
673   bad:
674     Safefree(xbuf);
675     *xlen = 0;
676     return NULL;
677 }
678
679 #endif /* USE_LOCALE_COLLATE */
680
681 #ifdef USE_LOCALE
682
683 STATIC bool
684 S_is_cur_LC_category_utf8(pTHX_ int category)
685 {
686     /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
687      * otherwise. 'category' may not be LC_ALL.  If the platform doesn't have
688      * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
689      * could give the wrong result.  It errs on the side of not being a UTF-8
690      * locale. */
691
692     char *save_input_locale = NULL;
693     STRLEN final_pos;
694
695 #ifdef LC_ALL
696     assert(category != LC_ALL);
697 #endif
698
699     /* First dispose of the trivial cases */
700     save_input_locale = setlocale(category, NULL);
701     if (! save_input_locale) {
702         return FALSE;   /* XXX maybe should croak */
703     }
704     save_input_locale = stdize_locale(savepv(save_input_locale));
705     if ((*save_input_locale == 'C' && save_input_locale[1] == '\0')
706         || strEQ(save_input_locale, "POSIX"))
707     {
708         Safefree(save_input_locale);
709         return FALSE;
710     }
711
712 #if defined(USE_LOCALE_CTYPE)    \
713     && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET)))
714
715     { /* Next try nl_langinfo or MB_CUR_MAX if available */
716
717         char *save_ctype_locale = NULL;
718         bool is_utf8;
719
720         if (category != LC_CTYPE) { /* These work only on LC_CTYPE */
721
722             /* Get the current LC_CTYPE locale */
723             save_ctype_locale = stdize_locale(savepv(setlocale(LC_CTYPE, NULL)));
724             if (! save_ctype_locale) {
725                 goto cant_use_nllanginfo;
726             }
727
728             /* If LC_CTYPE and the desired category use the same locale, this
729              * means that finding the value for LC_CTYPE is the same as finding
730              * the value for the desired category.  Otherwise, switch LC_CTYPE
731              * to the desired category's locale */
732             if (strEQ(save_ctype_locale, save_input_locale)) {
733                 Safefree(save_ctype_locale);
734                 save_ctype_locale = NULL;
735             }
736             else if (! setlocale(LC_CTYPE, save_input_locale)) {
737                 Safefree(save_ctype_locale);
738                 goto cant_use_nllanginfo;
739             }
740         }
741
742         /* Here the current LC_CTYPE is set to the locale of the category whose
743          * information is desired.  This means that nl_langinfo() and MB_CUR_MAX
744          * should give the correct results */
745
746 #   if defined(HAS_NL_LANGINFO) && defined(CODESET)
747         {
748             char *codeset = savepv(nl_langinfo(CODESET));
749             if (codeset && strNE(codeset, "")) {
750
751                 /* If we switched LC_CTYPE, switch back */
752                 if (save_ctype_locale) {
753                     setlocale(LC_CTYPE, save_ctype_locale);
754                     Safefree(save_ctype_locale);
755                 }
756
757                 is_utf8 = foldEQ(codeset, STR_WITH_LEN("UTF-8"))
758                         || foldEQ(codeset, STR_WITH_LEN("UTF8"));
759
760                 Safefree(codeset);
761                 Safefree(save_input_locale);
762                 return is_utf8;
763             }
764         }
765
766 #   endif
767 #   ifdef MB_CUR_MAX
768
769         /* Here, either we don't have nl_langinfo, or it didn't return a
770          * codeset.  Try MB_CUR_MAX */
771
772         /* Standard UTF-8 needs at least 4 bytes to represent the maximum
773          * Unicode code point.  Since UTF-8 is the only non-single byte
774          * encoding we handle, we just say any such encoding is UTF-8, and if
775          * turns out to be wrong, other things will fail */
776         is_utf8 = MB_CUR_MAX >= 4;
777
778         Safefree(save_input_locale);
779
780 #       ifdef HAS_MBTOWC
781
782         /* ... But, most system that have MB_CUR_MAX will also have mbtowc(),
783          * since they are both in the C99 standard.  We can feed a known byte
784          * string to the latter function, and check that it gives the expected
785          * result */
786         if (is_utf8) {
787             wchar_t wc;
788             (void) mbtowc(&wc, NULL, 0);    /* Reset any shift state */
789             if (mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8))
790                                                         != strlen(HYPHEN_UTF8)
791                 || wc != (wchar_t) 0x2010)
792             {
793                 is_utf8 = FALSE;
794             }
795         }
796 #       endif
797
798         /* If we switched LC_CTYPE, switch back */
799         if (save_ctype_locale) {
800             setlocale(LC_CTYPE, save_ctype_locale);
801             Safefree(save_ctype_locale);
802         }
803
804         return is_utf8;
805 #   endif
806     }
807
808   cant_use_nllanginfo:
809
810 #endif /* HAS_NL_LANGINFO etc */
811
812     /* nl_langinfo not available or failed somehow.  Look at the locale name to
813      * see if it matches qr/UTF -? 8 /ix  */
814
815     final_pos = strlen(save_input_locale) - 1;
816     if (final_pos >= 3) {
817         char *name = save_input_locale;
818
819         /* Find next 'U' or 'u' and look from there */
820         while ((name += strcspn(name, "Uu") + 1)
821                                             <= save_input_locale + final_pos - 2)
822         {
823             if (toFOLD(*(name)) != 't'
824                 || toFOLD(*(name + 1)) != 'f')
825             {
826                 continue;
827             }
828             name += 2;
829             if (*(name) == '-') {
830                 if ((name > save_input_locale + final_pos - 1)) {
831                     break;
832                 }
833                 name++;
834             }
835             if (*(name) == '8') {
836                 Safefree(save_input_locale);
837                 return TRUE;
838             }
839         }
840     }
841
842 #ifdef WIN32
843     /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
844     if (final_pos >= 4
845         && *(save_input_locale + final_pos - 0) == '1'
846         && *(save_input_locale + final_pos - 1) == '0'
847         && *(save_input_locale + final_pos - 2) == '0'
848         && *(save_input_locale + final_pos - 3) == '5'
849         && *(save_input_locale + final_pos - 4) == '6')
850     {
851         Safefree(save_input_locale);
852         return TRUE;
853     }
854 #endif
855
856     /* Other common encodings are the ISO 8859 series, which aren't UTF-8 */
857     if (instr(save_input_locale, "8859")) {
858         Safefree(save_input_locale);
859         return FALSE;
860     }
861
862 #ifdef HAS_LOCALECONV
863
864 #   ifdef USE_LOCALE_MONETARY
865
866     /* Here, there is nothing in the locale name to indicate whether the locale
867      * is UTF-8 or not.  This "name", the return of setlocale(), is actually
868      * defined to be opaque, so we can't really rely on the absence of various
869      * substrings in the name to indicate its UTF-8ness.  Look at the locale's
870      * currency symbol.  Often that will be in the native script, and if the
871      * symbol isn't in UTF-8, we know that the locale isn't.  If it is
872      * non-ASCII UTF-8, we infer that the locale is too.
873      * To do this, like above for LC_CTYPE, we first set LC_MONETARY to the
874      * locale of the desired category, if it isn't that locale already */
875
876     {
877         char *save_monetary_locale = NULL;
878         bool illegal_utf8 = FALSE;
879         bool only_ascii = FALSE;
880         const struct lconv* const lc = localeconv();
881
882         if (category != LC_MONETARY) {
883
884             save_monetary_locale = stdize_locale(savepv(setlocale(LC_MONETARY,
885                                                                   NULL)));
886             if (! save_monetary_locale) {
887                 goto cant_use_monetary;
888             }
889
890             if (strNE(save_monetary_locale, save_input_locale)) {
891                 if (! setlocale(LC_MONETARY, save_input_locale)) {
892                     Safefree(save_monetary_locale);
893                     goto cant_use_monetary;
894                 }
895             }
896         }
897
898         /* Here the current LC_MONETARY is set to the locale of the category
899          * whose information is desired. */
900
901         if (lc && lc->currency_symbol) {
902             if (! is_utf8_string((U8 *) lc->currency_symbol, 0)) {
903                 illegal_utf8 = TRUE;
904             }
905             else if (is_ascii_string((U8 *) lc->currency_symbol, 0)) {
906                 only_ascii = TRUE;
907             }
908         }
909
910         /* If we changed it, restore LC_MONETARY to its original locale */
911         if (save_monetary_locale) {
912             setlocale(LC_MONETARY, save_monetary_locale);
913             Safefree(save_monetary_locale);
914         }
915
916         Safefree(save_input_locale);
917
918         /* It isn't a UTF-8 locale if the symbol is not legal UTF-8; otherwise
919          * assume the locale is UTF-8 if and only if the symbol is non-ascii
920          * UTF-8.  (We can't really tell if the locale is UTF-8 or not if the
921          * symbol is just a '$', so we err on the side of it not being UTF-8)
922          * */
923         return (illegal_utf8)
924                 ? FALSE
925                 : ! only_ascii;
926
927     }
928   cant_use_monetary:
929
930 #   endif /* USE_LOCALE_MONETARY */
931 #endif /* HAS_LOCALECONV */
932
933 #if 0 && defined(HAS_STRERROR) && defined(USE_LOCALE_MESSAGES)
934
935 /* This code is ifdefd out because it was found to not be necessary in testing
936  * on our dromedary test machine, which has over 700 locales.  There, looking
937  * at just the currency symbol gave essentially the same results as doing this
938  * extra work.  Executing this also caused segfaults in miniperl.  I left it in
939  * so as to avoid rewriting it if real-world experience indicates that
940  * dromedary is an outlier.  Essentially, instead of returning abpve if we
941  * haven't found illegal utf8, we continue on and examine all the strerror()
942  * messages on the platform for utf8ness.  If all are ASCII, we still don't
943  * know the answer; but otherwise we have a pretty good indication of the
944  * utf8ness.  The reason this doesn't necessarily help much is that the
945  * messages may not have been translated into the locale.  The currency symbol
946  * is much more likely to have been translated.  The code below would need to
947  * be altered somewhat to just be a continuation of testing the currency
948  * symbol. */
949         int e;
950         unsigned int failures = 0, non_ascii = 0;
951         char *save_messages_locale = NULL;
952
953         /* Like above for LC_CTYPE, we set LC_MESSAGES to the locale of the
954          * desired category, if it isn't that locale already */
955
956         if (category != LC_MESSAGES) {
957
958             save_messages_locale = stdize_locale(savepv(setlocale(LC_MESSAGES,
959                                                                   NULL)));
960             if (! save_messages_locale) {
961                 goto cant_use_messages;
962             }
963
964             if (strEQ(save_messages_locale, save_input_locale)) {
965                 Safefree(save_input_locale);
966             }
967             else if (! setlocale(LC_MESSAGES, save_input_locale)) {
968                 Safefree(save_messages_locale);
969                 goto cant_use_messages;
970             }
971         }
972
973         /* Here the current LC_MESSAGES is set to the locale of the category
974          * whose information is desired.  Look through all the messages */
975
976         for (e = 0;
977 #ifdef HAS_SYS_ERRLIST
978              e <= sys_nerr
979 #endif
980              ; e++)
981         {
982             const U8* const errmsg = (U8 *) Strerror(e) ;
983             if (!errmsg)
984                 break;
985             if (! is_utf8_string(errmsg, 0)) {
986                 failures++;
987                 break;
988             }
989             else if (! is_ascii_string(errmsg, 0)) {
990                 non_ascii++;
991             }
992         }
993
994         /* And, if we changed it, restore LC_MESSAGES to its original locale */
995         if (save_messages_locale) {
996             setlocale(LC_MESSAGES, save_messages_locale);
997             Safefree(save_messages_locale);
998         }
999
1000         /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
1001          * any non-ascii means it is one; otherwise we assume it isn't */
1002         return (failures) ? FALSE : non_ascii;
1003
1004     }
1005   cant_use_messages:
1006
1007 #endif
1008
1009     Safefree(save_input_locale);
1010     return FALSE;
1011 }
1012
1013 #endif
1014
1015 /*
1016  * Local variables:
1017  * c-indentation-style: bsd
1018  * c-basic-offset: 4
1019  * indent-tabs-mode: nil
1020  * End:
1021  *
1022  * ex: set ts=8 sts=4 sw=4 et:
1023  */