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