This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
perlsub - Link to constant pragma
[perl5.git] / locale.c
CommitLineData
98994639
HS		 1/* locale.c
2 *
1129b882
NC		 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
98994639
HS		 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/*
4ac71550 12 * A Elbereth Gilthoniel,
cdad3b53 13 * silivren penna míriel
4ac71550 14 * o menel aglar elenath!
cdad3b53 15 * Na-chaered palan-díriel
4ac71550
TC		 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"]
98994639
HS		 21 */
22
166f8a29
DM		 23/* utility functions for handling locale-specific stuff like what
24 * character represents the decimal point.
0d071d52 25 *
7d4bcc4a
KW		 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
0d071d52
KW		 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
a9ad02a8
KW		 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'.
e9bc6d6b
KW		 35 *
36 * This code now has multi-thread-safe locale handling on systems that support
37 * that. This is completely transparent to most XS code. On earlier systems,
38 * it would be possible to emulate thread-safe locales, but this likely would
39 * involve a lot of locale switching, and would require XS code changes.
40 * Macros could be written so that the code wouldn't have to know which type of
41 * system is being used. It's unlikely that we would ever do that, since most
42 * modern systems support thread-safe locales, but there was code written to
43 * this end, and is retained, #ifdef'd out.
166f8a29
DM		 44 */
45
98994639
HS		 46#include "EXTERN.h"
47#define PERL_IN_LOCALE_C
f7416781 48#include "perl_langinfo.h"
98994639
HS		 49#include "perl.h"
50
a4af207c
JH		 51#include "reentr.h"
52
0dec74cd
KW		 53#ifdef I_WCHAR
54# include <wchar.h>
55#endif
5b64f24c
KW		 56#ifdef I_WCTYPE
57# include <wctype.h>
58#endif
0dec74cd 59
2fcc0ca9
KW		 60/* If the environment says to, we can output debugging information during
61 * initialization. This is done before option parsing, and before any thread
62 * creation, so can be a file-level static */
8c3a0f6c 63#if ! defined(DEBUGGING)
5a4b0634
KW		 64# define debug_initialization 0
65# define DEBUG_INITIALIZATION_set(v)
66#else
2fcc0ca9 67static bool debug_initialization = FALSE;
5a4b0634 68# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
2fcc0ca9
KW		 69#endif
70
48015184
KW		 71
72/* Returns the Unix errno portion; ignoring any others. This is a macro here
73 * instead of putting it into perl.h, because unclear to khw what should be
74 * done generally. */
75#define GET_ERRNO saved_errno
76
291a84fb
KW		 77/* strlen() of a literal string constant. We might want this more general,
78 * but using it in just this file for now. A problem with more generality is
79 * the compiler warnings about comparing unlike signs */
ff1b739b
KW		 80#define STRLENs(s) (sizeof("" s "") - 1)
81
63e5b0d7
KW		 82/* Is the C string input 'name' "C" or "POSIX"? If so, and 'name' is the
83 * return of setlocale(), then this is extremely likely to be the C or POSIX
84 * locale. However, the output of setlocale() is documented to be opaque, but
85 * the odds are extremely small that it would return these two strings for some
86 * other locale. Note that VMS in these two locales includes many non-ASCII
87 * characters as controls and punctuation (below are hex bytes):
88 * cntrl: 84-97 9B-9F
89 * punct: A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
90 * Oddly, none there are listed as alphas, though some represent alphabetics
91 * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
92#define isNAME_C_OR_POSIX(name) \
93 ( (name) != NULL \
94 && (( *(name) == 'C' && (*(name + 1)) == '\0') \
95 || strEQ((name), "POSIX")))
96
8ef6e574
KW		 97#ifdef USE_LOCALE
98
47280b20
KW		 99/* This code keeps a LRU cache of the UTF-8ness of the locales it has so-far
100 * looked up. This is in the form of a C string: */
101
102#define UTF8NESS_SEP "\v"
103#define UTF8NESS_PREFIX "\f"
104
105/* So, the string looks like:
98994639 106 *
47280b20 107 * \vC\a0\vPOSIX\a0\vam_ET\a0\vaf_ZA.utf8\a1\ven_US.UTF-8\a1\0
98994639 108 *
47280b20
KW		 109 * where the digit 0 after the \a indicates that the locale starting just
110 * after the preceding \v is not UTF-8, and the digit 1 mean it is. */
111
112STATIC_ASSERT_DECL(STRLENs(UTF8NESS_SEP) == 1);
113STATIC_ASSERT_DECL(STRLENs(UTF8NESS_PREFIX) == 1);
114
115#define C_and_POSIX_utf8ness UTF8NESS_SEP "C" UTF8NESS_PREFIX "0" \
116 UTF8NESS_SEP "POSIX" UTF8NESS_PREFIX "0"
117
118/* The cache is initialized to C_and_POSIX_utf8ness at start up. These are
119 * kept there always. The remining portion of the cache is LRU, with the
120 * oldest looked-up locale at the tail end */
121
98994639
HS		 122STATIC char *
123S_stdize_locale(pTHX_ char *locs)
124{
47280b20
KW		 125 /* Standardize the locale name from a string returned by 'setlocale',
126 * possibly modifying that string.
127 *
128 * The typical return value of setlocale() is either
129 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
130 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
131 * (the space-separated values represent the various sublocales,
132 * in some unspecified order). This is not handled by this function.
133 *
134 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
135 * which is harmful for further use of the string in setlocale(). This
136 * function removes the trailing new line and everything up through the '='
137 * */
138
7452cf6a 139 const char * const s = strchr(locs, '=');
98994639
HS		 140 bool okay = TRUE;
141
7918f24d
NC		 142 PERL_ARGS_ASSERT_STDIZE_LOCALE;
143
8772537c
AL		 144 if (s) {
145 const char * const t = strchr(s, '.');
98994639 146 okay = FALSE;
8772537c
AL		 147 if (t) {
148 const char * const u = strchr(t, '\n');
149 if (u && (u[1] == 0)) {
150 const STRLEN len = u - s;
151 Move(s + 1, locs, len, char);
152 locs[len] = 0;
153 okay = TRUE;
98994639
HS		 154 }
155 }
156 }
157
158 if (!okay)
159 Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
160
161 return locs;
162}
163
e5f10d49
KW		 164/* Two parallel arrays; first the locale categories Perl uses on this system;
165 * the second array is their names. These arrays are in mostly arbitrary
166 * order. */
167
168const int categories[] = {
169
170# ifdef USE_LOCALE_NUMERIC
171 LC_NUMERIC,
172# endif
173# ifdef USE_LOCALE_CTYPE
174 LC_CTYPE,
175# endif
176# ifdef USE_LOCALE_COLLATE
177 LC_COLLATE,
178# endif
179# ifdef USE_LOCALE_TIME
180 LC_TIME,
181# endif
182# ifdef USE_LOCALE_MESSAGES
183 LC_MESSAGES,
184# endif
185# ifdef USE_LOCALE_MONETARY
186 LC_MONETARY,
187# endif
9821811f
KW		 188# ifdef USE_LOCALE_ADDRESS
189 LC_ADDRESS,
190# endif
191# ifdef USE_LOCALE_IDENTIFICATION
192 LC_IDENTIFICATION,
193# endif
194# ifdef USE_LOCALE_MEASUREMENT
195 LC_MEASUREMENT,
196# endif
197# ifdef USE_LOCALE_PAPER
198 LC_PAPER,
199# endif
200# ifdef USE_LOCALE_TELEPHONE
201 LC_TELEPHONE,
202# endif
36dbc955
KW		 203# ifdef USE_LOCALE_SYNTAX
204 LC_SYNTAX,
205# endif
206# ifdef USE_LOCALE_TOD
207 LC_TOD,
208# endif
e5f10d49
KW		 209# ifdef LC_ALL
210 LC_ALL,
211# endif
212 -1 /* Placeholder because C doesn't allow a
213 trailing comma, and it would get complicated
214 with all the #ifdef's */
215};
216
217/* The top-most real element is LC_ALL */
218
4ef8bdf9 219const char * const category_names[] = {
e5f10d49
KW		 220
221# ifdef USE_LOCALE_NUMERIC
222 "LC_NUMERIC",
223# endif
224# ifdef USE_LOCALE_CTYPE
225 "LC_CTYPE",
226# endif
227# ifdef USE_LOCALE_COLLATE
228 "LC_COLLATE",
229# endif
230# ifdef USE_LOCALE_TIME
231 "LC_TIME",
232# endif
233# ifdef USE_LOCALE_MESSAGES
234 "LC_MESSAGES",
235# endif
236# ifdef USE_LOCALE_MONETARY
237 "LC_MONETARY",
238# endif
9821811f
KW		 239# ifdef USE_LOCALE_ADDRESS
240 "LC_ADDRESS",
241# endif
242# ifdef USE_LOCALE_IDENTIFICATION
243 "LC_IDENTIFICATION",
244# endif
245# ifdef USE_LOCALE_MEASUREMENT
246 "LC_MEASUREMENT",
247# endif
248# ifdef USE_LOCALE_PAPER
249 "LC_PAPER",
250# endif
251# ifdef USE_LOCALE_TELEPHONE
252 "LC_TELEPHONE",
253# endif
36dbc955
KW		 254# ifdef USE_LOCALE_SYNTAX
255 "LC_SYNTAX",
256# endif
257# ifdef USE_LOCALE_TOD
258 "LC_TOD",
259# endif
e5f10d49
KW		 260# ifdef LC_ALL
261 "LC_ALL",
262# endif
263 NULL /* Placeholder */
264 };
265
266# ifdef LC_ALL
267
268 /* On systems with LC_ALL, it is kept in the highest index position. (-2
269 * to account for the final unused placeholder element.) */
270# define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 2)
271
272# else
273
274 /* On systems without LC_ALL, we pretend it is there, one beyond the real
275 * top element, hence in the unused placeholder element. */
276# define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 1)
277
278# endif
279
280/* Pretending there is an LC_ALL element just above allows us to avoid most
281 * special cases. Most loops through these arrays in the code below are
282 * written like 'for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)'. They will work
283 * on either type of system. But the code must be written to not access the
948523db
KW		 284 * element at 'LC_ALL_INDEX' except on platforms that have it. This can be
285 * checked for at compile time by using the #define LC_ALL_INDEX which is only
286 * defined if we do have LC_ALL. */
e5f10d49 287
b09aaf40
KW		 288STATIC const char *
289S_category_name(const int category)
290{
291 unsigned int i;
292
293#ifdef LC_ALL
294
295 if (category == LC_ALL) {
296 return "LC_ALL";
297 }
298
299#endif
300
301 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
302 if (category == categories[i]) {
303 return category_names[i];
304 }
305 }
306
307 {
308 const char suffix[] = " (unknown)";
309 int temp = category;
310 Size_t length = sizeof(suffix) + 1;
311 char * unknown;
312 dTHX;
313
314 if (temp < 0) {
315 length++;
316 temp = - temp;
317 }
318
319 /* Calculate the number of digits */
320 while (temp >= 10) {
321 temp /= 10;
322 length++;
323 }
324
325 Newx(unknown, length, char);
326 my_snprintf(unknown, length, "%d%s", category, suffix);
327 SAVEFREEPV(unknown);
328 return unknown;
329 }
330}
331
948523db
KW		 332/* Now create LC_foo_INDEX #defines for just those categories on this system */
333# ifdef USE_LOCALE_NUMERIC
334# define LC_NUMERIC_INDEX 0
335# define _DUMMY_NUMERIC LC_NUMERIC_INDEX
336# else
337# define _DUMMY_NUMERIC -1
338# endif
339# ifdef USE_LOCALE_CTYPE
340# define LC_CTYPE_INDEX _DUMMY_NUMERIC + 1
341# define _DUMMY_CTYPE LC_CTYPE_INDEX
342# else
343# define _DUMMY_CTYPE _DUMMY_NUMERIC
344# endif
345# ifdef USE_LOCALE_COLLATE
346# define LC_COLLATE_INDEX _DUMMY_CTYPE + 1
347# define _DUMMY_COLLATE LC_COLLATE_INDEX
348# else
8203b3c3 349# define _DUMMY_COLLATE _DUMMY_CTYPE
948523db
KW		 350# endif
351# ifdef USE_LOCALE_TIME
352# define LC_TIME_INDEX _DUMMY_COLLATE + 1
353# define _DUMMY_TIME LC_TIME_INDEX
354# else
355# define _DUMMY_TIME _DUMMY_COLLATE
356# endif
357# ifdef USE_LOCALE_MESSAGES
358# define LC_MESSAGES_INDEX _DUMMY_TIME + 1
359# define _DUMMY_MESSAGES LC_MESSAGES_INDEX
360# else
361# define _DUMMY_MESSAGES _DUMMY_TIME
362# endif
363# ifdef USE_LOCALE_MONETARY
364# define LC_MONETARY_INDEX _DUMMY_MESSAGES + 1
365# define _DUMMY_MONETARY LC_MONETARY_INDEX
366# else
367# define _DUMMY_MONETARY _DUMMY_MESSAGES
368# endif
9821811f
KW		 369# ifdef USE_LOCALE_ADDRESS
370# define LC_ADDRESS_INDEX _DUMMY_MONETARY + 1
371# define _DUMMY_ADDRESS LC_ADDRESS_INDEX
372# else
373# define _DUMMY_ADDRESS _DUMMY_MONETARY
374# endif
375# ifdef USE_LOCALE_IDENTIFICATION
376# define LC_IDENTIFICATION_INDEX _DUMMY_ADDRESS + 1
377# define _DUMMY_IDENTIFICATION LC_IDENTIFICATION_INDEX
378# else
379# define _DUMMY_IDENTIFICATION _DUMMY_ADDRESS
380# endif
381# ifdef USE_LOCALE_MEASUREMENT
382# define LC_MEASUREMENT_INDEX _DUMMY_IDENTIFICATION + 1
383# define _DUMMY_MEASUREMENT LC_MEASUREMENT_INDEX
384# else
385# define _DUMMY_MEASUREMENT _DUMMY_IDENTIFICATION
386# endif
387# ifdef USE_LOCALE_PAPER
388# define LC_PAPER_INDEX _DUMMY_MEASUREMENT + 1
389# define _DUMMY_PAPER LC_PAPER_INDEX
390# else
391# define _DUMMY_PAPER _DUMMY_MEASUREMENT
392# endif
393# ifdef USE_LOCALE_TELEPHONE
394# define LC_TELEPHONE_INDEX _DUMMY_PAPER + 1
395# define _DUMMY_TELEPHONE LC_TELEPHONE_INDEX
396# else
397# define _DUMMY_TELEPHONE _DUMMY_PAPER
398# endif
36dbc955
KW		 399# ifdef USE_LOCALE_SYNTAX
400# define LC_SYNTAX_INDEX _DUMMY_TELEPHONE + 1
401# define _DUMMY_SYNTAX LC_SYNTAX_INDEX
402# else
403# define _DUMMY_SYNTAX _DUMMY_TELEPHONE
404# endif
405# ifdef USE_LOCALE_TOD
406# define LC_TOD_INDEX _DUMMY_SYNTAX + 1
407# define _DUMMY_TOD LC_TOD_INDEX
408# else
409# define _DUMMY_TOD _DUMMY_SYNTAX
410# endif
948523db 411# ifdef LC_ALL
36dbc955 412# define LC_ALL_INDEX _DUMMY_TOD + 1
948523db
KW		 413# endif
414#endif /* ifdef USE_LOCALE */
8ef6e574 415
d2b24094 416/* Windows requres a customized base-level setlocale() */
e9bc6d6b
KW		 417#ifdef WIN32
418# define my_setlocale(cat, locale) win32_setlocale(cat, locale)
419#else
420# define my_setlocale(cat, locale) setlocale(cat, locale)
421#endif
422
423#ifndef USE_POSIX_2008_LOCALE
424
425/* "do_setlocale_c" is intended to be called when the category is a constant
426 * known at compile time; "do_setlocale_r", not known until run time */
427# define do_setlocale_c(cat, locale) my_setlocale(cat, locale)
428# define do_setlocale_r(cat, locale) my_setlocale(cat, locale)
45cef8fb 429# define FIX_GLIBC_LC_MESSAGES_BUG(i)
e9bc6d6b
KW		 430
431#else /* Below uses POSIX 2008 */
432
433/* We emulate setlocale with our own function. LC_foo is not valid for the
434 * POSIX 2008 functions. Instead LC_foo_MASK is used, which we use an array
435 * lookup to convert to. At compile time we have defined LC_foo_INDEX as the
436 * proper offset into the array 'category_masks[]'. At runtime, we have to
437 * search through the array (as the actual numbers may not be small contiguous
438 * positive integers which would lend themselves to array lookup). */
439# define do_setlocale_c(cat, locale) \
440 emulate_setlocale(cat, locale, cat ## _INDEX, TRUE)
441# define do_setlocale_r(cat, locale) emulate_setlocale(cat, locale, 0, FALSE)
442
45cef8fb
KW		 443# if ! defined(__GLIBC__) || ! defined(USE_LOCALE_MESSAGES)
444
445# define FIX_GLIBC_LC_MESSAGES_BUG(i)
446
447# else /* Invalidate glibc cache of loaded translations, see [perl #134264] */
448
449# include <libintl.h>
450# define FIX_GLIBC_LC_MESSAGES_BUG(i) \
451 STMT_START { \
452 if ((i) == LC_MESSAGES_INDEX) { \
453 textdomain(textdomain(NULL)); \
454 } \
455 } STMT_END
456
457# endif
458
e9bc6d6b
KW		 459/* A third array, parallel to the ones above to map from category to its
460 * equivalent mask */
461const int category_masks[] = {
462# ifdef USE_LOCALE_NUMERIC
463 LC_NUMERIC_MASK,
464# endif
465# ifdef USE_LOCALE_CTYPE
466 LC_CTYPE_MASK,
467# endif
468# ifdef USE_LOCALE_COLLATE
469 LC_COLLATE_MASK,
470# endif
471# ifdef USE_LOCALE_TIME
472 LC_TIME_MASK,
473# endif
474# ifdef USE_LOCALE_MESSAGES
475 LC_MESSAGES_MASK,
476# endif
477# ifdef USE_LOCALE_MONETARY
478 LC_MONETARY_MASK,
479# endif
480# ifdef USE_LOCALE_ADDRESS
481 LC_ADDRESS_MASK,
482# endif
483# ifdef USE_LOCALE_IDENTIFICATION
484 LC_IDENTIFICATION_MASK,
485# endif
486# ifdef USE_LOCALE_MEASUREMENT
487 LC_MEASUREMENT_MASK,
488# endif
489# ifdef USE_LOCALE_PAPER
490 LC_PAPER_MASK,
491# endif
492# ifdef USE_LOCALE_TELEPHONE
493 LC_TELEPHONE_MASK,
494# endif
36dbc955
KW		 495# ifdef USE_LOCALE_SYNTAX
496 LC_SYNTAX_MASK,
497# endif
498# ifdef USE_LOCALE_TOD
499 LC_TOD_MASK,
500# endif
e9bc6d6b
KW		 501 /* LC_ALL can't be turned off by a Configure
502 * option, and in Posix 2008, should always be
503 * here, so compile it in unconditionally.
504 * This could catch some glitches at compile
505 * time */
506 LC_ALL_MASK
507 };
508
509STATIC const char *
510S_emulate_setlocale(const int category,
511 const char * locale,
512 unsigned int index,
513 const bool is_index_valid
514 )
515{
516 /* This function effectively performs a setlocale() on just the current
517 * thread; thus it is thread-safe. It does this by using the POSIX 2008
518 * locale functions to emulate the behavior of setlocale(). Similar to
519 * regular setlocale(), the return from this function points to memory that
520 * can be overwritten by other system calls, so needs to be copied
521 * immediately if you need to retain it. The difference here is that
522 * system calls besides another setlocale() can overwrite it.
523 *
524 * By doing this, most locale-sensitive functions become thread-safe. The
525 * exceptions are mostly those that return a pointer to static memory.
526 *
527 * This function takes the same parameters, 'category' and 'locale', that
528 * the regular setlocale() function does, but it also takes two additional
529 * ones. This is because the 2008 functions don't use a category; instead
530 * they use a corresponding mask. Because this function operates in both
531 * worlds, it may need one or the other or both. This function can
532 * calculate the mask from the input category, but to avoid this
533 * calculation, if the caller knows at compile time what the mask is, it
534 * can pass it, setting 'is_index_valid' to TRUE; otherwise the mask
535 * parameter is ignored.
536 *
537 * POSIX 2008, for some sick reason, chose not to provide a method to find
538 * the category name of a locale. Some vendors have created a
539 * querylocale() function to do just that. This function is a lot simpler
540 * to implement on systems that have this. Otherwise, we have to keep
541 * track of what the locale has been set to, so that we can return its
542 * name to emulate setlocale(). It's also possible for C code in some
543 * library to change the locale without us knowing it, though as of
544 * September 2017, there are no occurrences in CPAN of uselocale(). Some
545 * libraries do use setlocale(), but that changes the global locale, and
546 * threads using per-thread locales will just ignore those changes.
547 * Another problem is that without querylocale(), we have to guess at what
548 * was meant by setting a locale of "". We handle this by not actually
549 * ever setting to "" (unless querylocale exists), but to emulate what we
550 * think should happen for "".
551 */
552
553 int mask;
554 locale_t old_obj;
555 locale_t new_obj;
556 dTHX;
557
558# ifdef DEBUGGING
559
560 if (DEBUG_Lv_TEST || debug_initialization) {
561 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale input=%d (%s), \"%s\", %d, %d\n", __FILE__, __LINE__, category, category_name(category), locale, index, is_index_valid);
562 }
563
564# endif
565
566 /* If the input mask might be incorrect, calculate the correct one */
567 if (! is_index_valid) {
568 unsigned int i;
569
570# ifdef DEBUGGING
571
572 if (DEBUG_Lv_TEST || debug_initialization) {
573 PerlIO_printf(Perl_debug_log, "%s:%d: finding index of category %d (%s)\n", __FILE__, __LINE__, category, category_name(category));
574 }
575
576# endif
577
578 for (i = 0; i <= LC_ALL_INDEX; i++) {
579 if (category == categories[i]) {
580 index = i;
581 goto found_index;
582 }
583 }
584
585 /* Here, we don't know about this category, so can't handle it.
586 * Fallback to the early POSIX usages */
587 Perl_warner(aTHX_ packWARN(WARN_LOCALE),
588 "Unknown locale category %d; can't set it to %s\n",
589 category, locale);
590 return NULL;
591
592 found_index: ;
593
594# ifdef DEBUGGING
595
596 if (DEBUG_Lv_TEST || debug_initialization) {
597 PerlIO_printf(Perl_debug_log, "%s:%d: index is %d for %s\n", __FILE__, __LINE__, index, category_name(category));
598 }
599
600# endif
601
602 }
603
604 mask = category_masks[index];
605
606# ifdef DEBUGGING
607
608 if (DEBUG_Lv_TEST || debug_initialization) {
609 PerlIO_printf(Perl_debug_log, "%s:%d: category name is %s; mask is 0x%x\n", __FILE__, __LINE__, category_names[index], mask);
610 }
611
612# endif
613
614 /* If just querying what the existing locale is ... */
615 if (locale == NULL) {
616 locale_t cur_obj = uselocale((locale_t) 0);
617
618# ifdef DEBUGGING
619
620 if (DEBUG_Lv_TEST || debug_initialization) {
621 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale querying %p\n", __FILE__, __LINE__, cur_obj);
622 }
623
624# endif
625
626 if (cur_obj == LC_GLOBAL_LOCALE) {
627 return my_setlocale(category, NULL);
628 }
629
630# ifdef HAS_QUERYLOCALE
631
632 return (char *) querylocale(mask, cur_obj);
633
d2b24094 634# else
ecdda939
KW		 635
636 /* If this assert fails, adjust the size of curlocales in intrpvar.h */
637 STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX);
638
8e13243a
KW		 639# if defined(_NL_LOCALE_NAME) \
640 && defined(DEBUGGING) \
641 && ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME)
642 /* On systems that accept any locale name, the real underlying locale
643 * is often returned by this internal function, so we can't use it */
e9bc6d6b
KW		 644 {
645 /* Internal glibc for querylocale(), but doesn't handle
646 * empty-string ("") locale properly; who knows what other
3a732259 647 * glitches. Check for it now, under debug. */
e9bc6d6b
KW		 648
649 char * temp_name = nl_langinfo_l(_NL_LOCALE_NAME(category),
650 uselocale((locale_t) 0));
651 /*
652 PerlIO_printf(Perl_debug_log, "%s:%d: temp_name=%s\n", __FILE__, __LINE__, temp_name ? temp_name : "NULL");
653 PerlIO_printf(Perl_debug_log, "%s:%d: index=%d\n", __FILE__, __LINE__, index);
654 PerlIO_printf(Perl_debug_log, "%s:%d: PL_curlocales[index]=%s\n", __FILE__, __LINE__, PL_curlocales[index]);
655 */
656 if (temp_name && PL_curlocales[index] && strNE(temp_name, "")) {
657 if ( strNE(PL_curlocales[index], temp_name)
658 && ! ( isNAME_C_OR_POSIX(temp_name)
659 && isNAME_C_OR_POSIX(PL_curlocales[index]))) {
660
661# ifdef USE_C_BACKTRACE
662
663 dump_c_backtrace(Perl_debug_log, 20, 1);
664
665# endif
666
667 Perl_croak(aTHX_ "panic: Mismatch between what Perl thinks %s is"
668 " (%s) and what internal glibc thinks"
669 " (%s)\n", category_names[index],
670 PL_curlocales[index], temp_name);
671 }
672
673 return temp_name;
674 }
675 }
676
677# endif
678
679 /* Without querylocale(), we have to use our record-keeping we've
680 * done. */
681
682 if (category != LC_ALL) {
683
684# ifdef DEBUGGING
685
686 if (DEBUG_Lv_TEST || debug_initialization) {
687 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[index]);
688 }
689
690# endif
691
692 return PL_curlocales[index];
693 }
694 else { /* For LC_ALL */
695 unsigned int i;
696 Size_t names_len = 0;
697 char * all_string;
7c93a471 698 bool are_all_categories_the_same_locale = TRUE;
e9bc6d6b
KW		 699
700 /* If we have a valid LC_ALL value, just return it */
701 if (PL_curlocales[LC_ALL_INDEX]) {
702
703# ifdef DEBUGGING
704
705 if (DEBUG_Lv_TEST || debug_initialization) {
706 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[LC_ALL_INDEX]);
707 }
708
709# endif
710
711 return PL_curlocales[LC_ALL_INDEX];
712 }
713
714 /* Otherwise, we need to construct a string of name=value pairs.
715 * We use the glibc syntax, like
716 * LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
7c93a471
KW		 717 * First calculate the needed size. Along the way, check if all
718 * the locale names are the same */
e9bc6d6b
KW		 719 for (i = 0; i < LC_ALL_INDEX; i++) {
720
721# ifdef DEBUGGING
722
723 if (DEBUG_Lv_TEST || debug_initialization) {
724 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
725 }
726
727# endif
728
729 names_len += strlen(category_names[i])
730 + 1 /* '=' */
731 + strlen(PL_curlocales[i])
732 + 1; /* ';' */
7c93a471
KW		 733
734 if (i > 0 && strNE(PL_curlocales[i], PL_curlocales[i-1])) {
735 are_all_categories_the_same_locale = FALSE;
736 }
737 }
738
739 /* If they are the same, we don't actually have to construct the
740 * string; we just make the entry in LC_ALL_INDEX valid, and be
741 * that single name */
742 if (are_all_categories_the_same_locale) {
743 PL_curlocales[LC_ALL_INDEX] = savepv(PL_curlocales[0]);
744 return PL_curlocales[LC_ALL_INDEX];
e9bc6d6b 745 }
7c93a471 746
e9bc6d6b
KW		 747 names_len++; /* Trailing '\0' */
748 SAVEFREEPV(Newx(all_string, names_len, char));
749 *all_string = '\0';
750
751 /* Then fill in the string */
752 for (i = 0; i < LC_ALL_INDEX; i++) {
753
754# ifdef DEBUGGING
755
756 if (DEBUG_Lv_TEST || debug_initialization) {
757 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
758 }
759
760# endif
761
762 my_strlcat(all_string, category_names[i], names_len);
763 my_strlcat(all_string, "=", names_len);
764 my_strlcat(all_string, PL_curlocales[i], names_len);
765 my_strlcat(all_string, ";", names_len);
766 }
767
768# ifdef DEBUGGING
769
770 if (DEBUG_L_TEST || debug_initialization) {
771 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, all_string);
772 }
773
774 #endif
775
776 return all_string;
777 }
778
779# ifdef EINVAL
780
781 SETERRNO(EINVAL, LIB_INVARG);
782
783# endif
784
785 return NULL;
786
d2b24094
KW		 787# endif
788
6aba5c5e 789 } /* End of this being setlocale(LC_foo, NULL) */
e9bc6d6b 790
f8115d60 791 /* Here, we are switching locales. */
e9bc6d6b
KW		 792
793# ifndef HAS_QUERYLOCALE
794
795 if (strEQ(locale, "")) {
796
797 /* For non-querylocale() systems, we do the setting of "" ourselves to
798 * be sure that we really know what's going on. We follow the Linux
799 * documented behavior (but if that differs from the actual behavior,
800 * this won't work exactly as the OS implements). We go out and
801 * examine the environment based on our understanding of how the system
802 * works, and use that to figure things out */
803
804 const char * const lc_all = PerlEnv_getenv("LC_ALL");
805
806 /* Use any "LC_ALL" environment variable, as it overrides everything
807 * else. */
808 if (lc_all && strNE(lc_all, "")) {
809 locale = lc_all;
810 }
811 else {
812
813 /* Otherwise, we need to dig deeper. Unless overridden, the
814 * default is the LANG environment variable; if it doesn't exist,
815 * then "C" */
816
817 const char * default_name;
818
207cc8df 819 default_name = PerlEnv_getenv("LANG");
e9bc6d6b
KW		 820
821 if (! default_name || strEQ(default_name, "")) {
929a7f8c 822 default_name = "C";
e9bc6d6b 823 }
e9bc6d6b
KW		 824
825 if (category != LC_ALL) {
826 const char * const name = PerlEnv_getenv(category_names[index]);
827
828 /* Here we are setting a single category. Assume will have the
829 * default name */
830 locale = default_name;
831
832 /* But then look for an overriding environment variable */
833 if (name && strNE(name, "")) {
834 locale = name;
835 }
836 }
837 else {
838 bool did_override = FALSE;
839 unsigned int i;
840
841 /* Here, we are getting LC_ALL. Any categories that don't have
842 * a corresponding environment variable set should be set to
843 * LANG, or to "C" if there is no LANG. If no individual
844 * categories differ from this, we can just set LC_ALL. This
845 * is buggy on systems that have extra categories that we don't
846 * know about. If there is an environment variable that sets
847 * that category, we won't know to look for it, and so our use
848 * of LANG or "C" improperly overrides it. On the other hand,
849 * if we don't do what is done here, and there is no
850 * environment variable, the category's locale should be set to
851 * LANG or "C". So there is no good solution. khw thinks the
852 * best is to look at systems to see what categories they have,
853 * and include them, and then to assume that we know the
854 * complete set */
855
856 for (i = 0; i < LC_ALL_INDEX; i++) {
857 const char * const env_override
24f3e849 858 = PerlEnv_getenv(category_names[i]);
e9bc6d6b
KW		 859 const char * this_locale = ( env_override
860 && strNE(env_override, ""))
861 ? env_override
862 : default_name;
6435f98d
KW		 863 if (! emulate_setlocale(categories[i], this_locale, i, TRUE))
864 {
6435f98d
KW		 865 return NULL;
866 }
e9bc6d6b
KW		 867
868 if (strNE(this_locale, default_name)) {
869 did_override = TRUE;
870 }
e9bc6d6b
KW		 871 }
872
873 /* If all the categories are the same, we can set LC_ALL to
874 * that */
875 if (! did_override) {
876 locale = default_name;
877 }
878 else {
879
880 /* Here, LC_ALL is no longer valid, as some individual
881 * categories don't match it. We call ourselves
882 * recursively, as that will execute the code that
883 * generates the proper locale string for this situation.
884 * We don't do the remainder of this function, as that is
885 * to update our records, and we've just done that for the
886 * individual categories in the loop above, and doing so
887 * would cause LC_ALL to be done as well */
888 return emulate_setlocale(LC_ALL, NULL, LC_ALL_INDEX, TRUE);
889 }
890 }
891 }
6aba5c5e 892 } /* End of this being setlocale(LC_foo, "") */
e9bc6d6b
KW		 893 else if (strchr(locale, ';')) {
894
895 /* LC_ALL may actually incude a conglomeration of various categories.
896 * Without querylocale, this code uses the glibc (as of this writing)
897 * syntax for representing that, but that is not a stable API, and
898 * other platforms do it differently, so we have to handle all cases
899 * ourselves */
900
f0023d47 901 unsigned int i;
e9bc6d6b
KW		 902 const char * s = locale;
903 const char * e = locale + strlen(locale);
904 const char * p = s;
905 const char * category_end;
906 const char * name_start;
907 const char * name_end;
908
f0023d47
KW		 909 /* If the string that gives what to set doesn't include all categories,
910 * the omitted ones get set to "C". To get this behavior, first set
911 * all the individual categories to "C", and override the furnished
912 * ones below */
913 for (i = 0; i < LC_ALL_INDEX; i++) {
914 if (! emulate_setlocale(categories[i], "C", i, TRUE)) {
915 return NULL;
916 }
917 }
918
e9bc6d6b 919 while (s < e) {
e9bc6d6b
KW		 920
921 /* Parse through the category */
922 while (isWORDCHAR(*p)) {
923 p++;
924 }
925 category_end = p;
926
927 if (*p++ != '=') {
928 Perl_croak(aTHX_
929 "panic: %s: %d: Unexpected character in locale name '%02X",
930 __FILE__, __LINE__, *(p-1));
931 }
932
933 /* Parse through the locale name */
934 name_start = p;
bee74f4b
KW		 935 while (p < e && *p != ';') {
936 if (! isGRAPH(*p)) {
937 Perl_croak(aTHX_
938 "panic: %s: %d: Unexpected character in locale name '%02X",
939 __FILE__, __LINE__, *(p-1));
940 }
e9bc6d6b
KW		 941 p++;
942 }
943 name_end = p;
944
bee74f4b
KW		 945 /* Space past the semi-colon */
946 if (p < e) {
947 p++;
e9bc6d6b
KW		 948 }
949
950 /* Find the index of the category name in our lists */
951 for (i = 0; i < LC_ALL_INDEX; i++) {
3c76a412 952 char * individ_locale;
e9bc6d6b
KW		 953
954 /* Keep going if this isn't the index. The strnNE() avoids a
955 * Perl_form(), but would fail if ever a category name could be
956 * a substring of another one, like if there were a
957 * "LC_TIME_DATE" */
958 if strnNE(s, category_names[i], category_end - s) {
959 continue;
960 }
961
962 /* If this index is for the single category we're changing, we
963 * have found the locale to set it to. */
964 if (category == categories[i]) {
965 locale = Perl_form(aTHX_ "%.*s",
966 (int) (name_end - name_start),
967 name_start);
968 goto ready_to_set;
969 }
970
3c76a412 971 assert(category == LC_ALL);
bee74f4b
KW		 972 individ_locale = Perl_form(aTHX_ "%.*s",
973 (int) (name_end - name_start), name_start);
6435f98d
KW		 974 if (! emulate_setlocale(categories[i], individ_locale, i, TRUE))
975 {
976 return NULL;
977 }
e9bc6d6b
KW		 978 }
979
980 s = p;
981 }
982
983 /* Here we have set all the individual categories by recursive calls.
984 * These collectively should have fixed up LC_ALL, so can just query
985 * what that now is */
986 assert(category == LC_ALL);
987
988 return do_setlocale_c(LC_ALL, NULL);
6aba5c5e
KW		 989 } /* End of this being setlocale(LC_ALL,
990 "LC_CTYPE=foo;LC_NUMERIC=bar;...") */
e9bc6d6b
KW		 991
992 ready_to_set: ;
993
f8115d60
KW		 994 /* Here at the end of having to deal with the absence of querylocale().
995 * Some cases have already been fully handled by recursive calls to this
996 * function. But at this point, we haven't dealt with those, but are now
997 * prepared to, knowing what the locale name to set this category to is.
998 * This would have come for free if this system had had querylocale() */
999
e9bc6d6b
KW		 1000# endif /* end of ! querylocale */
1001
f8115d60
KW		 1002 assert(PL_C_locale_obj);
1003
1004 /* Switching locales generally entails freeing the current one's space (at
1005 * the C library's discretion). We need to stop using that locale before
1006 * the switch. So switch to a known locale object that we don't otherwise
1007 * mess with. This returns the locale object in effect at the time of the
1008 * switch. */
1009 old_obj = uselocale(PL_C_locale_obj);
1010
1011# ifdef DEBUGGING
1012
1013 if (DEBUG_Lv_TEST || debug_initialization) {
1014 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
1015 }
1016
1017# endif
1018
1019 if (! old_obj) {
1020
1021# ifdef DEBUGGING
1022
1023 if (DEBUG_L_TEST || debug_initialization) {
1024 dSAVE_ERRNO;
1025 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to C failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
1026 RESTORE_ERRNO;
1027 }
1028
1029# endif
1030
1031 return NULL;
1032 }
1033
1034# ifdef DEBUGGING
1035
1036 if (DEBUG_Lv_TEST || debug_initialization) {
b22e9937
KW		 1037 PerlIO_printf(Perl_debug_log,
1038 "%s:%d: emulate_setlocale now using %p\n",
1039 __FILE__, __LINE__, PL_C_locale_obj);
f8115d60
KW		 1040 }
1041
1042# endif
1043
6aba5c5e
KW		 1044 /* If this call is to switch to the LC_ALL C locale, it already exists, and
1045 * in fact, we already have switched to it (in preparation for what
1046 * normally is to come). But since we're already there, continue to use
70bd6bc8
KW		 1047 * it instead of trying to create a new locale */
1048 if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(locale)) {
1049
1050# ifdef DEBUGGING
1051
1052 if (DEBUG_Lv_TEST || debug_initialization) {
1053 PerlIO_printf(Perl_debug_log,
1054 "%s:%d: will stay in C object\n", __FILE__, __LINE__);
1055 }
1056
1057# endif
1058
1059 new_obj = PL_C_locale_obj;
1060
1061 /* We already had switched to the C locale in preparation for freeing
b22e9937 1062 * 'old_obj' */
70bd6bc8
KW		 1063 if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) {
1064 freelocale(old_obj);
1065 }
1066 }
1067 else {
b22e9937
KW		 1068 /* If we weren't in a thread safe locale, set so that newlocale() below
1069 * which uses 'old_obj', uses an empty one. Same for our reserved C
1070 * object. The latter is defensive coding, so that, even if there is
1071 * some bug, we will never end up trying to modify either of these, as
1072 * if passed to newlocale(), they can be. */
1073 if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
1074 old_obj = (locale_t) 0;
1075 }
f8115d60 1076
b22e9937
KW		 1077 /* Ready to create a new locale by modification of the exising one */
1078 new_obj = newlocale(mask, locale, old_obj);
e9bc6d6b 1079
b22e9937
KW		 1080 if (! new_obj) {
1081 dSAVE_ERRNO;
e9bc6d6b
KW		 1082
1083# ifdef DEBUGGING
1084
b22e9937
KW		 1085 if (DEBUG_L_TEST || debug_initialization) {
1086 PerlIO_printf(Perl_debug_log,
1087 "%s:%d: emulate_setlocale creating new object"
1088 " failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
1089 }
e9bc6d6b
KW		 1090
1091# endif
1092
b22e9937 1093 if (! uselocale(old_obj)) {
e9bc6d6b
KW		 1094
1095# ifdef DEBUGGING
1096
b22e9937
KW		 1097 if (DEBUG_L_TEST || debug_initialization) {
1098 PerlIO_printf(Perl_debug_log,
1099 "%s:%d: switching back failed: %d\n",
1100 __FILE__, __LINE__, GET_ERRNO);
1101 }
e9bc6d6b
KW		 1102
1103# endif
1104
b22e9937
KW		 1105 }
1106 RESTORE_ERRNO;
1107 return NULL;
e9bc6d6b 1108 }
e9bc6d6b
KW		 1109
1110# ifdef DEBUGGING
1111
b22e9937
KW		 1112 if (DEBUG_Lv_TEST || debug_initialization) {
1113 PerlIO_printf(Perl_debug_log,
1114 "%s:%d: emulate_setlocale created %p",
1115 __FILE__, __LINE__, new_obj);
1116 if (old_obj) {
1117 PerlIO_printf(Perl_debug_log,
1118 "; should have freed %p", old_obj);
1119 }
1120 PerlIO_printf(Perl_debug_log, "\n");
19ee3daf 1121 }
e9bc6d6b
KW		 1122
1123# endif
1124
b22e9937
KW		 1125 /* And switch into it */
1126 if (! uselocale(new_obj)) {
1127 dSAVE_ERRNO;
e9bc6d6b
KW		 1128
1129# ifdef DEBUGGING
1130
b22e9937
KW		 1131 if (DEBUG_L_TEST || debug_initialization) {
1132 PerlIO_printf(Perl_debug_log,
1133 "%s:%d: emulate_setlocale switching to new object"
1134 " failed\n", __FILE__, __LINE__);
1135 }
e9bc6d6b
KW		 1136
1137# endif
1138
b22e9937 1139 if (! uselocale(old_obj)) {
e9bc6d6b
KW		 1140
1141# ifdef DEBUGGING
1142
b22e9937
KW		 1143 if (DEBUG_L_TEST || debug_initialization) {
1144 PerlIO_printf(Perl_debug_log,
1145 "%s:%d: switching back failed: %d\n",
1146 __FILE__, __LINE__, GET_ERRNO);
1147 }
e9bc6d6b
KW		 1148
1149# endif
1150
b22e9937
KW		 1151 }
1152 freelocale(new_obj);
1153 RESTORE_ERRNO;
1154 return NULL;
e9bc6d6b 1155 }
70bd6bc8 1156 }
e9bc6d6b
KW		 1157
1158# ifdef DEBUGGING
1159
1160 if (DEBUG_Lv_TEST || debug_initialization) {
b22e9937
KW		 1161 PerlIO_printf(Perl_debug_log,
1162 "%s:%d: emulate_setlocale now using %p\n",
1163 __FILE__, __LINE__, new_obj);
e9bc6d6b
KW		 1164 }
1165
1166# endif
1167
1168 /* We are done, except for updating our records (if the system doesn't keep
1169 * them) and in the case of locale "", we don't actually know what the
1170 * locale that got switched to is, as it came from the environment. So
1171 * have to find it */
1172
1173# ifdef HAS_QUERYLOCALE
1174
1175 if (strEQ(locale, "")) {
1176 locale = querylocale(mask, new_obj);
1177 }
1178
1179# else
1180
1181 /* Here, 'locale' is the return value */
1182
1183 /* Without querylocale(), we have to update our records */
1184
1185 if (category == LC_ALL) {
1186 unsigned int i;
1187
1188 /* For LC_ALL, we change all individual categories to correspond */
1189 /* PL_curlocales is a parallel array, so has same
1190 * length as 'categories' */
1191 for (i = 0; i <= LC_ALL_INDEX; i++) {
1192 Safefree(PL_curlocales[i]);
1193 PL_curlocales[i] = savepv(locale);
1194 }
45cef8fb
KW		 1195
1196 FIX_GLIBC_LC_MESSAGES_BUG(LC_MESSAGES_INDEX);
e9bc6d6b
KW		 1197 }
1198 else {
1199
1200 /* For a single category, if it's not the same as the one in LC_ALL, we
1201 * nullify LC_ALL */
1202
1203 if (PL_curlocales[LC_ALL_INDEX] && strNE(PL_curlocales[LC_ALL_INDEX], locale)) {
1204 Safefree(PL_curlocales[LC_ALL_INDEX]);
1205 PL_curlocales[LC_ALL_INDEX] = NULL;
1206 }
1207
1208 /* Then update the category's record */
1209 Safefree(PL_curlocales[index]);
1210 PL_curlocales[index] = savepv(locale);
45cef8fb
KW		 1211
1212 FIX_GLIBC_LC_MESSAGES_BUG(index);
e9bc6d6b
KW		 1213 }
1214
1215# endif
1216
1217 return locale;
1218}
1219
1220#endif /* USE_POSIX_2008_LOCALE */
1221
1222#if 0 /* Code that was to emulate thread-safe locales on platforms that
1223 didn't natively support them */
1224
1225/* The way this would work is that we would keep a per-thread list of the
1226 * correct locale for that thread. Any operation that was locale-sensitive
1227 * would have to be changed so that it would look like this:
1228 *
1229 * LOCALE_LOCK;
1230 * setlocale to the correct locale for this operation
1231 * do operation
1232 * LOCALE_UNLOCK
1233 *
1234 * This leaves the global locale in the most recently used operation's, but it
1235 * was locked long enough to get the result. If that result is static, it
1236 * needs to be copied before the unlock.
1237 *
1238 * Macros could be written like SETUP_LOCALE_DEPENDENT_OP(category) that did
1239 * the setup, but are no-ops when not needed, and similarly,
1240 * END_LOCALE_DEPENDENT_OP for the tear-down
1241 *
1242 * But every call to a locale-sensitive function would have to be changed, and
1243 * if a module didn't cooperate by using the mutex, things would break.
1244 *
1245 * This code was abandoned before being completed or tested, and is left as-is
1246*/
1247
1248# define do_setlocale_c(cat, locale) locking_setlocale(cat, locale, cat ## _INDEX, TRUE)
1249# define do_setlocale_r(cat, locale) locking_setlocale(cat, locale, 0, FALSE)
1250
1251STATIC char *
1252S_locking_setlocale(pTHX_
1253 const int category,
1254 const char * locale,
1255 int index,
1256 const bool is_index_valid
1257 )
1258{
1259 /* This function kind of performs a setlocale() on just the current thread;
1260 * thus it is kind of thread-safe. It does this by keeping a thread-level
1261 * array of the current locales for each category. Every time a locale is
1262 * switched to, it does the switch globally, but updates the thread's
1263 * array. A query as to what the current locale is just returns the
1264 * appropriate element from the array, and doesn't actually call the system
1265 * setlocale(). The saving into the array is done in an uninterruptible
1266 * section of code, so is unaffected by whatever any other threads might be
1267 * doing.
1268 *
1269 * All locale-sensitive operations must work by first starting a critical
1270 * section, then switching to the thread's locale as kept by this function,
1271 * and then doing the operation, then ending the critical section. Thus,
1272 * each gets done in the appropriate locale. simulating thread-safety.
1273 *
1274 * This function takes the same parameters, 'category' and 'locale', that
1275 * the regular setlocale() function does, but it also takes two additional
1276 * ones. This is because as described earlier. If we know on input the
1277 * index corresponding to the category into the array where we store the
1278 * current locales, we don't have to calculate it. If the caller knows at
06cc5386 1279 * compile time what the index is, it can pass it, setting
e9bc6d6b
KW		 1280 * 'is_index_valid' to TRUE; otherwise the index parameter is ignored.
1281 *
1282 */
1283
1284 /* If the input index might be incorrect, calculate the correct one */
1285 if (! is_index_valid) {
1286 unsigned int i;
1287
1288 if (DEBUG_Lv_TEST || debug_initialization) {
1289 PerlIO_printf(Perl_debug_log, "%s:%d: converting category %d to index\n", __FILE__, __LINE__, category);
1290 }
1291
1292 for (i = 0; i <= LC_ALL_INDEX; i++) {
1293 if (category == categories[i]) {
1294 index = i;
1295 goto found_index;
1296 }
1297 }
1298
1299 /* Here, we don't know about this category, so can't handle it.
1300 * XXX best we can do is to unsafely set this
1301 * XXX warning */
1302
1303 return my_setlocale(category, locale);
1304
1305 found_index: ;
1306
1307 if (DEBUG_Lv_TEST || debug_initialization) {
1308 PerlIO_printf(Perl_debug_log, "%s:%d: index is 0x%x\n", __FILE__, __LINE__, index);
1309 }
1310 }
1311
1312 /* For a query, just return what's in our records */
1313 if (new_locale == NULL) {
1314 return curlocales[index];
1315 }
1316
1317
1318 /* Otherwise, we need to do the switch, and save the result, all in a
1319 * critical section */
1320
1321 Safefree(curlocales[[index]]);
1322
1323 /* It might be that this is called from an already-locked section of code.
1324 * We would have to detect and skip the LOCK/UNLOCK if so */
1325 LOCALE_LOCK;
1326
1327 curlocales[index] = savepv(my_setlocale(category, new_locale));
1328
1329 if (strEQ(new_locale, "")) {
1330
1331#ifdef LC_ALL
1332
1333 /* The locale values come from the environment, and may not all be the
1334 * same, so for LC_ALL, we have to update all the others, while the
1335 * mutex is still locked */
1336
1337 if (category == LC_ALL) {
1338 unsigned int i;
1339 for (i = 0; i < LC_ALL_INDEX) {
1340 curlocales[i] = my_setlocale(categories[i], NULL);
1341 }
1342 }
1343 }
1344
1345#endif
1346
1347 LOCALE_UNLOCK;
1348
1349 return curlocales[index];
1350}
1351
1352#endif
d36adde0 1353#ifdef USE_LOCALE
837ce802 1354
a4f00dcc 1355STATIC void
86799d2d 1356S_set_numeric_radix(pTHX_ const bool use_locale)
98994639 1357{
86799d2d
KW		 1358 /* If 'use_locale' is FALSE, set to use a dot for the radix character. If
1359 * TRUE, use the radix character derived from the current locale */
7d4bcc4a 1360
86799d2d
KW		 1361#if defined(USE_LOCALE_NUMERIC) && ( defined(HAS_LOCALECONV) \
1362 || defined(HAS_NL_LANGINFO))
98994639 1363
87f8e8e7 1364 const char * radix = (use_locale)
4e6826bf 1365 ? my_nl_langinfo(RADIXCHAR, FALSE)
87f8e8e7
KW		 1366 /* FALSE => already in dest locale */
1367 : ".";
2213a3be 1368
87f8e8e7 1369 sv_setpv(PL_numeric_radix_sv, radix);
86799d2d 1370
87f8e8e7
KW		 1371 /* If this is valid UTF-8 that isn't totally ASCII, and we are in
1372 * a UTF-8 locale, then mark the radix as being in UTF-8 */
1373 if (is_utf8_non_invariant_string((U8 *) SvPVX(PL_numeric_radix_sv),
7a393424 1374 SvCUR(PL_numeric_radix_sv))
87f8e8e7
KW		 1375 && _is_cur_LC_category_utf8(LC_NUMERIC))
1376 {
1377 SvUTF8_on(PL_numeric_radix_sv);
1378 }
86799d2d
KW		 1379
1380# ifdef DEBUGGING
7d4bcc4a 1381
2fcc0ca9
KW		 1382 if (DEBUG_L_TEST || debug_initialization) {
1383 PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
3ca88433
KW		 1384 SvPVX(PL_numeric_radix_sv),
1385 cBOOL(SvUTF8(PL_numeric_radix_sv)));
2fcc0ca9 1386 }
69014004 1387
86799d2d 1388# endif
d36adde0
KW		 1389#else
1390
1391 PERL_UNUSED_ARG(use_locale);
1392
86799d2d 1393#endif /* USE_LOCALE_NUMERIC and can find the radix char */
7d4bcc4a 1394
98994639
HS		 1395}
1396
398eeea9
KW		 1397STATIC void
1398S_new_numeric(pTHX_ const char *newnum)
98994639 1399{
7d4bcc4a
KW		 1400
1401#ifndef USE_LOCALE_NUMERIC
1402
1403 PERL_UNUSED_ARG(newnum);
1404
1405#else
0d071d52 1406
291a84fb 1407 /* Called after each libc setlocale() call affecting LC_NUMERIC, to tell
0d071d52
KW		 1408 * core Perl this and that 'newnum' is the name of the new locale.
1409 * It installs this locale as the current underlying default.
1410 *
1411 * The default locale and the C locale can be toggled between by use of the
5792c642
KW		 1412 * set_numeric_underlying() and set_numeric_standard() functions, which
1413 * should probably not be called directly, but only via macros like
0d071d52
KW		 1414 * SET_NUMERIC_STANDARD() in perl.h.
1415 *
1416 * The toggling is necessary mainly so that a non-dot radix decimal point
1417 * character can be output, while allowing internal calculations to use a
1418 * dot.
1419 *
1420 * This sets several interpreter-level variables:
bb304765 1421 * PL_numeric_name The underlying locale's name: a copy of 'newnum'
892e6465 1422 * PL_numeric_underlying A boolean indicating if the toggled state is such
7738054c
KW		 1423 * that the current locale is the program's underlying
1424 * locale
1425 * PL_numeric_standard An int indicating if the toggled state is such
4c68b815
KW		 1426 * that the current locale is the C locale or
1427 * indistinguishable from the C locale. If non-zero, it
1428 * is in C; if > 1, it means it may not be toggled away
7738054c 1429 * from C.
4c68b815
KW		 1430 * PL_numeric_underlying_is_standard A bool kept by this function
1431 * indicating that the underlying locale and the standard
1432 * C locale are indistinguishable for the purposes of
1433 * LC_NUMERIC. This happens when both of the above two
1434 * variables are true at the same time. (Toggling is a
1435 * no-op under these circumstances.) This variable is
1436 * used to avoid having to recalculate.
398eeea9 1437 */
0d071d52 1438
b03f34cf 1439 char *save_newnum;
98994639
HS		 1440
1441 if (! newnum) {
43c5f42d
NC		 1442 Safefree(PL_numeric_name);
1443 PL_numeric_name = NULL;
98994639 1444 PL_numeric_standard = TRUE;
892e6465 1445 PL_numeric_underlying = TRUE;
4c68b815 1446 PL_numeric_underlying_is_standard = TRUE;
98994639
HS		 1447 return;
1448 }
1449
b03f34cf 1450 save_newnum = stdize_locale(savepv(newnum));
892e6465 1451 PL_numeric_underlying = TRUE;
4c68b815
KW		 1452 PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
1453
69c5e0db
KW		 1454#ifndef TS_W32_BROKEN_LOCALECONV
1455
4c68b815 1456 /* If its name isn't C nor POSIX, it could still be indistinguishable from
69c5e0db
KW		 1457 * them. But on broken Windows systems calling my_nl_langinfo() for
1458 * THOUSEP can currently (but rarely) cause a race, so avoid doing that,
1459 * and just always change the locale if not C nor POSIX on those systems */
4c68b815 1460 if (! PL_numeric_standard) {
4e6826bf 1461 PL_numeric_standard = cBOOL(strEQ(".", my_nl_langinfo(RADIXCHAR,
4c68b815 1462 FALSE /* Don't toggle locale */ ))
4e6826bf 1463 && strEQ("", my_nl_langinfo(THOUSEP, FALSE)));
4c68b815 1464 }
abe1abcf 1465
69c5e0db
KW		 1466#endif
1467
4c68b815 1468 /* Save the new name if it isn't the same as the previous one, if any */
b03f34cf 1469 if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
98994639 1470 Safefree(PL_numeric_name);
b03f34cf 1471 PL_numeric_name = save_newnum;
b03f34cf 1472 }
abe1abcf
KW		 1473 else {
1474 Safefree(save_newnum);
1475 }
4c28b29c 1476
4c68b815
KW		 1477 PL_numeric_underlying_is_standard = PL_numeric_standard;
1478
7e5377f7 1479# ifdef HAS_POSIX_2008_LOCALE
e1aa2579
KW		 1480
1481 PL_underlying_numeric_obj = newlocale(LC_NUMERIC_MASK,
1482 PL_numeric_name,
1483 PL_underlying_numeric_obj);
1484
1485#endif
1486
4c68b815
KW		 1487 if (DEBUG_L_TEST || debug_initialization) {
1488 PerlIO_printf(Perl_debug_log, "Called new_numeric with %s, PL_numeric_name=%s\n", newnum, PL_numeric_name);
1489 }
1490
4c28b29c
KW		 1491 /* Keep LC_NUMERIC in the C locale. This is for XS modules, so they don't
1492 * have to worry about the radix being a non-dot. (Core operations that
1493 * need the underlying locale change to it temporarily). */
84f1d29f
KW		 1494 if (PL_numeric_standard) {
1495 set_numeric_radix(0);
1496 }
1497 else {
1498 set_numeric_standard();
1499 }
4c28b29c 1500
98994639 1501#endif /* USE_LOCALE_NUMERIC */
7d4bcc4a 1502
98994639
HS		 1503}
1504
1505void
1506Perl_set_numeric_standard(pTHX)
1507{
7d4bcc4a 1508
98994639 1509#ifdef USE_LOCALE_NUMERIC
7d4bcc4a 1510
28c1bf33
KW		 1511 /* Toggle the LC_NUMERIC locale to C. Most code should use the macros like
1512 * SET_NUMERIC_STANDARD() in perl.h instead of calling this directly. The
1513 * macro avoids calling this routine if toggling isn't necessary according
1514 * to our records (which could be wrong if some XS code has changed the
1515 * locale behind our back) */
0d071d52 1516
7d4bcc4a
KW		 1517# ifdef DEBUGGING
1518
2fcc0ca9
KW		 1519 if (DEBUG_L_TEST || debug_initialization) {
1520 PerlIO_printf(Perl_debug_log,
7bb8f702 1521 "Setting LC_NUMERIC locale to standard C\n");
2fcc0ca9 1522 }
98994639 1523
7d4bcc4a 1524# endif
7bb8f702
KW		 1525
1526 do_setlocale_c(LC_NUMERIC, "C");
1527 PL_numeric_standard = TRUE;
1528 PL_numeric_underlying = PL_numeric_underlying_is_standard;
1529 set_numeric_radix(0);
1530
98994639 1531#endif /* USE_LOCALE_NUMERIC */
7d4bcc4a 1532
98994639
HS		 1533}
1534
1535void
5792c642 1536Perl_set_numeric_underlying(pTHX)
98994639 1537{
7d4bcc4a 1538
98994639 1539#ifdef USE_LOCALE_NUMERIC
7d4bcc4a 1540
28c1bf33 1541 /* Toggle the LC_NUMERIC locale to the current underlying default. Most
7d4bcc4a
KW		 1542 * code should use the macros like SET_NUMERIC_UNDERLYING() in perl.h
1543 * instead of calling this directly. The macro avoids calling this routine
1544 * if toggling isn't necessary according to our records (which could be
1545 * wrong if some XS code has changed the locale behind our back) */
a9b8c0d8 1546
7d4bcc4a
KW		 1547# ifdef DEBUGGING
1548
2fcc0ca9
KW		 1549 if (DEBUG_L_TEST || debug_initialization) {
1550 PerlIO_printf(Perl_debug_log,
7bb8f702 1551 "Setting LC_NUMERIC locale to %s\n",
2fcc0ca9
KW		 1552 PL_numeric_name);
1553 }
98994639 1554
7d4bcc4a 1555# endif
7bb8f702
KW		 1556
1557 do_setlocale_c(LC_NUMERIC, PL_numeric_name);
1558 PL_numeric_standard = PL_numeric_underlying_is_standard;
1559 PL_numeric_underlying = TRUE;
1560 set_numeric_radix(! PL_numeric_standard);
1561
98994639 1562#endif /* USE_LOCALE_NUMERIC */
7d4bcc4a 1563
98994639
HS		 1564}
1565
1566/*
1567 * Set up for a new ctype locale.
1568 */
a4f00dcc
KW		 1569STATIC void
1570S_new_ctype(pTHX_ const char *newctype)
98994639 1571{
7d4bcc4a
KW		 1572
1573#ifndef USE_LOCALE_CTYPE
1574
7d4bcc4a
KW		 1575 PERL_UNUSED_ARG(newctype);
1576 PERL_UNUSED_CONTEXT;
1577
1578#else
0d071d52 1579
291a84fb 1580 /* Called after each libc setlocale() call affecting LC_CTYPE, to tell
0d071d52
KW		 1581 * core Perl this and that 'newctype' is the name of the new locale.
1582 *
1583 * This function sets up the folding arrays for all 256 bytes, assuming
1584 * that tofold() is tolc() since fold case is not a concept in POSIX,
1585 *
1586 * Any code changing the locale (outside this file) should use
9aac5db8
KW		 1587 * Perl_setlocale or POSIX::setlocale, which call this function. Therefore
1588 * this function should be called directly only from this file and from
0d071d52
KW		 1589 * POSIX::setlocale() */
1590
013f4e03 1591 unsigned int i;
98994639 1592
8b7358b9
KW		 1593 /* Don't check for problems if we are suppressing the warnings */
1594 bool check_for_problems = ckWARN_d(WARN_LOCALE) || UNLIKELY(DEBUG_L_TEST);
30d8090d 1595 bool maybe_utf8_turkic = FALSE;
8b7358b9 1596
7918f24d
NC		 1597 PERL_ARGS_ASSERT_NEW_CTYPE;
1598
215c5139
KW		 1599 /* We will replace any bad locale warning with 1) nothing if the new one is
1600 * ok; or 2) a new warning for the bad new locale */
1601 if (PL_warn_locale) {
1602 SvREFCNT_dec_NN(PL_warn_locale);
1603 PL_warn_locale = NULL;
1604 }
1605
c1284011 1606 PL_in_utf8_CTYPE_locale = _is_cur_LC_category_utf8(LC_CTYPE);
31f05a37
KW		 1607
1608 /* A UTF-8 locale gets standard rules. But note that code still has to
1609 * handle this specially because of the three problematic code points */
1610 if (PL_in_utf8_CTYPE_locale) {
1611 Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
30d8090d
KW		 1612
1613 /* UTF-8 locales can have special handling for 'I' and 'i' if they are
1614 * Turkic. Make sure these two are the only anomalies. (We don't use
1615 * towupper and towlower because they aren't in C89.) */
5b64f24c
KW		 1616
1617#if defined(HAS_TOWUPPER) && defined (HAS_TOWLOWER)
1618
1619 if (towupper('i') == 0x130 && towlower('I') == 0x131) {
1620
1621#else
1622
30d8090d 1623 if (toupper('i') == 'i' && tolower('I') == 'I') {
5b64f24c
KW		 1624
1625#endif
30d8090d
KW		 1626 check_for_problems = TRUE;
1627 maybe_utf8_turkic = TRUE;
1628 }
31f05a37 1629 }
8b7358b9
KW		 1630
1631 /* We don't populate the other lists if a UTF-8 locale, but do check that
1632 * everything works as expected, unless checking turned off */
1633 if (check_for_problems || ! PL_in_utf8_CTYPE_locale) {
8c6180a9
KW		 1634 /* Assume enough space for every character being bad. 4 spaces each
1635 * for the 94 printable characters that are output like "'x' "; and 5
1636 * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
1637 * NUL */
8b7358b9 1638 char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ] = { '\0' };
8c6180a9
KW		 1639 bool multi_byte_locale = FALSE; /* Assume is a single-byte locale
1640 to start */
1641 unsigned int bad_count = 0; /* Count of bad characters */
1642
baa60164 1643 for (i = 0; i < 256; i++) {
8b7358b9 1644 if (! PL_in_utf8_CTYPE_locale) {
bd6d0898
KW		 1645 if (isupper(i))
1646 PL_fold_locale[i] = (U8) tolower(i);
1647 else if (islower(i))
1648 PL_fold_locale[i] = (U8) toupper(i);
1649 else
1650 PL_fold_locale[i] = (U8) i;
8b7358b9 1651 }
8c6180a9
KW		 1652
1653 /* If checking for locale problems, see if the native ASCII-range
1654 * printables plus \n and \t are in their expected categories in
1655 * the new locale. If not, this could mean big trouble, upending
1656 * Perl's and most programs' assumptions, like having a
1657 * metacharacter with special meaning become a \w. Fortunately,
1658 * it's very rare to find locales that aren't supersets of ASCII
1659 * nowadays. It isn't a problem for most controls to be changed
1660 * into something else; we check only \n and \t, though perhaps \r
1661 * could be an issue as well. */
7d4bcc4a 1662 if ( check_for_problems
8c6180a9
KW		 1663 && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
1664 {
8b7358b9 1665 bool is_bad = FALSE;
6726b4f4 1666 char name[4] = { '\0' };
8b7358b9
KW		 1667
1668 /* Convert the name into a string */
6726b4f4 1669 if (isGRAPH_A(i)) {
8b7358b9
KW		 1670 name[0] = i;
1671 name[1] = '\0';
1672 }
1673 else if (i == '\n') {
6726b4f4
KW		 1674 my_strlcpy(name, "\\n", sizeof(name));
1675 }
1676 else if (i == '\t') {
1677 my_strlcpy(name, "\\t", sizeof(name));
8b7358b9
KW		 1678 }
1679 else {
6726b4f4
KW		 1680 assert(i == ' ');
1681 my_strlcpy(name, "' '", sizeof(name));
8b7358b9
KW		 1682 }
1683
1684 /* Check each possibe class */
1685 if (UNLIKELY(cBOOL(isalnum(i)) != cBOOL(isALPHANUMERIC_A(i)))) {
1686 is_bad = TRUE;
1687 DEBUG_L(PerlIO_printf(Perl_debug_log,
1688 "isalnum('%s') unexpectedly is %d\n",
1689 name, cBOOL(isalnum(i))));
1690 }
1691 if (UNLIKELY(cBOOL(isalpha(i)) != cBOOL(isALPHA_A(i)))) {
1692 is_bad = TRUE;
1693 DEBUG_L(PerlIO_printf(Perl_debug_log,
1694 "isalpha('%s') unexpectedly is %d\n",
1695 name, cBOOL(isalpha(i))));
1696 }
1697 if (UNLIKELY(cBOOL(isdigit(i)) != cBOOL(isDIGIT_A(i)))) {
1698 is_bad = TRUE;
1699 DEBUG_L(PerlIO_printf(Perl_debug_log,
1700 "isdigit('%s') unexpectedly is %d\n",
1701 name, cBOOL(isdigit(i))));
1702 }
1703 if (UNLIKELY(cBOOL(isgraph(i)) != cBOOL(isGRAPH_A(i)))) {
1704 is_bad = TRUE;
1705 DEBUG_L(PerlIO_printf(Perl_debug_log,
1706 "isgraph('%s') unexpectedly is %d\n",
1707 name, cBOOL(isgraph(i))));
1708 }
1709 if (UNLIKELY(cBOOL(islower(i)) != cBOOL(isLOWER_A(i)))) {
1710 is_bad = TRUE;
1711 DEBUG_L(PerlIO_printf(Perl_debug_log,
1712 "islower('%s') unexpectedly is %d\n",
1713 name, cBOOL(islower(i))));
1714 }
1715 if (UNLIKELY(cBOOL(isprint(i)) != cBOOL(isPRINT_A(i)))) {
1716 is_bad = TRUE;
1717 DEBUG_L(PerlIO_printf(Perl_debug_log,
1718 "isprint('%s') unexpectedly is %d\n",
1719 name, cBOOL(isprint(i))));
1720 }
1721 if (UNLIKELY(cBOOL(ispunct(i)) != cBOOL(isPUNCT_A(i)))) {
1722 is_bad = TRUE;
1723 DEBUG_L(PerlIO_printf(Perl_debug_log,
1724 "ispunct('%s') unexpectedly is %d\n",
1725 name, cBOOL(ispunct(i))));
1726 }
1727 if (UNLIKELY(cBOOL(isspace(i)) != cBOOL(isSPACE_A(i)))) {
1728 is_bad = TRUE;
1729 DEBUG_L(PerlIO_printf(Perl_debug_log,
1730 "isspace('%s') unexpectedly is %d\n",
1731 name, cBOOL(isspace(i))));
1732 }
1733 if (UNLIKELY(cBOOL(isupper(i)) != cBOOL(isUPPER_A(i)))) {
1734 is_bad = TRUE;
1735 DEBUG_L(PerlIO_printf(Perl_debug_log,
1736 "isupper('%s') unexpectedly is %d\n",
1737 name, cBOOL(isupper(i))));
1738 }
1739 if (UNLIKELY(cBOOL(isxdigit(i))!= cBOOL(isXDIGIT_A(i)))) {
1740 is_bad = TRUE;
1741 DEBUG_L(PerlIO_printf(Perl_debug_log,
1742 "isxdigit('%s') unexpectedly is %d\n",
1743 name, cBOOL(isxdigit(i))));
1744 }
65c15174 1745 if (UNLIKELY(tolower(i) != (int) toLOWER_A(i))) {
8b7358b9
KW		 1746 is_bad = TRUE;
1747 DEBUG_L(PerlIO_printf(Perl_debug_log,
1748 "tolower('%s')=0x%x instead of the expected 0x%x\n",
1749 name, tolower(i), (int) toLOWER_A(i)));
1750 }
65c15174 1751 if (UNLIKELY(toupper(i) != (int) toUPPER_A(i))) {
8b7358b9
KW		 1752 is_bad = TRUE;
1753 DEBUG_L(PerlIO_printf(Perl_debug_log,
1754 "toupper('%s')=0x%x instead of the expected 0x%x\n",
1755 name, toupper(i), (int) toUPPER_A(i)));
1756 }
1757 if (UNLIKELY((i == '\n' && ! isCNTRL_LC(i)))) {
1758 is_bad = TRUE;
1759 DEBUG_L(PerlIO_printf(Perl_debug_log,
1760 "'\\n' (=%02X) is not a control\n", (int) i));
1761 }
1762
1763 /* Add to the list; Separate multiple entries with a blank */
1764 if (is_bad) {
1765 if (bad_count) {
1766 my_strlcat(bad_chars_list, " ", sizeof(bad_chars_list));
8c6180a9 1767 }
8b7358b9
KW		 1768 my_strlcat(bad_chars_list, name, sizeof(bad_chars_list));
1769 bad_count++;
8c6180a9
KW		 1770 }
1771 }
1772 }
1773
30d8090d
KW		 1774 if (bad_count == 2 && maybe_utf8_turkic) {
1775 bad_count = 0;
1776 *bad_chars_list = '\0';
1777 PL_fold_locale['I'] = 'I';
1778 PL_fold_locale['i'] = 'i';
1779 PL_in_utf8_turkic_locale = TRUE;
1780 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s is turkic\n",
1781 __FILE__, __LINE__, newctype));
1782 }
1783 else {
b8df1494 1784 PL_in_utf8_turkic_locale = FALSE;
30d8090d 1785 }
b8df1494 1786
7d4bcc4a
KW		 1787# ifdef MB_CUR_MAX
1788
8c6180a9 1789 /* We only handle single-byte locales (outside of UTF-8 ones; so if
d35fca5f 1790 * this locale requires more than one byte, there are going to be
8c6180a9 1791 * problems. */
9c8a6dc2
KW		 1792 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1793 "%s:%d: check_for_problems=%d, MB_CUR_MAX=%d\n",
1794 __FILE__, __LINE__, check_for_problems, (int) MB_CUR_MAX));
1795
8b7358b9
KW		 1796 if ( check_for_problems && MB_CUR_MAX > 1
1797 && ! PL_in_utf8_CTYPE_locale
ba1a4362
KW		 1798
1799 /* Some platforms return MB_CUR_MAX > 1 for even the "C"
1800 * locale. Just assume that the implementation for them (plus
1801 * for POSIX) is correct and the > 1 value is spurious. (Since
1802 * these are specially handled to never be considered UTF-8
1803 * locales, as long as this is the only problem, everything
1804 * should work fine */
1805 && strNE(newctype, "C") && strNE(newctype, "POSIX"))
1806 {
8c6180a9
KW		 1807 multi_byte_locale = TRUE;
1808 }
7d4bcc4a
KW		 1809
1810# endif
8c6180a9 1811
30d8090d
KW		 1812 /* If we found problems and we want them output, do so */
1813 if ( (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale))
1814 && (LIKELY(ckWARN_d(WARN_LOCALE)) || UNLIKELY(DEBUG_L_TEST)))
1815 {
8b7358b9
KW		 1816 if (UNLIKELY(bad_count) && PL_in_utf8_CTYPE_locale) {
1817 PL_warn_locale = Perl_newSVpvf(aTHX_
1818 "Locale '%s' contains (at least) the following characters"
578a6a87
KW		 1819 " which have\nunexpected meanings: %s\nThe Perl program"
1820 " will use the expected meanings",
8b7358b9 1821 newctype, bad_chars_list);
8b7358b9
KW		 1822 }
1823 else {
1824 PL_warn_locale = Perl_newSVpvf(aTHX_
8c6180a9 1825 "Locale '%s' may not work well.%s%s%s\n",
780fcc9f 1826 newctype,
8c6180a9
KW		 1827 (multi_byte_locale)
1828 ? " Some characters in it are not recognized by"
1829 " Perl."
1830 : "",
1831 (bad_count)
1832 ? "\nThe following characters (and maybe others)"
1833 " may not have the same meaning as the Perl"
1834 " program expects:\n"
1835 : "",
1836 (bad_count)
1837 ? bad_chars_list
1838 : ""
1839 );
8b7358b9
KW		 1840 }
1841
b119c2be
KW		 1842# ifdef HAS_NL_LANGINFO
1843
1844 Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
1845 /* parameter FALSE is a don't care here */
4e6826bf 1846 my_nl_langinfo(CODESET, FALSE));
b119c2be
KW		 1847
1848# endif
1849
8b7358b9
KW		 1850 Perl_sv_catpvf(aTHX_ PL_warn_locale, "\n");
1851
cc9eaeb0 1852 /* If we are actually in the scope of the locale or are debugging,
bddebb56
KW		 1853 * output the message now. If not in that scope, we save the
1854 * message to be output at the first operation using this locale,
1855 * if that actually happens. Most programs don't use locales, so
1856 * they are immune to bad ones. */
cc9eaeb0 1857 if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
780fcc9f 1858
780fcc9f
KW		 1859 /* The '0' below suppresses a bogus gcc compiler warning */
1860 Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale), 0);
bddebb56 1861
bddebb56
KW		 1862 if (IN_LC(LC_CTYPE)) {
1863 SvREFCNT_dec_NN(PL_warn_locale);
1864 PL_warn_locale = NULL;
1865 }
780fcc9f 1866 }
baa60164 1867 }
31f05a37 1868 }
98994639
HS		 1869
1870#endif /* USE_LOCALE_CTYPE */
7d4bcc4a 1871
98994639
HS		 1872}
1873
98994639 1874void
2726666d
KW		 1875Perl__warn_problematic_locale()
1876{
2726666d
KW		 1877
1878#ifdef USE_LOCALE_CTYPE
1879
5f04a188
KW		 1880 dTHX;
1881
1882 /* Internal-to-core function that outputs the message in PL_warn_locale,
1883 * and then NULLS it. Should be called only through the macro
1884 * _CHECK_AND_WARN_PROBLEMATIC_LOCALE */
1885
2726666d 1886 if (PL_warn_locale) {
2726666d
KW		 1887 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
1888 SvPVX(PL_warn_locale),
1889 0 /* dummy to avoid compiler warning */ );
2726666d
KW		 1890 SvREFCNT_dec_NN(PL_warn_locale);
1891 PL_warn_locale = NULL;
1892 }
1893
1894#endif
1895
1896}
1897
a4f00dcc
KW		 1898STATIC void
1899S_new_collate(pTHX_ const char *newcoll)
98994639 1900{
7d4bcc4a
KW		 1901
1902#ifndef USE_LOCALE_COLLATE
1903
1904 PERL_UNUSED_ARG(newcoll);
1905 PERL_UNUSED_CONTEXT;
1906
1907#else
0d071d52 1908
291a84fb 1909 /* Called after each libc setlocale() call affecting LC_COLLATE, to tell
0d071d52
KW		 1910 * core Perl this and that 'newcoll' is the name of the new locale.
1911 *
d35fca5f
KW		 1912 * The design of locale collation is that every locale change is given an
1913 * index 'PL_collation_ix'. The first time a string particpates in an
1914 * operation that requires collation while locale collation is active, it
1915 * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()). That
1916 * magic includes the collation index, and the transformation of the string
1917 * by strxfrm(), q.v. That transformation is used when doing comparisons,
1918 * instead of the string itself. If a string changes, the magic is
1919 * cleared. The next time the locale changes, the index is incremented,
1920 * and so we know during a comparison that the transformation is not
1921 * necessarily still valid, and so is recomputed. Note that if the locale
1922 * changes enough times, the index could wrap (a U32), and it is possible
1923 * that a transformation would improperly be considered valid, leading to
1924 * an unlikely bug */
0d071d52 1925
98994639
HS		 1926 if (! newcoll) {
1927 if (PL_collation_name) {
1928 ++PL_collation_ix;
1929 Safefree(PL_collation_name);
1930 PL_collation_name = NULL;
1931 }
1932 PL_collation_standard = TRUE;
00bf60ca 1933 is_standard_collation:
98994639
HS		 1934 PL_collxfrm_base = 0;
1935 PL_collxfrm_mult = 2;
165a1c52 1936 PL_in_utf8_COLLATE_locale = FALSE;
f28f4d2a 1937 PL_strxfrm_NUL_replacement = '\0';
a4a439fb 1938 PL_strxfrm_max_cp = 0;
98994639
HS		 1939 return;
1940 }
1941
d35fca5f 1942 /* If this is not the same locale as currently, set the new one up */
98994639
HS		 1943 if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
1944 ++PL_collation_ix;
1945 Safefree(PL_collation_name);
1946 PL_collation_name = stdize_locale(savepv(newcoll));
a39edc4c 1947 PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
00bf60ca
KW		 1948 if (PL_collation_standard) {
1949 goto is_standard_collation;
1950 }
98994639 1951
165a1c52 1952 PL_in_utf8_COLLATE_locale = _is_cur_LC_category_utf8(LC_COLLATE);
f28f4d2a 1953 PL_strxfrm_NUL_replacement = '\0';
a4a439fb 1954 PL_strxfrm_max_cp = 0;
165a1c52 1955
59c018b9
KW		 1956 /* A locale collation definition includes primary, secondary, tertiary,
1957 * etc. weights for each character. To sort, the primary weights are
1958 * used, and only if they compare equal, then the secondary weights are
1959 * used, and only if they compare equal, then the tertiary, etc.
1960 *
1961 * strxfrm() works by taking the input string, say ABC, and creating an
1962 * output transformed string consisting of first the primary weights,
1963 * A¹B¹C¹ followed by the secondary ones, A²B²C²; and then the
1964 * tertiary, etc, yielding A¹B¹C¹ A²B²C² A³B³C³ .... Some characters
1965 * may not have weights at every level. In our example, let's say B
1966 * doesn't have a tertiary weight, and A doesn't have a secondary
1967 * weight. The constructed string is then going to be
1968 * A¹B¹C¹ B²C² A³C³ ....
1969 * This has the desired effect that strcmp() will look at the secondary
1970 * or tertiary weights only if the strings compare equal at all higher
1971 * priority weights. The spaces shown here, like in
c342d20e 1972 * "A¹B¹C¹ A²B²C² "
59c018b9
KW		 1973 * are not just for readability. In the general case, these must
1974 * actually be bytes, which we will call here 'separator weights'; and
1975 * they must be smaller than any other weight value, but since these
1976 * are C strings, only the terminating one can be a NUL (some
1977 * implementations may include a non-NUL separator weight just before
1978 * the NUL). Implementations tend to reserve 01 for the separator
1979 * weights. They are needed so that a shorter string's secondary
1980 * weights won't be misconstrued as primary weights of a longer string,
1981 * etc. By making them smaller than any other weight, the shorter
1982 * string will sort first. (Actually, if all secondary weights are
1983 * smaller than all primary ones, there is no need for a separator
1984 * weight between those two levels, etc.)
1985 *
1986 * The length of the transformed string is roughly a linear function of
1987 * the input string. It's not exactly linear because some characters
1988 * don't have weights at all levels. When we call strxfrm() we have to
1989 * allocate some memory to hold the transformed string. The
1990 * calculations below try to find coefficients 'm' and 'b' for this
1991 * locale so that m*x + b equals how much space we need, given the size
1992 * of the input string in 'x'. If we calculate too small, we increase
1993 * the size as needed, and call strxfrm() again, but it is better to
1994 * get it right the first time to avoid wasted expensive string
1995 * transformations. */
1996
98994639 1997 {
79f120c8
KW		 1998 /* We use the string below to find how long the tranformation of it
1999 * is. Almost all locales are supersets of ASCII, or at least the
2000 * ASCII letters. We use all of them, half upper half lower,
2001 * because if we used fewer, we might hit just the ones that are
2002 * outliers in a particular locale. Most of the strings being
2003 * collated will contain a preponderance of letters, and even if
2004 * they are above-ASCII, they are likely to have the same number of
2005 * weight levels as the ASCII ones. It turns out that digits tend
2006 * to have fewer levels, and some punctuation has more, but those
2007 * are relatively sparse in text, and khw believes this gives a
2008 * reasonable result, but it could be changed if experience so
2009 * dictates. */
2010 const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
2011 char * x_longer; /* Transformed 'longer' */
2012 Size_t x_len_longer; /* Length of 'x_longer' */
2013
2014 char * x_shorter; /* We also transform a substring of 'longer' */
2015 Size_t x_len_shorter;
2016
a4a439fb 2017 /* _mem_collxfrm() is used get the transformation (though here we
79f120c8
KW		 2018 * are interested only in its length). It is used because it has
2019 * the intelligence to handle all cases, but to work, it needs some
2020 * values of 'm' and 'b' to get it started. For the purposes of
2021 * this calculation we use a very conservative estimate of 'm' and
2022 * 'b'. This assumes a weight can be multiple bytes, enough to
2023 * hold any UV on the platform, and there are 5 levels, 4 weight
2024 * bytes, and a trailing NUL. */
2025 PL_collxfrm_base = 5;
2026 PL_collxfrm_mult = 5 * sizeof(UV);
2027
2028 /* Find out how long the transformation really is */
a4a439fb
KW		 2029 x_longer = _mem_collxfrm(longer,
2030 sizeof(longer) - 1,
2031 &x_len_longer,
2032
2033 /* We avoid converting to UTF-8 in the
2034 * called function by telling it the
2035 * string is in UTF-8 if the locale is a
2036 * UTF-8 one. Since the string passed
2037 * here is invariant under UTF-8, we can
2038 * claim it's UTF-8 even though it isn't.
2039 * */
2040 PL_in_utf8_COLLATE_locale);
79f120c8
KW		 2041 Safefree(x_longer);
2042
2043 /* Find out how long the transformation of a substring of 'longer'
2044 * is. Together the lengths of these transformations are
2045 * sufficient to calculate 'm' and 'b'. The substring is all of
2046 * 'longer' except the first character. This minimizes the chances
2047 * of being swayed by outliers */
a4a439fb 2048 x_shorter = _mem_collxfrm(longer + 1,
79f120c8 2049 sizeof(longer) - 2,
a4a439fb
KW		 2050 &x_len_shorter,
2051 PL_in_utf8_COLLATE_locale);
79f120c8
KW		 2052 Safefree(x_shorter);
2053
2054 /* If the results are nonsensical for this simple test, the whole
2055 * locale definition is suspect. Mark it so that locale collation
2056 * is not active at all for it. XXX Should we warn? */
2057 if ( x_len_shorter == 0
2058 || x_len_longer == 0
2059 || x_len_shorter >= x_len_longer)
2060 {
2061 PL_collxfrm_mult = 0;
2062 PL_collxfrm_base = 0;
2063 }
2064 else {
2065 SSize_t base; /* Temporary */
2066
2067 /* We have both: m * strlen(longer) + b = x_len_longer
2068 * m * strlen(shorter) + b = x_len_shorter;
2069 * subtracting yields:
2070 * m * (strlen(longer) - strlen(shorter))
2071 * = x_len_longer - x_len_shorter
2072 * But we have set things up so that 'shorter' is 1 byte smaller
2073 * than 'longer'. Hence:
2074 * m = x_len_longer - x_len_shorter
2075 *
2076 * But if something went wrong, make sure the multiplier is at
2077 * least 1.
2078 */
2079 if (x_len_longer > x_len_shorter) {
2080 PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
2081 }
2082 else {
2083 PL_collxfrm_mult = 1;
2084 }
2085
2086 /* mx + b = len
2087 * so: b = len - mx
2088 * but in case something has gone wrong, make sure it is
2089 * non-negative */
2090 base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
2091 if (base < 0) {
2092 base = 0;
2093 }
2094
2095 /* Add 1 for the trailing NUL */
2096 PL_collxfrm_base = base + 1;
2097 }
58eebef2 2098
7d4bcc4a
KW		 2099# ifdef DEBUGGING
2100
58eebef2
KW		 2101 if (DEBUG_L_TEST || debug_initialization) {
2102 PerlIO_printf(Perl_debug_log,
b07929e4
KW		 2103 "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, "
2104 "x_len_longer=%zu,"
2105 " collate multipler=%zu, collate base=%zu\n",
58eebef2
KW		 2106 __FILE__, __LINE__,
2107 PL_in_utf8_COLLATE_locale,
2108 x_len_shorter, x_len_longer,
2109 PL_collxfrm_mult, PL_collxfrm_base);
2110 }
7d4bcc4a
KW		 2111# endif
2112
98994639
HS		 2113 }
2114 }
2115
2116#endif /* USE_LOCALE_COLLATE */
7d4bcc4a 2117
98994639
HS		 2118}
2119
d36adde0
KW		 2120#endif
2121
d2b24094 2122#ifdef WIN32
b8cc575c 2123
6c332036
TC		 2124#define USE_WSETLOCALE
2125
2126#ifdef USE_WSETLOCALE
2127
2128STATIC char *
2129S_wrap_wsetlocale(pTHX_ int category, const char *locale) {
2130 wchar_t *wlocale;
2131 wchar_t *wresult;
2132 char *result;
2133
2134 if (locale) {
2135 int req_size =
2136 MultiByteToWideChar(CP_UTF8, 0, locale, -1, NULL, 0);
2137
2138 if (!req_size) {
2139 errno = EINVAL;
2140 return NULL;
2141 }
2142
2143 Newx(wlocale, req_size, wchar_t);
2144 if (!MultiByteToWideChar(CP_UTF8, 0, locale, -1, wlocale, req_size)) {
2145 Safefree(wlocale);
2146 errno = EINVAL;
2147 return NULL;
2148 }
2149 }
2150 else {
2151 wlocale = NULL;
2152 }
2153 wresult = _wsetlocale(category, wlocale);
2154 Safefree(wlocale);
2155 if (wresult) {
2156 int req_size =
2157 WideCharToMultiByte(CP_UTF8, 0, wresult, -1, NULL, 0, NULL, NULL);
2158 Newx(result, req_size, char);
2159 SAVEFREEPV(result); /* is there something better we can do here? */
2160 if (!WideCharToMultiByte(CP_UTF8, 0, wresult, -1,
2161 result, req_size, NULL, NULL)) {
2162 errno = EINVAL;
2163 return NULL;
2164 }
2165 }
2166 else {
2167 result = NULL;
2168 }
2169
2170 return result;
2171}
2172
2173#endif
2174
a4f00dcc 2175STATIC char *
b8cc575c 2176S_win32_setlocale(pTHX_ int category, const char* locale)
b385bb4d
KW		 2177{
2178 /* This, for Windows, emulates POSIX setlocale() behavior. There is no
7d4bcc4a
KW		 2179 * difference between the two unless the input locale is "", which normally
2180 * means on Windows to get the machine default, which is set via the
2181 * computer's "Regional and Language Options" (or its current equivalent).
2182 * In POSIX, it instead means to find the locale from the user's
2183 * environment. This routine changes the Windows behavior to first look in
2184 * the environment, and, if anything is found, use that instead of going to
2185 * the machine default. If there is no environment override, the machine
2186 * default is used, by calling the real setlocale() with "".
2187 *
2188 * The POSIX behavior is to use the LC_ALL variable if set; otherwise to
2189 * use the particular category's variable if set; otherwise to use the LANG
2190 * variable. */
b385bb4d 2191
175c4cf9 2192 bool override_LC_ALL = FALSE;
89f7b9aa 2193 char * result;
e5f10d49 2194 unsigned int i;
89f7b9aa 2195
b385bb4d 2196 if (locale && strEQ(locale, "")) {
7d4bcc4a
KW		 2197
2198# ifdef LC_ALL
2199
b385bb4d
KW		 2200 locale = PerlEnv_getenv("LC_ALL");
2201 if (! locale) {
e5f10d49
KW		 2202 if (category == LC_ALL) {
2203 override_LC_ALL = TRUE;
2204 }
2205 else {
7d4bcc4a
KW		 2206
2207# endif
7d4bcc4a 2208
e5f10d49
KW		 2209 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
2210 if (category == categories[i]) {
2211 locale = PerlEnv_getenv(category_names[i]);
2212 goto found_locale;
2213 }
2214 }
7d4bcc4a 2215
b385bb4d 2216 locale = PerlEnv_getenv("LANG");
481465ea 2217 if (! locale) {
b385bb4d
KW		 2218 locale = "";
2219 }
e5f10d49
KW		 2220
2221 found_locale: ;
7d4bcc4a
KW		 2222
2223# ifdef LC_ALL
2224
e5f10d49 2225 }
b385bb4d 2226 }
7d4bcc4a
KW		 2227
2228# endif
2229
b385bb4d
KW		 2230 }
2231
6c332036
TC		 2232#ifdef USE_WSETLOCALE
2233 result = S_wrap_wsetlocale(aTHX_ category, locale);
2234#else
89f7b9aa 2235 result = setlocale(category, locale);
6c332036 2236#endif
48015184
KW		 2237 DEBUG_L(STMT_START {
2238 dSAVE_ERRNO;
2239 PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
2240 setlocale_debug_string(category, locale, result));
2241 RESTORE_ERRNO;
2242 } STMT_END);
89f7b9aa 2243
481465ea 2244 if (! override_LC_ALL) {
89f7b9aa
KW		 2245 return result;
2246 }
2247
dfd77d7a 2248 /* Here the input category was LC_ALL, and we have set it to what is in the
481465ea
KW		 2249 * LANG variable or the system default if there is no LANG. But these have
2250 * lower priority than the other LC_foo variables, so override it for each
2251 * one that is set. (If they are set to "", it means to use the same thing
2252 * we just set LC_ALL to, so can skip) */
7d4bcc4a 2253
948523db 2254 for (i = 0; i < LC_ALL_INDEX; i++) {
e5f10d49
KW		 2255 result = PerlEnv_getenv(category_names[i]);
2256 if (result && strNE(result, "")) {
6c332036 2257#ifdef USE_WSETLOCALE
17a1e9ac 2258 S_wrap_wsetlocale(aTHX_ categories[i], result);
6c332036 2259#else
17a1e9ac 2260 setlocale(categories[i], result);
6c332036 2261#endif
e5f10d49
KW		 2262 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
2263 __FILE__, __LINE__,
2264 setlocale_debug_string(categories[i], result, "not captured")));
2265 }
89f7b9aa 2266 }
7d4bcc4a 2267
bbc98134 2268 result = setlocale(LC_ALL, NULL);
48015184
KW		 2269 DEBUG_L(STMT_START {
2270 dSAVE_ERRNO;
2271 PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
bbc98134 2272 __FILE__, __LINE__,
48015184
KW		 2273 setlocale_debug_string(LC_ALL, NULL, result));
2274 RESTORE_ERRNO;
2275 } STMT_END);
89f7b9aa 2276
bbc98134 2277 return result;
b385bb4d
KW		 2278}
2279
2280#endif
2281
9aac5db8
KW		 2282/*
2283
51b56f5c 2284=for apidoc_section Locales
9aac5db8
KW		 2285
2286=for apidoc Perl_setlocale
2287
2288This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
2289taking the same parameters, and returning the same information, except that it
9487427b
KW		 2290returns the correct underlying C<LC_NUMERIC> locale. Regular C<setlocale> will
2291instead return C<C> if the underlying locale has a non-dot decimal point
2292character, or a non-empty thousands separator for displaying floating point
2293numbers. This is because perl keeps that locale category such that it has a
2294dot and empty separator, changing the locale briefly during the operations
2295where the underlying one is required. C<Perl_setlocale> knows about this, and
2296compensates; regular C<setlocale> doesn't.
9aac5db8 2297
e9bc6d6b 2298Another reason it isn't completely a drop-in replacement is that it is
9aac5db8 2299declared to return S<C<const char *>>, whereas the system setlocale omits the
163deff3
KW		 2300C<const> (presumably because its API was specified long ago, and can't be
2301updated; it is illegal to change the information C<setlocale> returns; doing
2302so leads to segfaults.)
9aac5db8 2303
e9bc6d6b
KW		 2304Finally, C<Perl_setlocale> works under all circumstances, whereas plain
2305C<setlocale> can be completely ineffective on some platforms under some
2306configurations.
2307
9aac5db8 2308C<Perl_setlocale> should not be used to change the locale except on systems
e9bc6d6b
KW		 2309where the predefined variable C<${^SAFE_LOCALES}> is 1. On some such systems,
2310the system C<setlocale()> is ineffective, returning the wrong information, and
2311failing to actually change the locale. C<Perl_setlocale>, however works
2312properly in all circumstances.
9aac5db8
KW		 2313
2314The return points to a per-thread static buffer, which is overwritten the next
2315time C<Perl_setlocale> is called from the same thread.
2316
2317=cut
2318
2319*/
2320
2321const char *
2322Perl_setlocale(const int category, const char * locale)
a4f00dcc
KW		 2323{
2324 /* This wraps POSIX::setlocale() */
2325
52129632 2326#ifndef USE_LOCALE
d36adde0
KW		 2327
2328 PERL_UNUSED_ARG(category);
2329 PERL_UNUSED_ARG(locale);
2330
2331 return "C";
2332
2333#else
2334
9aac5db8
KW		 2335 const char * retval;
2336 const char * newlocale;
2337 dSAVEDERRNO;
a4f00dcc 2338 dTHX;
d36adde0 2339 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
a4f00dcc 2340
a4f00dcc
KW		 2341#ifdef USE_LOCALE_NUMERIC
2342
291a84fb
KW		 2343 /* A NULL locale means only query what the current one is. We have the
2344 * LC_NUMERIC name saved, because we are normally switched into the C
9487427b
KW		 2345 * (or equivalent) locale for it. For an LC_ALL query, switch back to get
2346 * the correct results. All other categories don't require special
2347 * handling */
a4f00dcc
KW		 2348 if (locale == NULL) {
2349 if (category == LC_NUMERIC) {
9aac5db8
KW		 2350
2351 /* We don't have to copy this return value, as it is a per-thread
2352 * variable, and won't change until a future setlocale */
2353 return PL_numeric_name;
a4f00dcc
KW		 2354 }
2355
7d4bcc4a 2356# ifdef LC_ALL
a4f00dcc 2357
9aac5db8
KW		 2358 else if (category == LC_ALL) {
2359 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
a4f00dcc
KW		 2360 }
2361
7d4bcc4a 2362# endif
a4f00dcc
KW		 2363
2364 }
2365
2366#endif
2367
33e5a354
KW		 2368 retval = save_to_buffer(do_setlocale_r(category, locale),
2369 &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
9aac5db8
KW		 2370 SAVE_ERRNO;
2371
2372#if defined(USE_LOCALE_NUMERIC) && defined(LC_ALL)
2373
2374 if (locale == NULL && category == LC_ALL) {
2375 RESTORE_LC_NUMERIC();
2376 }
2377
2378#endif
a4f00dcc
KW		 2379
2380 DEBUG_L(PerlIO_printf(Perl_debug_log,
2381 "%s:%d: %s\n", __FILE__, __LINE__,
2382 setlocale_debug_string(category, locale, retval)));
7d4bcc4a 2383
9aac5db8
KW		 2384 RESTORE_ERRNO;
2385
2386 if (! retval) {
a4f00dcc
KW		 2387 return NULL;
2388 }
2389
9aac5db8 2390 /* If locale == NULL, we are just querying the state */
a4f00dcc 2391 if (locale == NULL) {
a4f00dcc
KW		 2392 return retval;
2393 }
a4f00dcc 2394
1159483a
KW		 2395 /* Now that have switched locales, we have to update our records to
2396 * correspond. */
a4f00dcc 2397
1159483a 2398 switch (category) {
a4f00dcc 2399
1159483a 2400#ifdef USE_LOCALE_CTYPE
a4f00dcc 2401
1159483a
KW		 2402 case LC_CTYPE:
2403 new_ctype(retval);
2404 break;
a4f00dcc 2405
1159483a 2406#endif
a4f00dcc
KW		 2407#ifdef USE_LOCALE_COLLATE
2408
1159483a
KW		 2409 case LC_COLLATE:
2410 new_collate(retval);
2411 break;
a4f00dcc 2412
1159483a 2413#endif
a4f00dcc
KW		 2414#ifdef USE_LOCALE_NUMERIC
2415
1159483a
KW		 2416 case LC_NUMERIC:
2417 new_numeric(retval);
2418 break;
a4f00dcc 2419
1159483a
KW		 2420#endif
2421#ifdef LC_ALL
a4f00dcc 2422
1159483a 2423 case LC_ALL:
a4f00dcc 2424
1159483a
KW		 2425 /* LC_ALL updates all the things we care about. The values may not
2426 * be the same as 'retval', as the locale "" may have set things
2427 * individually */
a4f00dcc 2428
1159483a 2429# ifdef USE_LOCALE_CTYPE
a4f00dcc 2430
b0bde642 2431 newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
1159483a 2432 new_ctype(newlocale);
b0bde642 2433 Safefree(newlocale);
a4f00dcc 2434
1159483a
KW		 2435# endif /* USE_LOCALE_CTYPE */
2436# ifdef USE_LOCALE_COLLATE
2437
b0bde642 2438 newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
1159483a 2439 new_collate(newlocale);
b0bde642 2440 Safefree(newlocale);
a4f00dcc 2441
7d4bcc4a 2442# endif
1159483a 2443# ifdef USE_LOCALE_NUMERIC
a4f00dcc 2444
b0bde642 2445 newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
1159483a 2446 new_numeric(newlocale);
b0bde642 2447 Safefree(newlocale);
a4f00dcc 2448
1159483a
KW		 2449# endif /* USE_LOCALE_NUMERIC */
2450#endif /* LC_ALL */
a4f00dcc 2451
1159483a
KW		 2452 default:
2453 break;
a4f00dcc
KW		 2454 }
2455
2456 return retval;
2457
d36adde0
KW		 2458#endif
2459
f7416781
KW		 2460}
2461
2462PERL_STATIC_INLINE const char *
2463S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t offset)
2464{
2465 /* Copy the NUL-terminated 'string' to 'buf' + 'offset'. 'buf' has size 'buf_size',
2466 * growing it if necessary */
2467
0b6697c5 2468 Size_t string_size;
f7416781
KW		 2469
2470 PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
2471
0b6697c5
KW		 2472 if (! string) {
2473 return NULL;
2474 }
2475
2476 string_size = strlen(string) + offset + 1;
2477
f7416781
KW		 2478 if (*buf_size == 0) {
2479 Newx(*buf, string_size, char);
2480 *buf_size = string_size;
2481 }
2482 else if (string_size > *buf_size) {
2483 Renew(*buf, string_size, char);
2484 *buf_size = string_size;
2485 }
2486
2487 Copy(string, *buf + offset, string_size - offset, char);
2488 return *buf;
2489}
2490
2491/*
2492
f7416781
KW		 2493=for apidoc Perl_langinfo
2494
ce181bf6 2495This is an (almost) drop-in replacement for the system C<L<nl_langinfo(3)>>,
f7416781
KW		 2496taking the same C<item> parameter values, and returning the same information.
2497But it is more thread-safe than regular C<nl_langinfo()>, and hides the quirks
2498of Perl's locale handling from your code, and can be used on systems that lack
2499a native C<nl_langinfo>.
2500
2501Expanding on these:
2502
2503=over
2504
2505=item *
2506
ce181bf6
KW		 2507The reason it isn't quite a drop-in replacement is actually an advantage. The
2508only difference is that it returns S<C<const char *>>, whereas plain
2509C<nl_langinfo()> returns S<C<char *>>, but you are (only by documentation)
2510forbidden to write into the buffer. By declaring this C<const>, the compiler
2511enforces this restriction, so if it is violated, you know at compilation time,
2512rather than getting segfaults at runtime.
2513
2514=item *
2515
69e2275e 2516It delivers the correct results for the C<RADIXCHAR> and C<THOUSEP> items,
f7416781
KW		 2517without you having to write extra code. The reason for the extra code would be
2518because these are from the C<LC_NUMERIC> locale category, which is normally
9487427b
KW		 2519kept set by Perl so that the radix is a dot, and the separator is the empty
2520string, no matter what the underlying locale is supposed to be, and so to get
2521the expected results, you have to temporarily toggle into the underlying
2522locale, and later toggle back. (You could use plain C<nl_langinfo> and
2523C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this but then you wouldn't get
2524the other advantages of C<Perl_langinfo()>; not keeping C<LC_NUMERIC> in the C
2525(or equivalent) locale would break a lot of CPAN, which is expecting the radix
2526(decimal point) character to be a dot.)
ce181bf6
KW		 2527
2528=item *
2529
2530The system function it replaces can have its static return buffer trashed,
f1460a66 2531not only by a subsequent call to that function, but by a C<freelocale>,
ce181bf6
KW		 2532C<setlocale>, or other locale change. The returned buffer of this function is
2533not changed until the next call to it, so the buffer is never in a trashed
2534state.
f7416781
KW		 2535
2536=item *
2537
ce181bf6
KW		 2538Its return buffer is per-thread, so it also is never overwritten by a call to
2539this function from another thread; unlike the function it replaces.
2540
2541=item *
2542
2543But most importantly, it works on systems that don't have C<nl_langinfo>, such
2544as Windows, hence makes your code more portable. Of the fifty-some possible
2545items specified by the POSIX 2008 standard,
f7416781 2546L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
8d72e74e
KW		 2547only one is completely unimplemented, though on non-Windows platforms, another
2548significant one is also not implemented). It uses various techniques to
2549recover the other items, including calling C<L<localeconv(3)>>, and
2550C<L<strftime(3)>>, both of which are specified in C89, so should be always be
2551available. Later C<strftime()> versions have additional capabilities; C<""> is
2552returned for those not available on your system.
ce181bf6
KW		 2553
2554It is important to note that when called with an item that is recovered by
2555using C<localeconv>, the buffer from any previous explicit call to
2556C<localeconv> will be overwritten. This means you must save that buffer's
c3997e39
KW		 2557contents if you need to access them after a call to this function. (But note
2558that you might not want to be using C<localeconv()> directly anyway, because of
2559issues like the ones listed in the second item of this list (above) for
2560C<RADIXCHAR> and C<THOUSEP>. You can use the methods given in L<perlcall> to
2561call L<POSIX/localeconv> and avoid all the issues, but then you have a hash to
2562unpack).
9f0bc911 2563
6201c220
KW		 2564The details for those items which may deviate from what this emulation returns
2565and what a native C<nl_langinfo()> would return are specified in
2566L<I18N::Langinfo>.
f7416781 2567
ce181bf6
KW		 2568=back
2569
f7416781
KW		 2570When using C<Perl_langinfo> on systems that don't have a native
2571C<nl_langinfo()>, you must
2572
2573 #include "perl_langinfo.h"
2574
2575before the C<perl.h> C<#include>. You can replace your C<langinfo.h>
2576C<#include> with this one. (Doing it this way keeps out the symbols that plain
c3997e39
KW		 2577C<langinfo.h> would try to import into the namespace for code that doesn't need
2578it.)
f7416781 2579
f7416781
KW		 2580The original impetus for C<Perl_langinfo()> was so that code that needs to
2581find out the current currency symbol, floating point radix character, or digit
2582grouping separator can use, on all systems, the simpler and more
2583thread-friendly C<nl_langinfo> API instead of C<L<localeconv(3)>> which is a
2584pain to make thread-friendly. For other fields returned by C<localeconv>, it
2585is better to use the methods given in L<perlcall> to call
2586L<C<POSIX::localeconv()>|POSIX/localeconv>, which is thread-friendly.
2587
2588=cut
2589
2590*/
2591
2592const char *
2593#ifdef HAS_NL_LANGINFO
2594Perl_langinfo(const nl_item item)
2595#else
2596Perl_langinfo(const int item)
2597#endif
2598{
f61748ac
KW		 2599 return my_nl_langinfo(item, TRUE);
2600}
2601
59a15af0 2602STATIC const char *
f61748ac
KW		 2603#ifdef HAS_NL_LANGINFO
2604S_my_nl_langinfo(const nl_item item, bool toggle)
2605#else
2606S_my_nl_langinfo(const int item, bool toggle)
2607#endif
2608{
ae74815b 2609 dTHX;
0b6697c5 2610 const char * retval;
f7416781 2611
d36adde0
KW		 2612#ifdef USE_LOCALE_NUMERIC
2613
5a854ab3
KW		 2614 /* We only need to toggle into the underlying LC_NUMERIC locale for these
2615 * two items, and only if not already there */
4e6826bf 2616 if (toggle && (( item != RADIXCHAR && item != THOUSEP)
5a854ab3 2617 || PL_numeric_underlying))
d36adde0
KW		 2618
2619#endif /* No toggling needed if not using LC_NUMERIC */
2620
5a854ab3 2621 toggle = FALSE;
5a854ab3 2622
ab340fff 2623#if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */
ee90eb2d 2624# if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
80306bb6
KW		 2625 || ! defined(HAS_POSIX_2008_LOCALE) \
2626 || ! defined(DUPLOCALE)
f7416781 2627
ab340fff 2628 /* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
ae74815b
KW		 2629 * for those items dependent on it. This must be copied to a buffer before
2630 * switching back, as some systems destroy the buffer when setlocale() is
2631 * called */
f7416781 2632
038d3702
KW		 2633 {
2634 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2635
b2fee59c 2636 if (toggle) {
038d3702 2637 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
b2fee59c 2638 }
f7416781 2639
5acc4454
KW		 2640 LOCALE_LOCK; /* Prevent interference from another thread executing
2641 this code section (the only call to nl_langinfo in
2642 the core) */
2643
ee90eb2d 2644
628ff75a
KW		 2645 /* Copy to a per-thread buffer, which is also one that won't be
2646 * destroyed by a subsequent setlocale(), such as the
2647 * RESTORE_LC_NUMERIC may do just below. */
0b6697c5
KW		 2648 retval = save_to_buffer(nl_langinfo(item),
2649 &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
f7416781 2650
5acc4454
KW		 2651 LOCALE_UNLOCK;
2652
b2fee59c 2653 if (toggle) {
038d3702 2654 RESTORE_LC_NUMERIC();
b2fee59c 2655 }
f7416781
KW		 2656 }
2657
ab340fff
KW		 2658# else /* Use nl_langinfo_l(), avoiding both a mutex and changing the locale */
2659
5a854ab3 2660 {
b2fee59c
KW		 2661 bool do_free = FALSE;
2662 locale_t cur = uselocale((locale_t) 0);
ab340fff 2663
b2fee59c
KW		 2664 if (cur == LC_GLOBAL_LOCALE) {
2665 cur = duplocale(LC_GLOBAL_LOCALE);
2666 do_free = TRUE;
2667 }
ab340fff 2668
d36adde0
KW		 2669# ifdef USE_LOCALE_NUMERIC
2670
b2fee59c 2671 if (toggle) {
e1aa2579
KW		 2672 if (PL_underlying_numeric_obj) {
2673 cur = PL_underlying_numeric_obj;
2674 }
2675 else {
2676 cur = newlocale(LC_NUMERIC_MASK, PL_numeric_name, cur);
2677 do_free = TRUE;
2678 }
b2fee59c 2679 }
ab340fff 2680
d36adde0
KW		 2681# endif
2682
628ff75a
KW		 2683 /* We have to save it to a buffer, because the freelocale() just below
2684 * can invalidate the internal one */
0b6697c5
KW		 2685 retval = save_to_buffer(nl_langinfo_l(item, cur),
2686 &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
ee90eb2d 2687
b2fee59c
KW		 2688 if (do_free) {
2689 freelocale(cur);
2690 }
5a854ab3 2691 }
ab340fff 2692
c1566110
KW		 2693# endif
2694
0b6697c5 2695 if (strEQ(retval, "")) {
4e6826bf 2696 if (item == YESSTR) {
c1566110
KW		 2697 return "yes";
2698 }
4e6826bf 2699 if (item == NOSTR) {
c1566110
KW		 2700 return "no";
2701 }
2702 }
2703
0b6697c5 2704 return retval;
ab340fff 2705
f7416781 2706#else /* Below, emulate nl_langinfo as best we can */
43dd6b15
KW		 2707
2708 {
2709
f7416781
KW		 2710# ifdef HAS_LOCALECONV
2711
43dd6b15 2712 const struct lconv* lc;
628ff75a 2713 const char * temp;
038d3702 2714 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
f7416781 2715
69c5e0db
KW		 2716# ifdef TS_W32_BROKEN_LOCALECONV
2717
2718 const char * save_global;
2719 const char * save_thread;
2720 int needed_size;
2721 char * ptr;
2722 char * e;
2723 char * item_start;
2724
2725# endif
f7416781
KW		 2726# endif
2727# ifdef HAS_STRFTIME
2728
43dd6b15
KW		 2729 struct tm tm;
2730 bool return_format = FALSE; /* Return the %format, not the value */
2731 const char * format;
f7416781
KW		 2732
2733# endif
2734
43dd6b15
KW		 2735 /* We copy the results to a per-thread buffer, even if not
2736 * multi-threaded. This is in part to simplify this code, and partly
2737 * because we need a buffer anyway for strftime(), and partly because a
2738 * call of localeconv() could otherwise wipe out the buffer, and the
2739 * programmer would not be expecting this, as this is a nl_langinfo()
2740 * substitute after all, so s/he might be thinking their localeconv()
2741 * is safe until another localeconv() call. */
f7416781 2742
43dd6b15
KW		 2743 switch (item) {
2744 Size_t len;
f7416781 2745
8d72e74e 2746 /* This is unimplemented */
4e6826bf 2747 case ERA: /* For use with strftime() %E modifier */
f7416781 2748
43dd6b15
KW		 2749 default:
2750 return "";
f7416781 2751
43dd6b15 2752 /* We use only an English set, since we don't know any more */
4e6826bf
KW		 2753 case YESEXPR: return "^[+1yY]";
2754 case YESSTR: return "yes";
2755 case NOEXPR: return "^[-0nN]";
2756 case NOSTR: return "no";
2757
8d72e74e
KW		 2758 case CODESET:
2759
2760# ifndef WIN32
2761
2762 /* On non-windows, this is unimplemented, in part because of
2763 * inconsistencies between vendors. The Darwin native
2764 * nl_langinfo() implementation simply looks at everything past
2765 * any dot in the name, but that doesn't work for other
2766 * vendors. Many Linux locales that don't have UTF-8 in their
2767 * names really are UTF-8, for example; z/OS locales that do
2768 * have UTF-8 in their names, aren't really UTF-8 */
2769 return "";
2770
2771# else
2772
2773 { /* But on Windows, the name does seem to be consistent, so
2774 use that. */
2775 const char * p;
2776 const char * first;
2777 Size_t offset = 0;
2778 const char * name = my_setlocale(LC_CTYPE, NULL);
2779
2780 if (isNAME_C_OR_POSIX(name)) {
2781 return "ANSI_X3.4-1968";
2782 }
2783
2784 /* Find the dot in the locale name */
2785 first = (const char *) strchr(name, '.');
2786 if (! first) {
2787 first = name;
2788 goto has_nondigit;
2789 }
2790
2791 /* Look at everything past the dot */
2792 first++;
2793 p = first;
2794
2795 while (*p) {
2796 if (! isDIGIT(*p)) {
2797 goto has_nondigit;
2798 }
2799
2800 p++;
2801 }
2802
2803 /* Here everything past the dot is a digit. Treat it as a
2804 * code page */
18503cbd 2805 retval = save_to_buffer("CP", &PL_langinfo_buf,
32a62865 2806 &PL_langinfo_bufsize, 0);
8d72e74e 2807 offset = STRLENs("CP");
f7416781 2808
8d72e74e
KW		 2809 has_nondigit:
2810
2811 retval = save_to_buffer(first, &PL_langinfo_buf,
2812 &PL_langinfo_bufsize, offset);
2813 }
2814
2815 break;
2816
2817# endif
f7416781
KW		 2818# ifdef HAS_LOCALECONV
2819
4e6826bf 2820 case CRNCYSTR:
f7416781 2821
43dd6b15
KW		 2822 /* We don't bother with localeconv_l() because any system that
2823 * has it is likely to also have nl_langinfo() */
291a84fb 2824
69c5e0db
KW		 2825 LOCALE_LOCK_V; /* Prevent interference with other threads
2826 using localeconv() */
2827
2828# ifdef TS_W32_BROKEN_LOCALECONV
2829
2830 /* This is a workaround for a Windows bug prior to VS 15.
2831 * What we do here is, while locked, switch to the global
2832 * locale so localeconv() works; then switch back just before
2833 * the unlock. This can screw things up if some thread is
2834 * already using the global locale while assuming no other is.
2835 * A different workaround would be to call GetCurrencyFormat on
2836 * a known value, and parse it; patches welcome
2837 *
2838 * We have to use LC_ALL instead of LC_MONETARY because of
2839 * another bug in Windows */
2840
2841 save_thread = savepv(my_setlocale(LC_ALL, NULL));
2842 _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
2843 save_global= savepv(my_setlocale(LC_ALL, NULL));
2844 my_setlocale(LC_ALL, save_thread);
2845
2846# endif
5acc4454 2847
43dd6b15
KW		 2848 lc = localeconv();
2849 if ( ! lc
2850 || ! lc->currency_symbol
2851 || strEQ("", lc->currency_symbol))
2852 {
69c5e0db 2853 LOCALE_UNLOCK_V;
43dd6b15
KW		 2854 return "";
2855 }
f7416781 2856
43dd6b15 2857 /* Leave the first spot empty to be filled in below */
0b6697c5
KW		 2858 retval = save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
2859 &PL_langinfo_bufsize, 1);
43dd6b15
KW		 2860 if (lc->mon_decimal_point && strEQ(lc->mon_decimal_point, ""))
2861 { /* khw couldn't figure out how the localedef specifications
2862 would show that the $ should replace the radix; this is
2863 just a guess as to how it might work.*/
a34edee3 2864 PL_langinfo_buf[0] = '.';
43dd6b15
KW		 2865 }
2866 else if (lc->p_cs_precedes) {
a34edee3 2867 PL_langinfo_buf[0] = '-';
43dd6b15
KW		 2868 }
2869 else {
a34edee3 2870 PL_langinfo_buf[0] = '+';
43dd6b15 2871 }
f7416781 2872
69c5e0db
KW		 2873# ifdef TS_W32_BROKEN_LOCALECONV
2874
2875 my_setlocale(LC_ALL, save_global);
2876 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
2877 my_setlocale(LC_ALL, save_thread);
2878 Safefree(save_global);
2879 Safefree(save_thread);
2880
2881# endif
2882
2883 LOCALE_UNLOCK_V;
43dd6b15 2884 break;
f7416781 2885
69c5e0db
KW		 2886# ifdef TS_W32_BROKEN_LOCALECONV
2887
4e6826bf 2888 case RADIXCHAR:
69c5e0db
KW		 2889
2890 /* For this, we output a known simple floating point number to
2891 * a buffer, and parse it, looking for the radix */
2892
2893 if (toggle) {
2894 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2895 }
2896
2897 if (PL_langinfo_bufsize < 10) {
2898 PL_langinfo_bufsize = 10;
2899 Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
2900 }
2901
2902 needed_size = my_snprintf(PL_langinfo_buf, PL_langinfo_bufsize,
2903 "%.1f", 1.5);
2904 if (needed_size >= (int) PL_langinfo_bufsize) {
2905 PL_langinfo_bufsize = needed_size + 1;
2906 Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
2907 needed_size = my_snprintf(PL_langinfo_buf, PL_langinfo_bufsize,
2908 "%.1f", 1.5);
2909 assert(needed_size < (int) PL_langinfo_bufsize);
2910 }
2911
2912 ptr = PL_langinfo_buf;
2913 e = PL_langinfo_buf + PL_langinfo_bufsize;
2914
2915 /* Find the '1' */
2916 while (ptr < e && *ptr != '1') {
2917 ptr++;
2918 }
2919 ptr++;
2920
2921 /* Find the '5' */
2922 item_start = ptr;
2923 while (ptr < e && *ptr != '5') {
2924 ptr++;
2925 }
2926
2927 /* Everything in between is the radix string */
2928 if (ptr >= e) {
2929 PL_langinfo_buf[0] = '?';
2930 PL_langinfo_buf[1] = '\0';
2931 }
2932 else {
2933 *ptr = '\0';
2934 Move(item_start, PL_langinfo_buf, ptr - PL_langinfo_buf, char);
2935 }
2936
2937 if (toggle) {
2938 RESTORE_LC_NUMERIC();
2939 }
2940
2941 retval = PL_langinfo_buf;
2942 break;
2943
2944# else
2945
2946 case RADIXCHAR: /* No special handling needed */
2947
2948# endif
2949
4e6826bf 2950 case THOUSEP:
f7416781 2951
43dd6b15 2952 if (toggle) {
038d3702 2953 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
c0d737a8 2954 }
f7416781 2955
69c5e0db
KW		 2956 LOCALE_LOCK_V; /* Prevent interference with other threads
2957 using localeconv() */
2958
2959# ifdef TS_W32_BROKEN_LOCALECONV
2960
2961 /* This should only be for the thousands separator. A
2962 * different work around would be to use GetNumberFormat on a
2963 * known value and parse the result to find the separator */
2964 save_thread = savepv(my_setlocale(LC_ALL, NULL));
2965 _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
2966 save_global = savepv(my_setlocale(LC_ALL, NULL));
2967 my_setlocale(LC_ALL, save_thread);
2968# if 0
2969 /* This is the start of code that for broken Windows replaces
2970 * the above and below code, and instead calls
2971 * GetNumberFormat() and then would parse that to find the
2972 * thousands separator. It needs to handle UTF-16 vs -8
2973 * issues. */
2974
2975 needed_size = GetNumberFormatEx(PL_numeric_name, 0, "1234.5", NULL, PL_langinfo_buf, PL_langinfo_bufsize);
2976 DEBUG_L(PerlIO_printf(Perl_debug_log,
2977 "%s: %d: return from GetNumber, count=%d, val=%s\n",
2978 __FILE__, __LINE__, needed_size, PL_langinfo_buf));
2979
2980# endif
2981# endif
5acc4454 2982
43dd6b15
KW		 2983 lc = localeconv();
2984 if (! lc) {
628ff75a 2985 temp = "";
33394adc 2986 }
43dd6b15 2987 else {
4e6826bf 2988 temp = (item == RADIXCHAR)
43dd6b15
KW		 2989 ? lc->decimal_point
2990 : lc->thousands_sep;
628ff75a
KW		 2991 if (! temp) {
2992 temp = "";
43dd6b15
KW		 2993 }
2994 }
f7416781 2995
0b6697c5
KW		 2996 retval = save_to_buffer(temp, &PL_langinfo_buf,
2997 &PL_langinfo_bufsize, 0);
f7416781 2998
69c5e0db
KW		 2999# ifdef TS_W32_BROKEN_LOCALECONV
3000
3001 my_setlocale(LC_ALL, save_global);
3002 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
3003 my_setlocale(LC_ALL, save_thread);
3004 Safefree(save_global);
3005 Safefree(save_thread);
3006
3007# endif
3008
3009 LOCALE_UNLOCK_V;
5acc4454 3010
43dd6b15 3011 if (toggle) {
038d3702 3012 RESTORE_LC_NUMERIC();
43dd6b15 3013 }
f7416781 3014
43dd6b15 3015 break;
f7416781
KW		 3016
3017# endif
3018# ifdef HAS_STRFTIME
3019
43dd6b15
KW		 3020 /* These are defined by C89, so we assume that strftime supports
3021 * them, and so are returned unconditionally; they may not be what
3022 * the locale actually says, but should give good enough results
3023 * for someone using them as formats (as opposed to trying to parse
3024 * them to figure out what the locale says). The other format
3025 * items are actually tested to verify they work on the platform */
4e6826bf
KW		 3026 case D_FMT: return "%x";
3027 case T_FMT: return "%X";
3028 case D_T_FMT: return "%c";
43dd6b15
KW		 3029
3030 /* These formats are only available in later strfmtime's */
4e6826bf 3031 case ERA_D_FMT: case ERA_T_FMT: case ERA_D_T_FMT: case T_FMT_AMPM:
43dd6b15
KW		 3032
3033 /* The rest can be gotten from most versions of strftime(). */
4e6826bf
KW		 3034 case ABDAY_1: case ABDAY_2: case ABDAY_3:
3035 case ABDAY_4: case ABDAY_5: case ABDAY_6: case ABDAY_7:
3036 case ALT_DIGITS:
3037 case AM_STR: case PM_STR:
3038 case ABMON_1: case ABMON_2: case ABMON_3: case ABMON_4:
3039 case ABMON_5: case ABMON_6: case ABMON_7: case ABMON_8:
3040 case ABMON_9: case ABMON_10: case ABMON_11: case ABMON_12:
3041 case DAY_1: case DAY_2: case DAY_3: case DAY_4:
3042 case DAY_5: case DAY_6: case DAY_7:
3043 case MON_1: case MON_2: case MON_3: case MON_4:
3044 case MON_5: case MON_6: case MON_7: case MON_8:
3045 case MON_9: case MON_10: case MON_11: case MON_12:
43dd6b15
KW		 3046
3047 LOCALE_LOCK;
3048
3049 init_tm(&tm); /* Precaution against core dumps */
3050 tm.tm_sec = 30;
3051 tm.tm_min = 30;
3052 tm.tm_hour = 6;
3053 tm.tm_year = 2017 - 1900;
3054 tm.tm_wday = 0;
3055 tm.tm_mon = 0;
3056 switch (item) {
3057 default:
3058 LOCALE_UNLOCK;
3059 Perl_croak(aTHX_
3060 "panic: %s: %d: switch case: %d problem",
3061 __FILE__, __LINE__, item);
3062 NOT_REACHED; /* NOTREACHED */
3063
4e6826bf
KW		 3064 case PM_STR: tm.tm_hour = 18;
3065 case AM_STR:
43dd6b15
KW		 3066 format = "%p";
3067 break;
3068
4e6826bf
KW		 3069 case ABDAY_7: tm.tm_wday++;
3070 case ABDAY_6: tm.tm_wday++;
3071 case ABDAY_5: tm.tm_wday++;
3072 case ABDAY_4: tm.tm_wday++;
3073 case ABDAY_3: tm.tm_wday++;
3074 case ABDAY_2: tm.tm_wday++;
3075 case ABDAY_1:
43dd6b15
KW		 3076 format = "%a";
3077 break;
3078
4e6826bf
KW		 3079 case DAY_7: tm.tm_wday++;
3080 case DAY_6: tm.tm_wday++;
3081 case DAY_5: tm.tm_wday++;
3082 case DAY_4: tm.tm_wday++;
3083 case DAY_3: tm.tm_wday++;
3084 case DAY_2: tm.tm_wday++;
3085 case DAY_1:
43dd6b15
KW		 3086 format = "%A";
3087 break;
3088
4e6826bf
KW		 3089 case ABMON_12: tm.tm_mon++;
3090 case ABMON_11: tm.tm_mon++;
3091 case ABMON_10: tm.tm_mon++;
3092 case ABMON_9: tm.tm_mon++;
3093 case ABMON_8: tm.tm_mon++;
3094 case ABMON_7: tm.tm_mon++;
3095 case ABMON_6: tm.tm_mon++;
3096 case ABMON_5: tm.tm_mon++;
3097 case ABMON_4: tm.tm_mon++;
3098 case ABMON_3: tm.tm_mon++;
3099 case ABMON_2: tm.tm_mon++;
3100 case ABMON_1:
43dd6b15
KW		 3101 format = "%b";
3102 break;
3103
4e6826bf
KW		 3104 case MON_12: tm.tm_mon++;
3105 case MON_11: tm.tm_mon++;
3106 case MON_10: tm.tm_mon++;
3107 case MON_9: tm.tm_mon++;
3108 case MON_8: tm.tm_mon++;
3109 case MON_7: tm.tm_mon++;
3110 case MON_6: tm.tm_mon++;
3111 case MON_5: tm.tm_mon++;
3112 case MON_4: tm.tm_mon++;
3113 case MON_3: tm.tm_mon++;
3114 case MON_2: tm.tm_mon++;
3115 case MON_1:
43dd6b15
KW		 3116 format = "%B";
3117 break;
3118
4e6826bf 3119 case T_FMT_AMPM:
43dd6b15
KW		 3120 format = "%r";
3121 return_format = TRUE;
3122 break;
3123
4e6826bf 3124 case ERA_D_FMT:
43dd6b15
KW		 3125 format = "%Ex";
3126 return_format = TRUE;
3127 break;
3128
4e6826bf 3129 case ERA_T_FMT:
43dd6b15
KW		 3130 format = "%EX";
3131 return_format = TRUE;
3132 break;
3133
4e6826bf 3134 case ERA_D_T_FMT:
43dd6b15
KW		 3135 format = "%Ec";
3136 return_format = TRUE;
3137 break;
3138
4e6826bf 3139 case ALT_DIGITS:
43dd6b15
KW		 3140 tm.tm_wday = 0;
3141 format = "%Ow"; /* Find the alternate digit for 0 */
3142 break;
3143 }
f7416781 3144
43dd6b15
KW		 3145 /* We can't use my_strftime() because it doesn't look at
3146 * tm_wday */
3147 while (0 == strftime(PL_langinfo_buf, PL_langinfo_bufsize,
3148 format, &tm))
3149 {
3150 /* A zero return means one of:
3151 * a) there wasn't enough space in PL_langinfo_buf
3152 * b) the format, like a plain %p, returns empty
3153 * c) it was an illegal format, though some
3154 * implementations of strftime will just return the
3155 * illegal format as a plain character sequence.
3156 *
3157 * To quickly test for case 'b)', try again but precede
3158 * the format with a plain character. If that result is
3159 * still empty, the problem is either 'a)' or 'c)' */
3160
3161 Size_t format_size = strlen(format) + 1;
3162 Size_t mod_size = format_size + 1;
3163 char * mod_format;
3164 char * temp_result;
3165
3166 Newx(mod_format, mod_size, char);
3167 Newx(temp_result, PL_langinfo_bufsize, char);
6873aa47 3168 *mod_format = ' ';
43dd6b15
KW		 3169 my_strlcpy(mod_format + 1, format, mod_size);
3170 len = strftime(temp_result,
3171 PL_langinfo_bufsize,
3172 mod_format, &tm);
3173 Safefree(mod_format);
3174 Safefree(temp_result);
3175
3176 /* If 'len' is non-zero, it means that we had a case like
3177 * %p which means the current locale doesn't use a.m. or
3178 * p.m., and that is valid */
3179 if (len == 0) {
3180
3181 /* Here, still didn't work. If we get well beyond a
3182 * reasonable size, bail out to prevent an infinite
3183 * loop. */
3184
3185 if (PL_langinfo_bufsize > 100 * format_size) {
3186 *PL_langinfo_buf = '\0';
3187 }
3188 else {
3189 /* Double the buffer size to retry; Add 1 in case
3190 * original was 0, so we aren't stuck at 0. */
3191 PL_langinfo_bufsize *= 2;
3192 PL_langinfo_bufsize++;
3193 Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
3194 continue;
3195 }
3196 }
f7416781 3197
f7416781 3198 break;
43dd6b15 3199 }
f7416781 3200
43dd6b15
KW		 3201 /* Here, we got a result.
3202 *
3203 * If the item is 'ALT_DIGITS', PL_langinfo_buf contains the
3204 * alternate format for wday 0. If the value is the same as
3205 * the normal 0, there isn't an alternate, so clear the buffer.
3206 * */
4e6826bf 3207 if ( item == ALT_DIGITS
43dd6b15
KW		 3208 && strEQ(PL_langinfo_buf, "0"))
3209 {
3210 *PL_langinfo_buf = '\0';
3211 }
f7416781 3212
43dd6b15
KW		 3213 /* ALT_DIGITS is problematic. Experiments on it showed that
3214 * strftime() did not always work properly when going from
3215 * alt-9 to alt-10. Only a few locales have this item defined,
3216 * and in all of them on Linux that khw was able to find,
3217 * nl_langinfo() merely returned the alt-0 character, possibly
3218 * doubled. Most Unicode digits are in blocks of 10
3219 * consecutive code points, so that is sufficient information
3220 * for those scripts, as we can infer alt-1, alt-2, .... But
3221 * for a Japanese locale, a CJK ideographic 0 is returned, and
3222 * the CJK digits are not in code point order, so you can't
3223 * really infer anything. The localedef for this locale did
3224 * specify the succeeding digits, so that strftime() works
3225 * properly on them, without needing to infer anything. But
3226 * the nl_langinfo() return did not give sufficient information
3227 * for the caller to understand what's going on. So until
3228 * there is evidence that it should work differently, this
3229 * returns the alt-0 string for ALT_DIGITS.
3230 *
3231 * wday was chosen because its range is all a single digit.
3232 * Things like tm_sec have two digits as the minimum: '00' */
f7416781 3233
43dd6b15 3234 LOCALE_UNLOCK;
f7416781 3235
d1b150d9
KW		 3236 retval = PL_langinfo_buf;
3237
43dd6b15
KW		 3238 /* If to return the format, not the value, overwrite the buffer
3239 * with it. But some strftime()s will keep the original format
3240 * if illegal, so change those to "" */
3241 if (return_format) {
3242 if (strEQ(PL_langinfo_buf, format)) {
f7416781
KW		 3243 *PL_langinfo_buf = '\0';
3244 }
43dd6b15 3245 else {
0b6697c5
KW		 3246 retval = save_to_buffer(format, &PL_langinfo_buf,
3247 &PL_langinfo_bufsize, 0);
f7416781
KW		 3248 }
3249 }
3250
3251 break;
f7416781
KW		 3252
3253# endif
3254
43dd6b15 3255 }
f7416781
KW		 3256 }
3257
0b6697c5 3258 return retval;
f7416781
KW		 3259
3260#endif
3261
a4f00dcc 3262}
b385bb4d 3263
98994639
HS		 3264/*
3265 * Initialize locale awareness.
3266 */
3267int
3268Perl_init_i18nl10n(pTHX_ int printwarn)
3269{
0e92a118
KW		 3270 /* printwarn is
3271 *
3272 * 0 if not to output warning when setup locale is bad
3273 * 1 if to output warning based on value of PERL_BADLANG
3274 * >1 if to output regardless of PERL_BADLANG
3275 *
3276 * returns
98994639 3277 * 1 = set ok or not applicable,
0e92a118
KW		 3278 * 0 = fallback to a locale of lower priority
3279 * -1 = fallback to all locales failed, not even to the C locale
6b058d42
KW		 3280 *
3281 * Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
3282 * set, debugging information is output.
3283 *
3284 * This looks more complicated than it is, mainly due to the #ifdefs.
3285 *
3286 * We try to set LC_ALL to the value determined by the environment. If
3287 * there is no LC_ALL on this platform, we try the individual categories we
3288 * know about. If this works, we are done.
3289 *
3290 * But if it doesn't work, we have to do something else. We search the
3291 * environment variables ourselves instead of relying on the system to do
3292 * it. We look at, in order, LC_ALL, LANG, a system default locale (if we
3293 * think there is one), and the ultimate fallback "C". This is all done in
3294 * the same loop as above to avoid duplicating code, but it makes things
7d4bcc4a
KW		 3295 * more complex. The 'trial_locales' array is initialized with just one
3296 * element; it causes the behavior described in the paragraph above this to
3297 * happen. If that fails, we add elements to 'trial_locales', and do extra
3298 * loop iterations to cause the behavior described in this paragraph.
6b058d42
KW		 3299 *
3300 * On Ultrix, the locale MUST come from the environment, so there is
3301 * preliminary code to set it. I (khw) am not sure that it is necessary,
3302 * and that this couldn't be folded into the loop, but barring any real
3303 * platforms to test on, it's staying as-is
3304 *
3305 * A slight complication is that in embedded Perls, the locale may already
3306 * be set-up, and we don't want to get it from the normal environment
3307 * variables. This is handled by having a special environment variable
3308 * indicate we're in this situation. We simply set setlocale's 2nd
3309 * parameter to be a NULL instead of "". That indicates to setlocale that
3310 * it is not to change anything, but to return the current value,
3311 * effectively initializing perl's db to what the locale already is.
3312 *
3313 * We play the same trick with NULL if a LC_ALL succeeds. We call
3314 * setlocale() on the individual categores with NULL to get their existing
3315 * values for our db, instead of trying to change them.
3316 * */
98994639 3317
1565c085 3318
0e92a118
KW		 3319 int ok = 1;
3320
7d4bcc4a
KW		 3321#ifndef USE_LOCALE
3322
3323 PERL_UNUSED_ARG(printwarn);
3324
3325#else /* USE_LOCALE */
7d4bcc4a
KW		 3326# ifdef __GLIBC__
3327
24f3e849 3328 const char * const language = PerlEnv_getenv("LANGUAGE");
7d4bcc4a
KW		 3329
3330# endif
65ebb059 3331
ccd65d51
KW		 3332 /* NULL uses the existing already set up locale */
3333 const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
3334 ? NULL
3335 : "";
c3fcd832
KW		 3336 const char* trial_locales[5]; /* 5 = 1 each for "", LC_ALL, LANG, "", C */
3337 unsigned int trial_locales_count;
24f3e849
KW		 3338 const char * const lc_all = PerlEnv_getenv("LC_ALL");
3339 const char * const lang = PerlEnv_getenv("LANG");
98994639 3340 bool setlocale_failure = FALSE;
65ebb059 3341 unsigned int i;
175c4cf9
KW		 3342
3343 /* A later getenv() could zap this, so only use here */
3344 const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
3345
3346 const bool locwarn = (printwarn > 1
e5f10d49
KW		 3347 || ( printwarn
3348 && ( ! bad_lang_use_once
22ff3130 3349 || (
e5f10d49
KW		 3350 /* disallow with "" or "0" */
3351 *bad_lang_use_once
3352 && strNE("0", bad_lang_use_once)))));
ea92aad8 3353
291a84fb 3354 /* setlocale() return vals; not copied so must be looked at immediately */
8de4332b 3355 const char * sl_result[NOMINAL_LC_ALL_INDEX + 1];
291a84fb
KW		 3356
3357 /* current locale for given category; should have been copied so aren't
3358 * volatile */
8de4332b 3359 const char * curlocales[NOMINAL_LC_ALL_INDEX + 1];
291a84fb 3360
7d4bcc4a
KW		 3361# ifdef WIN32
3362
6bce99ee
JH		 3363 /* In some systems you can find out the system default locale
3364 * and use that as the fallback locale. */
7d4bcc4a
KW		 3365# define SYSTEM_DEFAULT_LOCALE
3366# endif
3367# ifdef SYSTEM_DEFAULT_LOCALE
3368
65ebb059 3369 const char *system_default_locale = NULL;
98994639 3370
7d4bcc4a 3371# endif
948523db
KW		 3372
3373# ifndef DEBUGGING
3374# define DEBUG_LOCALE_INIT(a,b,c)
3375# else
7d4bcc4a 3376
8298454c 3377 DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
7d4bcc4a
KW		 3378
3379# define DEBUG_LOCALE_INIT(category, locale, result) \
2fcc0ca9
KW		 3380 STMT_START { \
3381 if (debug_initialization) { \
3382 PerlIO_printf(Perl_debug_log, \
3383 "%s:%d: %s\n", \
3384 __FILE__, __LINE__, \
a4f00dcc 3385 setlocale_debug_string(category, \
2fcc0ca9
KW		 3386 locale, \
3387 result)); \
3388 } \
3389 } STMT_END
2fcc0ca9 3390
948523db
KW		 3391/* Make sure the parallel arrays are properly set up */
3392# ifdef USE_LOCALE_NUMERIC
3393 assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
3394 assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
e9bc6d6b
KW		 3395# ifdef USE_POSIX_2008_LOCALE
3396 assert(category_masks[LC_NUMERIC_INDEX] == LC_NUMERIC_MASK);
3397# endif
948523db
KW		 3398# endif
3399# ifdef USE_LOCALE_CTYPE
3400 assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
3401 assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
e9bc6d6b
KW		 3402# ifdef USE_POSIX_2008_LOCALE
3403 assert(category_masks[LC_CTYPE_INDEX] == LC_CTYPE_MASK);
3404# endif
948523db
KW		 3405# endif
3406# ifdef USE_LOCALE_COLLATE
3407 assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
3408 assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
e9bc6d6b
KW		 3409# ifdef USE_POSIX_2008_LOCALE
3410 assert(category_masks[LC_COLLATE_INDEX] == LC_COLLATE_MASK);
3411# endif
948523db
KW		 3412# endif
3413# ifdef USE_LOCALE_TIME
3414 assert(categories[LC_TIME_INDEX] == LC_TIME);
3415 assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
e9bc6d6b
KW		 3416# ifdef USE_POSIX_2008_LOCALE
3417 assert(category_masks[LC_TIME_INDEX] == LC_TIME_MASK);
3418# endif
948523db
KW		 3419# endif
3420# ifdef USE_LOCALE_MESSAGES
3421 assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
3422 assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
e9bc6d6b
KW		 3423# ifdef USE_POSIX_2008_LOCALE
3424 assert(category_masks[LC_MESSAGES_INDEX] == LC_MESSAGES_MASK);
3425# endif
948523db
KW		 3426# endif
3427# ifdef USE_LOCALE_MONETARY
3428 assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
3429 assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
e9bc6d6b
KW		 3430# ifdef USE_POSIX_2008_LOCALE
3431 assert(category_masks[LC_MONETARY_INDEX] == LC_MONETARY_MASK);
3432# endif
948523db 3433# endif
9821811f
KW		 3434# ifdef USE_LOCALE_ADDRESS
3435 assert(categories[LC_ADDRESS_INDEX] == LC_ADDRESS);
3436 assert(strEQ(category_names[LC_ADDRESS_INDEX], "LC_ADDRESS"));
e9bc6d6b
KW		 3437# ifdef USE_POSIX_2008_LOCALE
3438 assert(category_masks[LC_ADDRESS_INDEX] == LC_ADDRESS_MASK);
3439# endif
9821811f
KW		 3440# endif
3441# ifdef USE_LOCALE_IDENTIFICATION
3442 assert(categories[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION);
3443 assert(strEQ(category_names[LC_IDENTIFICATION_INDEX], "LC_IDENTIFICATION"));
e9bc6d6b
KW		 3444# ifdef USE_POSIX_2008_LOCALE
3445 assert(category_masks[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION_MASK);
3446# endif
9821811f
KW		 3447# endif
3448# ifdef USE_LOCALE_MEASUREMENT
3449 assert(categories[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT);
3450 assert(strEQ(category_names[LC_MEASUREMENT_INDEX], "LC_MEASUREMENT"));
e9bc6d6b
KW		 3451# ifdef USE_POSIX_2008_LOCALE
3452 assert(category_masks[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT_MASK);
3453# endif
9821811f
KW		 3454# endif
3455# ifdef USE_LOCALE_PAPER
3456 assert(categories[LC_PAPER_INDEX] == LC_PAPER);
3457 assert(strEQ(category_names[LC_PAPER_INDEX], "LC_PAPER"));
e9bc6d6b
KW		 3458# ifdef USE_POSIX_2008_LOCALE
3459 assert(category_masks[LC_PAPER_INDEX] == LC_PAPER_MASK);
3460# endif
9821811f
KW		 3461# endif
3462# ifdef USE_LOCALE_TELEPHONE
3463 assert(categories[LC_TELEPHONE_INDEX] == LC_TELEPHONE);
3464 assert(strEQ(category_names[LC_TELEPHONE_INDEX], "LC_TELEPHONE"));
e9bc6d6b
KW		 3465# ifdef USE_POSIX_2008_LOCALE
3466 assert(category_masks[LC_TELEPHONE_INDEX] == LC_TELEPHONE_MASK);
3467# endif
9821811f 3468# endif
36dbc955
KW		 3469# ifdef USE_LOCALE_SYNTAX
3470 assert(categories[LC_SYNTAX_INDEX] == LC_SYNTAX);
3471 assert(strEQ(category_names[LC_SYNTAX_INDEX], "LC_SYNTAX"));
3472# ifdef USE_POSIX_2008_LOCALE
3473 assert(category_masks[LC_SYNTAX_INDEX] == LC_SYNTAX_MASK);
3474# endif
3475# endif
3476# ifdef USE_LOCALE_TOD
3477 assert(categories[LC_TOD_INDEX] == LC_TOD);
3478 assert(strEQ(category_names[LC_TOD_INDEX], "LC_TOD"));
3479# ifdef USE_POSIX_2008_LOCALE
3480 assert(category_masks[LC_TOD_INDEX] == LC_TOD_MASK);
3481# endif
3482# endif
948523db
KW		 3483# ifdef LC_ALL
3484 assert(categories[LC_ALL_INDEX] == LC_ALL);
3485 assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
3486 assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
e9bc6d6b
KW		 3487# ifdef USE_POSIX_2008_LOCALE
3488 assert(category_masks[LC_ALL_INDEX] == LC_ALL_MASK);
3489# endif
948523db
KW		 3490# endif
3491# endif /* DEBUGGING */
47280b20 3492
5a6637f0
KW		 3493 /* Initialize the per-thread mbrFOO() state variables. See POSIX.xs for
3494 * why these particular incantations are used. */
d2c9cb53
KW		 3495#ifdef HAS_MBRLEN
3496 memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
3497#endif
5a6637f0
KW		 3498#ifdef HAS_MBRTOWC
3499 memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
3500#endif
3501#ifdef HAS_WCTOMBR
3502 wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
3503#endif
d2c9cb53 3504
47280b20
KW		 3505 /* Initialize the cache of the program's UTF-8ness for the always known
3506 * locales C and POSIX */
3507 my_strlcpy(PL_locale_utf8ness, C_and_POSIX_utf8ness,
3508 sizeof(PL_locale_utf8ness));
3509
e9bc6d6b
KW		 3510# ifdef USE_THREAD_SAFE_LOCALE
3511# ifdef WIN32
3512
3513 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
3514
3515# endif
3516# endif
39e69e77 3517# ifdef USE_POSIX_2008_LOCALE
e9bc6d6b
KW		 3518
3519 PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
3520 if (! PL_C_locale_obj) {
3521 Perl_croak_nocontext(
3522 "panic: Cannot create POSIX 2008 C locale object; errno=%d", errno);
3523 }
3524 if (DEBUG_Lv_TEST || debug_initialization) {
3525 PerlIO_printf(Perl_debug_log, "%s:%d: created C object %p\n", __FILE__, __LINE__, PL_C_locale_obj);
3526 }
3527
3528# endif
3529
78f7c09f
KW		 3530# ifdef USE_LOCALE_NUMERIC
3531
3ca88433
KW		 3532 PL_numeric_radix_sv = newSVpvs(".");
3533
78f7c09f
KW		 3534# endif
3535
e9bc6d6b
KW		 3536# if defined(USE_POSIX_2008_LOCALE) && ! defined(HAS_QUERYLOCALE)
3537
3538 /* Initialize our records. If we have POSIX 2008, we have LC_ALL */
3539 do_setlocale_c(LC_ALL, my_setlocale(LC_ALL, NULL));
3540
3541# endif
b56c4436 3542# ifdef LOCALE_ENVIRON_REQUIRED
98994639
HS		 3543
3544 /*
3545 * Ultrix setlocale(..., "") fails if there are no environment
3546 * variables from which to get a locale name.
3547 */
3548
b56c4436
KW		 3549# ifndef LC_ALL
3550# error Ultrix without LC_ALL not implemented
3551# else
7d4bcc4a 3552
b56c4436
KW		 3553 {
3554 bool done = FALSE;
ea92aad8
KW		 3555 if (lang) {
3556 sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, setlocale_init);
3557 DEBUG_LOCALE_INIT(LC_ALL, setlocale_init, sl_result[LC_ALL_INDEX]);
3558 if (sl_result[LC_ALL_INDEX])
3559 done = TRUE;
3560 else
e5f10d49 3561 setlocale_failure = TRUE;
ea92aad8
KW		 3562 }
3563 if (! setlocale_failure) {
3564 const char * locale_param;
3565 for (i = 0; i < LC_ALL_INDEX; i++) {
3566 locale_param = (! done && (lang || PerlEnv_getenv(category_names[i])))
3567 ? setlocale_init
3568 : NULL;
3569 sl_result[i] = do_setlocale_r(categories[i], locale_param);
3570 if (! sl_result[i]) {
3571 setlocale_failure = TRUE;
3572 }
3573 DEBUG_LOCALE_INIT(categories[i], locale_param, sl_result[i]);
e5f10d49 3574 }
c835d6be 3575 }
7d4bcc4a
KW		 3576 }
3577
3578# endif /* LC_ALL */
e5f10d49 3579# endif /* LOCALE_ENVIRON_REQUIRED */
98994639 3580
65ebb059 3581 /* We try each locale in the list until we get one that works, or exhaust
20a240df
KW		 3582 * the list. Normally the loop is executed just once. But if setting the
3583 * locale fails, inside the loop we add fallback trials to the array and so
3584 * will execute the loop multiple times */
c3fcd832
KW		 3585 trial_locales[0] = setlocale_init;
3586 trial_locales_count = 1;
7d4bcc4a 3587
65ebb059
KW		 3588 for (i= 0; i < trial_locales_count; i++) {
3589 const char * trial_locale = trial_locales[i];
3590
3591 if (i > 0) {
3592
3593 /* XXX This is to preserve old behavior for LOCALE_ENVIRON_REQUIRED
3594 * when i==0, but I (khw) don't think that behavior makes much
3595 * sense */
3596 setlocale_failure = FALSE;
3597
7d4bcc4a 3598# ifdef SYSTEM_DEFAULT_LOCALE
291a84fb 3599# ifdef WIN32 /* Note that assumes Win32 has LC_ALL */
7d4bcc4a 3600
65ebb059
KW		 3601 /* On Windows machines, an entry of "" after the 0th means to use
3602 * the system default locale, which we now proceed to get. */
3603 if (strEQ(trial_locale, "")) {
3604 unsigned int j;
3605
3606 /* Note that this may change the locale, but we are going to do
3607 * that anyway just below */
837ce802 3608 system_default_locale = do_setlocale_c(LC_ALL, "");
5d1187d1 3609 DEBUG_LOCALE_INIT(LC_ALL, "", system_default_locale);
65ebb059 3610
7d4bcc4a 3611 /* Skip if invalid or if it's already on the list of locales to
65ebb059
KW		 3612 * try */
3613 if (! system_default_locale) {
3614 goto next_iteration;
3615 }
3616 for (j = 0; j < trial_locales_count; j++) {
3617 if (strEQ(system_default_locale, trial_locales[j])) {
3618 goto next_iteration;
3619 }
3620 }
3621
3622 trial_locale = system_default_locale;
3623 }
ec0202b5
KW		 3624# else
3625# error SYSTEM_DEFAULT_LOCALE only implemented for Win32
3626# endif
7d4bcc4a 3627# endif /* SYSTEM_DEFAULT_LOCALE */
291a84fb
KW		 3628
3629 } /* For i > 0 */
65ebb059 3630
7d4bcc4a
KW		 3631# ifdef LC_ALL
3632
948523db
KW		 3633 sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, trial_locale);
3634 DEBUG_LOCALE_INIT(LC_ALL, trial_locale, sl_result[LC_ALL_INDEX]);
3635 if (! sl_result[LC_ALL_INDEX]) {
49c85077 3636 setlocale_failure = TRUE;
7cd8b568
KW		 3637 }
3638 else {
3639 /* Since LC_ALL succeeded, it should have changed all the other
3640 * categories it can to its value; so we massage things so that the
3641 * setlocales below just return their category's current values.
3642 * This adequately handles the case in NetBSD where LC_COLLATE may
3643 * not be defined for a locale, and setting it individually will
7d4bcc4a 3644 * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to
7cd8b568
KW		 3645 * the POSIX locale. */
3646 trial_locale = NULL;
3647 }
7d4bcc4a
KW		 3648
3649# endif /* LC_ALL */
98994639 3650
e5f10d49
KW		 3651 if (! setlocale_failure) {
3652 unsigned int j;
3653 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
3654 curlocales[j]
3655 = savepv(do_setlocale_r(categories[j], trial_locale));
3656 if (! curlocales[j]) {
3657 setlocale_failure = TRUE;
3658 }
3659 DEBUG_LOCALE_INIT(categories[j], trial_locale, curlocales[j]);
3660 }
c835d6be 3661
e5f10d49
KW		 3662 if (! setlocale_failure) { /* All succeeded */
3663 break; /* Exit trial_locales loop */
49c85077 3664 }
65ebb059 3665 }
98994639 3666
49c85077
KW		 3667 /* Here, something failed; will need to try a fallback. */
3668 ok = 0;
65ebb059 3669
49c85077
KW		 3670 if (i == 0) {
3671 unsigned int j;
98994639 3672
65ebb059 3673 if (locwarn) { /* Output failure info only on the first one */
7d4bcc4a
KW		 3674
3675# ifdef LC_ALL
98994639 3676
49c85077
KW		 3677 PerlIO_printf(Perl_error_log,
3678 "perl: warning: Setting locale failed.\n");
98994639 3679
7d4bcc4a 3680# else /* !LC_ALL */
98994639 3681
49c85077
KW		 3682 PerlIO_printf(Perl_error_log,
3683 "perl: warning: Setting locale failed for the categories:\n\t");
7d4bcc4a 3684
e5f10d49
KW		 3685 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
3686 if (! curlocales[j]) {
3687 PerlIO_printf(Perl_error_log, category_names[j]);
3688 }
3689 else {
3690 Safefree(curlocales[j]);
3691 }
3692 }
7d4bcc4a 3693
7d4bcc4a 3694# endif /* LC_ALL */
98994639 3695
49c85077
KW		 3696 PerlIO_printf(Perl_error_log,
3697 "perl: warning: Please check that your locale settings:\n");
98994639 3698
7d4bcc4a
KW		 3699# ifdef __GLIBC__
3700
49c85077
KW		 3701 PerlIO_printf(Perl_error_log,
3702 "\tLANGUAGE = %c%s%c,\n",
3703 language ? '"' : '(',
3704 language ? language : "unset",
3705 language ? '"' : ')');
7d4bcc4a 3706# endif
98994639 3707
49c85077
KW		 3708 PerlIO_printf(Perl_error_log,
3709 "\tLC_ALL = %c%s%c,\n",
3710 lc_all ? '"' : '(',
3711 lc_all ? lc_all : "unset",
3712 lc_all ? '"' : ')');
98994639 3713
7d4bcc4a
KW		 3714# if defined(USE_ENVIRON_ARRAY)
3715
49c85077 3716 {
cd999af9 3717 char **e;
d5e32b93
KW		 3718
3719 /* Look through the environment for any variables of the
3720 * form qr/ ^ LC_ [A-Z]+ = /x, except LC_ALL which was
3721 * already handled above. These are assumed to be locale
3722 * settings. Output them and their values. */
cd999af9 3723 for (e = environ; *e; e++) {
d5e32b93
KW		 3724 const STRLEN prefix_len = sizeof("LC_") - 1;
3725 STRLEN uppers_len;
3726
cd999af9 3727 if ( strBEGINs(*e, "LC_")
c8b388b0 3728 && ! strBEGINs(*e, "LC_ALL=")
d5e32b93
KW		 3729 && (uppers_len = strspn(*e + prefix_len,
3730 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
3731 && ((*e)[prefix_len + uppers_len] == '='))
cd999af9
KW		 3732 {
3733 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
d5e32b93
KW		 3734 (int) (prefix_len + uppers_len), *e,
3735 *e + prefix_len + uppers_len + 1);
cd999af9
KW		 3736 }
3737 }
49c85077 3738 }
7d4bcc4a
KW		 3739
3740# else
3741
49c85077
KW		 3742 PerlIO_printf(Perl_error_log,
3743 "\t(possibly more locale environment variables)\n");
7d4bcc4a
KW		 3744
3745# endif
98994639 3746
49c85077
KW		 3747 PerlIO_printf(Perl_error_log,
3748 "\tLANG = %c%s%c\n",
3749 lang ? '"' : '(',
3750 lang ? lang : "unset",
3751 lang ? '"' : ')');
98994639 3752
49c85077
KW		 3753 PerlIO_printf(Perl_error_log,
3754 " are supported and installed on your system.\n");
3755 }
98994639 3756
65ebb059 3757 /* Calculate what fallback locales to try. We have avoided this
f6bab5f6 3758 * until we have to, because failure is quite unlikely. This will
65ebb059
KW		 3759 * usually change the upper bound of the loop we are in.
3760 *
3761 * Since the system's default way of setting the locale has not
3762 * found one that works, We use Perl's defined ordering: LC_ALL,
3763 * LANG, and the C locale. We don't try the same locale twice, so
3764 * don't add to the list if already there. (On POSIX systems, the
3765 * LC_ALL element will likely be a repeat of the 0th element "",
6b058d42
KW		 3766 * but there's no harm done by doing it explicitly.
3767 *
3768 * Note that this tries the LC_ALL environment variable even on
3769 * systems which have no LC_ALL locale setting. This may or may
3770 * not have been originally intentional, but there's no real need
3771 * to change the behavior. */
65ebb059
KW		 3772 if (lc_all) {
3773 for (j = 0; j < trial_locales_count; j++) {
3774 if (strEQ(lc_all, trial_locales[j])) {
3775 goto done_lc_all;
3776 }
3777 }
3778 trial_locales[trial_locales_count++] = lc_all;
3779 }
3780 done_lc_all:
98994639 3781
65ebb059
KW		 3782 if (lang) {
3783 for (j = 0; j < trial_locales_count; j++) {
3784 if (strEQ(lang, trial_locales[j])) {
3785 goto done_lang;
3786 }
3787 }
3788 trial_locales[trial_locales_count++] = lang;
3789 }
3790 done_lang:
3791
7d4bcc4a
KW		 3792# if defined(WIN32) && defined(LC_ALL)
3793
65ebb059
KW		 3794 /* For Windows, we also try the system default locale before "C".
3795 * (If there exists a Windows without LC_ALL we skip this because
3796 * it gets too complicated. For those, the "C" is the next
3797 * fallback possibility). The "" is the same as the 0th element of
3798 * the array, but the code at the loop above knows to treat it
3799 * differently when not the 0th */
3800 trial_locales[trial_locales_count++] = "";
7d4bcc4a
KW		 3801
3802# endif
65ebb059
KW		 3803
3804 for (j = 0; j < trial_locales_count; j++) {
3805 if (strEQ("C", trial_locales[j])) {
3806 goto done_C;
3807 }
3808 }
3809 trial_locales[trial_locales_count++] = "C";
98994639 3810
65ebb059
KW		 3811 done_C: ;
3812 } /* end of first time through the loop */
98994639 3813
7d4bcc4a
KW		 3814# ifdef WIN32
3815
65ebb059 3816 next_iteration: ;
7d4bcc4a
KW		 3817
3818# endif
65ebb059
KW		 3819
3820 } /* end of looping through the trial locales */
3821
3822 if (ok < 1) { /* If we tried to fallback */
3823 const char* msg;
3824 if (! setlocale_failure) { /* fallback succeeded */
3825 msg = "Falling back to";
3826 }
3827 else { /* fallback failed */
e5f10d49 3828 unsigned int j;
98994639 3829
65ebb059
KW		 3830 /* We dropped off the end of the loop, so have to decrement i to
3831 * get back to the value the last time through */
3832 i--;
98994639 3833
65ebb059
KW		 3834 ok = -1;
3835 msg = "Failed to fall back to";
3836
3837 /* To continue, we should use whatever values we've got */
7d4bcc4a 3838
e5f10d49
KW		 3839 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
3840 Safefree(curlocales[j]);
3841 curlocales[j] = savepv(do_setlocale_r(categories[j], NULL));
3842 DEBUG_LOCALE_INIT(categories[j], NULL, curlocales[j]);
3843 }
65ebb059
KW		 3844 }
3845
3846 if (locwarn) {
3847 const char * description;
3848 const char * name = "";
3849 if (strEQ(trial_locales[i], "C")) {
3850 description = "the standard locale";
3851 name = "C";
3852 }
7d4bcc4a
KW		 3853
3854# ifdef SYSTEM_DEFAULT_LOCALE
3855
65ebb059
KW		 3856 else if (strEQ(trial_locales[i], "")) {
3857 description = "the system default locale";
3858 if (system_default_locale) {
3859 name = system_default_locale;
3860 }
3861 }
7d4bcc4a
KW		 3862
3863# endif /* SYSTEM_DEFAULT_LOCALE */
3864
65ebb059
KW		 3865 else {
3866 description = "a fallback locale";
3867 name = trial_locales[i];
3868 }
3869 if (name && strNE(name, "")) {
3870 PerlIO_printf(Perl_error_log,
3871 "perl: warning: %s %s (\"%s\").\n", msg, description, name);
3872 }
3873 else {
3874 PerlIO_printf(Perl_error_log,
3875 "perl: warning: %s %s.\n", msg, description);
3876 }
3877 }
3878 } /* End of tried to fallback */
98994639 3879
e5f10d49
KW		 3880 /* Done with finding the locales; update our records */
3881
7d4bcc4a
KW		 3882# ifdef USE_LOCALE_CTYPE
3883
948523db 3884 new_ctype(curlocales[LC_CTYPE_INDEX]);
98994639 3885
e5f10d49 3886# endif
7d4bcc4a
KW		 3887# ifdef USE_LOCALE_COLLATE
3888
948523db 3889 new_collate(curlocales[LC_COLLATE_INDEX]);
98994639 3890
e5f10d49 3891# endif
7d4bcc4a
KW		 3892# ifdef USE_LOCALE_NUMERIC
3893
948523db 3894 new_numeric(curlocales[LC_NUMERIC_INDEX]);
e5f10d49
KW		 3895
3896# endif
3897
948523db 3898 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
47280b20 3899
e9bc6d6b 3900# if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
47280b20
KW		 3901
3902 /* This caches whether each category's locale is UTF-8 or not. This
3903 * may involve changing the locale. It is ok to do this at
e9bc6d6b
KW		 3904 * initialization time before any threads have started, but not later
3905 * unless thread-safe operations are used.
47280b20
KW		 3906 * Caching means that if the program heeds our dictate not to change
3907 * locales in threaded applications, this data will remain valid, and
9de6fe47
KW		 3908 * it may get queried without having to change locales. If the
3909 * environment is such that all categories have the same locale, this
3910 * isn't needed, as the code will not change the locale; but this
3911 * handles the uncommon case where the environment has disparate
3912 * locales for the categories */
47280b20
KW		 3913 (void) _is_cur_LC_category_utf8(categories[i]);
3914
3915# endif
3916
e5f10d49
KW		 3917 Safefree(curlocales[i]);
3918 }
b310b053 3919
7d4bcc4a
KW		 3920# if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
3921
49c85077 3922 /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
50bf02bd
KW		 3923 * locale is UTF-8. The call to new_ctype() just above has already
3924 * calculated the latter value and saved it in PL_in_utf8_CTYPE_locale. If
3925 * both PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
3926 * are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer on
3927 * STDIN, STDOUT, STDERR, _and_ the default open discipline. */
3928 PL_utf8locale = PL_in_utf8_CTYPE_locale;
49c85077 3929
a05d7ebb 3930 /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
fde18df1
JH		 3931 This is an alternative to using the -C command line switch
3932 (the -C if present will override this). */
3933 {
dd374669 3934 const char *p = PerlEnv_getenv("PERL_UNICODE");
a05d7ebb 3935 PL_unicode = p ? parse_unicode_opts(&p) : 0;
5a22a2bb
NC		 3936 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3937 PL_utf8cache = -1;
b310b053
JH		 3938 }
3939
7d4bcc4a 3940# endif
e3305790 3941#endif /* USE_LOCALE */
2fcc0ca9 3942#ifdef DEBUGGING
7d4bcc4a 3943
2fcc0ca9 3944 /* So won't continue to output stuff */
27cdc72e 3945 DEBUG_INITIALIZATION_set(FALSE);
7d4bcc4a 3946
2fcc0ca9
KW		 3947#endif
3948
98994639
HS		 3949 return ok;
3950}
3951
98994639
HS		 3952#ifdef USE_LOCALE_COLLATE
3953
a4a439fb 3954char *
a4a439fb
KW		 3955Perl__mem_collxfrm(pTHX_ const char *input_string,
3956 STRLEN len, /* Length of 'input_string' */
3957 STRLEN *xlen, /* Set to length of returned string
3958 (not including the collation index
3959 prefix) */
3960 bool utf8 /* Is the input in UTF-8? */
6696cfa7 3961 )
98994639 3962{
a4a439fb
KW		 3963
3964 /* _mem_collxfrm() is a bit like strxfrm() but with two important
3965 * differences. First, it handles embedded NULs. Second, it allocates a bit
3966 * more memory than needed for the transformed data itself. The real
55e5378d 3967 * transformed data begins at offset COLLXFRM_HDR_LEN. *xlen is set to
a4a439fb
KW		 3968 * the length of that, and doesn't include the collation index size.
3969 * Please see sv_collxfrm() to see how this is used. */
3970
55e5378d
KW		 3971#define COLLXFRM_HDR_LEN sizeof(PL_collation_ix)
3972
6696cfa7
KW		 3973 char * s = (char *) input_string;
3974 STRLEN s_strlen = strlen(input_string);
79f120c8 3975 char *xbuf = NULL;
55e5378d 3976 STRLEN xAlloc; /* xalloc is a reserved word in VC */
17f41037 3977 STRLEN length_in_chars;
c664130f 3978 bool first_time = TRUE; /* Cleared after first loop iteration */
98994639 3979
a4a439fb
KW		 3980 PERL_ARGS_ASSERT__MEM_COLLXFRM;
3981
3982 /* Must be NUL-terminated */
3983 assert(*(input_string + len) == '\0');
7918f24d 3984
79f120c8
KW		 3985 /* If this locale has defective collation, skip */
3986 if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
c7202dee
KW		 3987 DEBUG_L(PerlIO_printf(Perl_debug_log,
3988 "_mem_collxfrm: locale's collation is defective\n"));
79f120c8
KW		 3989 goto bad;
3990 }
3991
6696cfa7
KW		 3992 /* Replace any embedded NULs with the control that sorts before any others.
3993 * This will give as good as possible results on strings that don't
3994 * otherwise contain that character, but otherwise there may be
3995 * less-than-perfect results with that character and NUL. This is
fdc080f3 3996 * unavoidable unless we replace strxfrm with our own implementation. */
fd43f63c
KW		 3997 if (UNLIKELY(s_strlen < len)) { /* Only execute if there is an embedded
3998 NUL */
6696cfa7
KW		 3999 char * e = s + len;
4000 char * sans_nuls;
fdc080f3 4001 STRLEN sans_nuls_len;
94762aa0 4002 int try_non_controls;
afc4976f
KW		 4003 char this_replacement_char[] = "?\0"; /* Room for a two-byte string,
4004 making sure 2nd byte is NUL.
4005 */
4006 STRLEN this_replacement_len;
4007
1e4c9676
KW		 4008 /* If we don't know what non-NUL control character sorts lowest for
4009 * this locale, find it */
f28f4d2a 4010 if (PL_strxfrm_NUL_replacement == '\0') {
6696cfa7 4011 int j;
afc4976f 4012 char * cur_min_x = NULL; /* The min_char's xfrm, (except it also
6696cfa7
KW		 4013 includes the collation index
4014 prefixed. */
4015
91c0e2e0 4016 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
94762aa0
KW		 4017
4018 /* Unlikely, but it may be that no control will work to replace
1e4c9676
KW		 4019 * NUL, in which case we instead look for any character. Controls
4020 * are preferred because collation order is, in general, context
4021 * sensitive, with adjoining characters affecting the order, and
4022 * controls are less likely to have such interactions, allowing the
4023 * NUL-replacement to stand on its own. (Another way to look at it
4024 * is to imagine what would happen if the NUL were replaced by a
4025 * combining character; it wouldn't work out all that well.) */
94762aa0
KW		 4026 for (try_non_controls = 0;
4027 try_non_controls < 2;
4028 try_non_controls++)
4029 {
d4ff9586
KW		 4030 /* Look through all legal code points (NUL isn't) */
4031 for (j = 1; j < 256; j++) {
4032 char * x; /* j's xfrm plus collation index */
4033 STRLEN x_len; /* length of 'x' */
4034 STRLEN trial_len = 1;
736a4fed 4035 char cur_source[] = { '\0', '\0' };
d4ff9586 4036
736a4fed
KW		 4037 /* Skip non-controls the first time through the loop. The
4038 * controls in a UTF-8 locale are the L1 ones */
afc4976f
KW		 4039 if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
4040 ? ! isCNTRL_L1(j)
4041 : ! isCNTRL_LC(j))
4042 {
d4ff9586 4043 continue;
6696cfa7 4044 }
6696cfa7 4045
736a4fed
KW		 4046 /* Create a 1-char string of the current code point */
4047 cur_source[0] = (char) j;
4048
d4ff9586
KW		 4049 /* Then transform it */
4050 x = _mem_collxfrm(cur_source, trial_len, &x_len,
afc4976f 4051 0 /* The string is not in UTF-8 */);
6696cfa7 4052
1e4c9676 4053 /* Ignore any character that didn't successfully transform.
d4ff9586
KW		 4054 * */
4055 if (! x) {
4056 continue;
4057 }
6696cfa7 4058
d4ff9586
KW		 4059 /* If this character's transformation is lower than
4060 * the current lowest, this one becomes the lowest */
4061 if ( cur_min_x == NULL
4062 || strLT(x + COLLXFRM_HDR_LEN,
4063 cur_min_x + COLLXFRM_HDR_LEN))
4064 {
f28f4d2a 4065 PL_strxfrm_NUL_replacement = j;
62d66863 4066 Safefree(cur_min_x);
d4ff9586 4067 cur_min_x = x;
d4ff9586
KW		 4068 }
4069 else {
4070 Safefree(x);
4071 }
1e4c9676 4072 } /* end of loop through all 255 characters */
6696cfa7 4073
1e4c9676 4074 /* Stop looking if found */
94762aa0
KW		 4075 if (cur_min_x) {
4076 break;
4077 }
4078
4079 /* Unlikely, but possible, if there aren't any controls that
4080 * work in the locale, repeat the loop, looking for any
4081 * character that works */
4082 DEBUG_L(PerlIO_printf(Perl_debug_log,
4083 "_mem_collxfrm: No control worked. Trying non-controls\n"));
1e4c9676 4084 } /* End of loop to try first the controls, then any char */
6696cfa7 4085
94762aa0
KW		 4086 if (! cur_min_x) {
4087 DEBUG_L(PerlIO_printf(Perl_debug_log,
4088 "_mem_collxfrm: Couldn't find any character to replace"
4089 " embedded NULs in locale %s with", PL_collation_name));
4090 goto bad;
58eebef2
KW		 4091 }
4092
94762aa0
KW		 4093 DEBUG_L(PerlIO_printf(Perl_debug_log,
4094 "_mem_collxfrm: Replacing embedded NULs in locale %s with "
f28f4d2a 4095 "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
94762aa0 4096
6696cfa7 4097 Safefree(cur_min_x);
1e4c9676 4098 } /* End of determining the character that is to replace NULs */
afc4976f
KW		 4099
4100 /* If the replacement is variant under UTF-8, it must match the
291a84fb 4101 * UTF8-ness of the original */
f28f4d2a
KW		 4102 if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
4103 this_replacement_char[0] =
4104 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
4105 this_replacement_char[1] =
4106 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
afc4976f
KW		 4107 this_replacement_len = 2;
4108 }
4109 else {
f28f4d2a 4110 this_replacement_char[0] = PL_strxfrm_NUL_replacement;
afc4976f
KW		 4111 /* this_replacement_char[1] = '\0' was done at initialization */
4112 this_replacement_len = 1;
6696cfa7
KW		 4113 }
4114
4115 /* The worst case length for the replaced string would be if every
4116 * character in it is NUL. Multiply that by the length of each
4117 * replacement, and allow for a trailing NUL */
afc4976f 4118 sans_nuls_len = (len * this_replacement_len) + 1;
fdc080f3 4119 Newx(sans_nuls, sans_nuls_len, char);
6696cfa7
KW		 4120 *sans_nuls = '\0';
4121
6696cfa7
KW		 4122 /* Replace each NUL with the lowest collating control. Loop until have
4123 * exhausted all the NULs */
4124 while (s + s_strlen < e) {
6069d6c5 4125 my_strlcat(sans_nuls, s, sans_nuls_len);
6696cfa7
KW		 4126
4127 /* Do the actual replacement */
6069d6c5 4128 my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
6696cfa7
KW		 4129
4130 /* Move past the input NUL */
4131 s += s_strlen + 1;
4132 s_strlen = strlen(s);
4133 }
4134
4135 /* And add anything that trails the final NUL */
6069d6c5 4136 my_strlcat(sans_nuls, s, sans_nuls_len);
6696cfa7
KW		 4137
4138 /* Switch so below we transform this modified string */
4139 s = sans_nuls;
4140 len = strlen(s);
1e4c9676 4141 } /* End of replacing NULs */
6696cfa7 4142
a4a439fb
KW		 4143 /* Make sure the UTF8ness of the string and locale match */
4144 if (utf8 != PL_in_utf8_COLLATE_locale) {
9de6fe47 4145 /* XXX convert above Unicode to 10FFFF? */
a4a439fb
KW		 4146 const char * const t = s; /* Temporary so we can later find where the
4147 input was */
4148
4149 /* Here they don't match. Change the string's to be what the locale is
4150 * expecting */
4151
4152 if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
4153 s = (char *) bytes_to_utf8((const U8 *) s, &len);
4154 utf8 = TRUE;
4155 }
4156 else { /* locale is not UTF-8; but input is; downgrade the input */
4157
4158 s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
4159
4160 /* If the downgrade was successful we are done, but if the input
4161 * contains things that require UTF-8 to represent, have to do
4162 * damage control ... */
4163 if (UNLIKELY(utf8)) {
4164
4165 /* What we do is construct a non-UTF-8 string with
4166 * 1) the characters representable by a single byte converted
4167 * to be so (if necessary);
4168 * 2) and the rest converted to collate the same as the
4169 * highest collating representable character. That makes
4170 * them collate at the end. This is similar to how we
4171 * handle embedded NULs, but we use the highest collating
4172 * code point instead of the smallest. Like the NUL case,
4173 * this isn't perfect, but is the best we can reasonably
4174 * do. Every above-255 code point will sort the same as
4175 * the highest-sorting 0-255 code point. If that code
4176 * point can combine in a sequence with some other code
4177 * points for weight calculations, us changing something to
4178 * be it can adversely affect the results. But in most
4179 * cases, it should work reasonably. And note that this is
4180 * really an illegal situation: using code points above 255
4181 * on a locale where only 0-255 are valid. If two strings
4182 * sort entirely equal, then the sort order for the
4183 * above-255 code points will be in code point order. */
4184
4185 utf8 = FALSE;
4186
4187 /* If we haven't calculated the code point with the maximum
4188 * collating order for this locale, do so now */
4189 if (! PL_strxfrm_max_cp) {
4190 int j;
4191
4192 /* The current transformed string that collates the
4193 * highest (except it also includes the prefixed collation
4194 * index. */
4195 char * cur_max_x = NULL;
4196
4197 /* Look through all legal code points (NUL isn't) */
4198 for (j = 1; j < 256; j++) {
4199 char * x;
4200 STRLEN x_len;
736a4fed 4201 char cur_source[] = { '\0', '\0' };
a4a439fb 4202
736a4fed
KW		 4203 /* Create a 1-char string of the current code point */
4204 cur_source[0] = (char) j;
a4a439fb
KW		 4205
4206 /* Then transform it */
4207 x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
4208
4209 /* If something went wrong (which it shouldn't), just
4210 * ignore this code point */
94762aa0 4211 if (! x) {
a4a439fb
KW		 4212 continue;
4213 }
4214
4215 /* If this character's transformation is higher than
4216 * the current highest, this one becomes the highest */
4217 if ( cur_max_x == NULL
55e5378d
KW		 4218 || strGT(x + COLLXFRM_HDR_LEN,
4219 cur_max_x + COLLXFRM_HDR_LEN))
a4a439fb
KW		 4220 {
4221 PL_strxfrm_max_cp = j;
62d66863 4222 Safefree(cur_max_x);
a4a439fb
KW		 4223 cur_max_x = x;
4224 }
4225 else {
4226 Safefree(x);
4227 }
4228 }
4229
94762aa0
KW		 4230 if (! cur_max_x) {
4231 DEBUG_L(PerlIO_printf(Perl_debug_log,
4232 "_mem_collxfrm: Couldn't find any character to"
4233 " replace above-Latin1 chars in locale %s with",
4234 PL_collation_name));
4235 goto bad;
4236 }
4237
58eebef2
KW		 4238 DEBUG_L(PerlIO_printf(Perl_debug_log,
4239 "_mem_collxfrm: highest 1-byte collating character"
4240 " in locale %s is 0x%02X\n",
4241 PL_collation_name,
4242 PL_strxfrm_max_cp));
58eebef2 4243
a4a439fb
KW		 4244 Safefree(cur_max_x);
4245 }
4246
4247 /* Here we know which legal code point collates the highest.
4248 * We are ready to construct the non-UTF-8 string. The length
4249 * will be at least 1 byte smaller than the input string
4250 * (because we changed at least one 2-byte character into a
4251 * single byte), but that is eaten up by the trailing NUL */
4252 Newx(s, len, char);
4253
4254 {
4255 STRLEN i;
4256 STRLEN d= 0;
042d9e50 4257 char * e = (char *) t + len;
a4a439fb
KW		 4258
4259 for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
4260 U8 cur_char = t[i];
4261 if (UTF8_IS_INVARIANT(cur_char)) {
4262 s[d++] = cur_char;
4263 }
042d9e50 4264 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
a4a439fb
KW		 4265 s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
4266 }
4267 else { /* Replace illegal cp with highest collating
4268 one */
4269 s[d++] = PL_strxfrm_max_cp;
4270 }
4271 }
4272 s[d++] = '\0';
4273 Renew(s, d, char); /* Free up unused space */
4274 }
4275 }
4276 }
4277
4278 /* Here, we have constructed a modified version of the input. It could
4279 * be that we already had a modified copy before we did this version.
4280 * If so, that copy is no longer needed */
4281 if (t != input_string) {
4282 Safefree(t);
4283 }
4284 }
4285
17f41037
KW		 4286 length_in_chars = (utf8)
4287 ? utf8_length((U8 *) s, (U8 *) s + len)
4288 : len;
4289
59c018b9
KW		 4290 /* The first element in the output is the collation id, used by
4291 * sv_collxfrm(); then comes the space for the transformed string. The
4292 * equation should give us a good estimate as to how much is needed */
55e5378d 4293 xAlloc = COLLXFRM_HDR_LEN
a4a439fb 4294 + PL_collxfrm_base
17f41037 4295 + (PL_collxfrm_mult * length_in_chars);
a02a5408 4296 Newx(xbuf, xAlloc, char);
c7202dee
KW		 4297 if (UNLIKELY(! xbuf)) {
4298 DEBUG_L(PerlIO_printf(Perl_debug_log,
4299 "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
98994639 4300 goto bad;
c7202dee 4301 }
98994639 4302
d35fca5f 4303 /* Store the collation id */
98994639 4304 *(U32*)xbuf = PL_collation_ix;
d35fca5f
KW		 4305
4306 /* Then the transformation of the input. We loop until successful, or we
4307 * give up */
4ebeff16 4308 for (;;) {
1adab0a7 4309
55e5378d 4310 *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
4ebeff16
KW		 4311
4312 /* If the transformed string occupies less space than we told strxfrm()
4313 * was available, it means it successfully transformed the whole
4314 * string. */
55e5378d 4315 if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
17f41037 4316
1adab0a7
KW		 4317 /* Some systems include a trailing NUL in the returned length.
4318 * Ignore it, using a loop in case multiple trailing NULs are
4319 * returned. */
4320 while ( (*xlen) > 0
4321 && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
4322 {
4323 (*xlen)--;
4324 }
4325
17f41037
KW		 4326 /* If the first try didn't get it, it means our prediction was low.
4327 * Modify the coefficients so that we predict a larger value in any
4328 * future transformations */
4329 if (! first_time) {
4330 STRLEN needed = *xlen + 1; /* +1 For trailing NUL */
4331 STRLEN computed_guess = PL_collxfrm_base
4332 + (PL_collxfrm_mult * length_in_chars);
e1c30f0c
KW		 4333
4334 /* On zero-length input, just keep current slope instead of
4335 * dividing by 0 */
4336 const STRLEN new_m = (length_in_chars != 0)
4337 ? needed / length_in_chars
4338 : PL_collxfrm_mult;
17f41037
KW		 4339
4340 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
b07929e4
KW		 4341 "%s: %d: initial size of %zu bytes for a length "
4342 "%zu string was insufficient, %zu needed\n",
17f41037 4343 __FILE__, __LINE__,
b07929e4 4344 computed_guess, length_in_chars, needed));
17f41037
KW		 4345
4346 /* If slope increased, use it, but discard this result for
4347 * length 1 strings, as we can't be sure that it's a real slope
4348 * change */
4349 if (length_in_chars > 1 && new_m > PL_collxfrm_mult) {
7d4bcc4a
KW		 4350
4351# ifdef DEBUGGING
4352
17f41037
KW		 4353 STRLEN old_m = PL_collxfrm_mult;
4354 STRLEN old_b = PL_collxfrm_base;
7d4bcc4a
KW		 4355
4356# endif
4357
17f41037
KW		 4358 PL_collxfrm_mult = new_m;
4359 PL_collxfrm_base = 1; /* +1 For trailing NUL */
4360 computed_guess = PL_collxfrm_base
4361 + (PL_collxfrm_mult * length_in_chars);
4362 if (computed_guess < needed) {
4363 PL_collxfrm_base += needed - computed_guess;
4364 }
4365
4366 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
b07929e4
KW		 4367 "%s: %d: slope is now %zu; was %zu, base "
4368 "is now %zu; was %zu\n",
17f41037 4369 __FILE__, __LINE__,
b07929e4
KW		 4370 PL_collxfrm_mult, old_m,
4371 PL_collxfrm_base, old_b));
17f41037
KW		 4372 }
4373 else { /* Slope didn't change, but 'b' did */
4374 const STRLEN new_b = needed
4375 - computed_guess
4376 + PL_collxfrm_base;
4377 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
b07929e4 4378 "%s: %d: base is now %zu; was %zu\n",
17f41037 4379 __FILE__, __LINE__,
b07929e4 4380 new_b, PL_collxfrm_base));
17f41037
KW		 4381 PL_collxfrm_base = new_b;
4382 }
4383 }
4384
4ebeff16
KW		 4385 break;
4386 }
bb0f664e 4387
c7202dee
KW		 4388 if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
4389 DEBUG_L(PerlIO_printf(Perl_debug_log,
4390 "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
4391 *xlen, PERL_INT_MAX));
4ebeff16 4392 goto bad;
c7202dee 4393 }
d35fca5f 4394
c664130f 4395 /* A well-behaved strxfrm() returns exactly how much space it needs
1adab0a7
KW		 4396 * (usually not including the trailing NUL) when it fails due to not
4397 * enough space being provided. Assume that this is the case unless
4398 * it's been proven otherwise */
c664130f 4399 if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
55e5378d 4400 xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
c664130f
KW		 4401 }
4402 else { /* Here, either:
4403 * 1) The strxfrm() has previously shown bad behavior; or
4404 * 2) It isn't the first time through the loop, which means
4405 * that the strxfrm() is now showing bad behavior, because
4406 * we gave it what it said was needed in the previous
4407 * iteration, and it came back saying it needed still more.
4408 * (Many versions of cygwin fit this. When the buffer size
4409 * isn't sufficient, they return the input size instead of
4410 * how much is needed.)
d4ff9586
KW		 4411 * Increase the buffer size by a fixed percentage and try again.
4412 * */
6ddd902c 4413 xAlloc += (xAlloc / 4) + 1;
c664130f 4414 PL_strxfrm_is_behaved = FALSE;
c664130f 4415
7d4bcc4a
KW		 4416# ifdef DEBUGGING
4417
58eebef2
KW		 4418 if (DEBUG_Lv_TEST || debug_initialization) {
4419 PerlIO_printf(Perl_debug_log,
4420 "_mem_collxfrm required more space than previously calculated"
b07929e4 4421 " for locale %s, trying again with new guess=%d+%zu\n",
58eebef2 4422 PL_collation_name, (int) COLLXFRM_HDR_LEN,
b07929e4 4423 xAlloc - COLLXFRM_HDR_LEN);
58eebef2 4424 }
7d4bcc4a
KW		 4425
4426# endif
4427
58eebef2 4428 }
c664130f 4429
4ebeff16 4430 Renew(xbuf, xAlloc, char);
c7202dee
KW		 4431 if (UNLIKELY(! xbuf)) {
4432 DEBUG_L(PerlIO_printf(Perl_debug_log,
4433 "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
4ebeff16 4434 goto bad;
c7202dee 4435 }
c664130f
KW		 4436
4437 first_time = FALSE;
4ebeff16 4438 }
98994639 4439
6696cfa7 4440
7d4bcc4a
KW		 4441# ifdef DEBUGGING
4442
58eebef2 4443 if (DEBUG_Lv_TEST || debug_initialization) {
c7202dee
KW		 4444
4445 print_collxfrm_input_and_return(s, s + len, xlen, utf8);
4446 PerlIO_printf(Perl_debug_log, "Its xfrm is:");
7e2f38b2
KW		 4447 PerlIO_printf(Perl_debug_log, "%s\n",
4448 _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
4449 *xlen, 1));
58eebef2 4450 }
7d4bcc4a
KW		 4451
4452# endif
58eebef2 4453
3c5f993e 4454 /* Free up unneeded space; retain ehough for trailing NUL */
55e5378d 4455 Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
98994639 4456
6696cfa7
KW		 4457 if (s != input_string) {
4458 Safefree(s);
98994639
HS		 4459 }
4460
98994639
HS		 4461 return xbuf;
4462
4463 bad:
7d4bcc4a
KW		 4464
4465# ifdef DEBUGGING
4466
58eebef2 4467 if (DEBUG_Lv_TEST || debug_initialization) {
c7202dee 4468 print_collxfrm_input_and_return(s, s + len, NULL, utf8);
58eebef2 4469 }
7d4bcc4a
KW		 4470
4471# endif
4472
21dce8f4
KW		 4473 Safefree(xbuf);
4474 if (s != input_string) {
4475 Safefree(s);
4476 }
4477 *xlen = 0;
4478
98994639
HS		 4479 return NULL;
4480}
4481
7d4bcc4a 4482# ifdef DEBUGGING
c7202dee 4483
4cbaac56 4484STATIC void
c7202dee
KW		 4485S_print_collxfrm_input_and_return(pTHX_
4486 const char * const s,
4487 const char * const e,
4488 const STRLEN * const xlen,
4489 const bool is_utf8)
4490{
c7202dee
KW		 4491
4492 PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
4493
511e4ff7
DM		 4494 PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
4495 (UV)PL_collation_ix);
c7202dee 4496 if (xlen) {
08b6dc1d 4497 PerlIO_printf(Perl_debug_log, "%zu", *xlen);
c7202dee
KW		 4498 }
4499 else {
4500 PerlIO_printf(Perl_debug_log, "NULL");
4501 }
4502 PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
4503 PL_collation_name);
9c8a6dc2
KW		 4504 print_bytes_for_locale(s, e, is_utf8);
4505
4506 PerlIO_printf(Perl_debug_log, "'\n");
4507}
4508
4d9252fd
KW		 4509# endif /* DEBUGGING */
4510#endif /* USE_LOCALE_COLLATE */
1c0e67b5
KW		 4511#ifdef USE_LOCALE
4512# ifdef DEBUGGING
4d9252fd 4513
9c8a6dc2
KW		 4514STATIC void
4515S_print_bytes_for_locale(pTHX_
4516 const char * const s,
4517 const char * const e,
4518 const bool is_utf8)
4519{
4520 const char * t = s;
4521 bool prev_was_printable = TRUE;
4522 bool first_time = TRUE;
4523
4524 PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
c7202dee
KW		 4525
4526 while (t < e) {
4527 UV cp = (is_utf8)
4528 ? utf8_to_uvchr_buf((U8 *) t, e, NULL)
4529 : * (U8 *) t;
4530 if (isPRINT(cp)) {
4531 if (! prev_was_printable) {
4532 PerlIO_printf(Perl_debug_log, " ");
4533 }
4534 PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
4535 prev_was_printable = TRUE;
4536 }
4537 else {
4538 if (! first_time) {
4539 PerlIO_printf(Perl_debug_log, " ");
4540 }
147e3846 4541 PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
c7202dee
KW		 4542 prev_was_printable = FALSE;
4543 }
4544 t += (is_utf8) ? UTF8SKIP(t) : 1;
4545 first_time = FALSE;
4546 }
c7202dee
KW		 4547}
4548
1c0e67b5 4549# endif /* #ifdef DEBUGGING */
8ef6e574 4550
962aa53f
KW		 4551STATIC const char *
4552S_switch_category_locale_to_template(pTHX_ const int switch_category, const int template_category, const char * template_locale)
4553{
4554 /* Changes the locale for LC_'switch_category" to that of
4555 * LC_'template_category', if they aren't already the same. If not NULL,
4556 * 'template_locale' is the locale that 'template_category' is in.
4557 *
9de6fe47
KW		 4558 * Returns a copy of the name of the original locale for 'switch_category'
4559 * so can be switched back to with the companion function
4560 * restore_switched_locale(), (NULL if no restoral is necessary.) */
962aa53f
KW		 4561
4562 char * restore_to_locale = NULL;
4563
4564 if (switch_category == template_category) { /* No changes needed */
4565 return NULL;
4566 }
4567
4568 /* Find the original locale of the category we may need to change, so that
4569 * it can be restored to later */
d6189047
KW		 4570 restore_to_locale = stdize_locale(savepv(do_setlocale_r(switch_category,
4571 NULL)));
962aa53f
KW		 4572 if (! restore_to_locale) {
4573 Perl_croak(aTHX_
4574 "panic: %s: %d: Could not find current %s locale, errno=%d\n",
4575 __FILE__, __LINE__, category_name(switch_category), errno);
4576 }
962aa53f
KW		 4577
4578 /* If the locale of the template category wasn't passed in, find it now */
4579 if (template_locale == NULL) {
4580 template_locale = do_setlocale_r(template_category, NULL);
4581 if (! template_locale) {
4582 Perl_croak(aTHX_
4583 "panic: %s: %d: Could not find current %s locale, errno=%d\n",
4584 __FILE__, __LINE__, category_name(template_category), errno);
4585 }
4586 }
4587
4588 /* It the locales are the same, there's nothing to do */
4589 if (strEQ(restore_to_locale, template_locale)) {
4590 Safefree(restore_to_locale);
4591
4592 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale unchanged as %s\n",
e1c8059f 4593 category_name(switch_category), template_locale));
962aa53f
KW		 4594
4595 return NULL;
4596 }
4597
4598 /* Finally, change the locale to the template one */
4599 if (! do_setlocale_r(switch_category, template_locale)) {
4600 Perl_croak(aTHX_
4601 "panic: %s: %d: Could not change %s locale to %s, errno=%d\n",
4602 __FILE__, __LINE__, category_name(switch_category),
4603 template_locale, errno);
4604 }
4605
4606 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale switched to %s\n",
4607 category_name(switch_category), template_locale));
4608
4609 return restore_to_locale;
4610}
4611
4612STATIC void
4613S_restore_switched_locale(pTHX_ const int category, const char * const original_locale)
4614{
9de6fe47
KW		 4615 /* Restores the locale for LC_'category' to 'original_locale' (which is a
4616 * copy that will be freed by this function), or do nothing if the latter
4617 * parameter is NULL */
962aa53f
KW		 4618
4619 if (original_locale == NULL) {
4620 return;
4621 }
4622
4623 if (! do_setlocale_r(category, original_locale)) {
4624 Perl_croak(aTHX_
4625 "panic: %s: %d: setlocale %s restore to %s failed, errno=%d\n",
4626 __FILE__, __LINE__,
4627 category_name(category), original_locale, errno);
4628 }
4629
4630 Safefree(original_locale);
4631}
4632
51332242
N		 4633/* is_cur_LC_category_utf8 uses a small char buffer to avoid malloc/free */
4634#define CUR_LC_BUFFER_SIZE 64
4635
c1284011
KW		 4636bool
4637Perl__is_cur_LC_category_utf8(pTHX_ int category)
7d74bb61
KW		 4638{
4639 /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
4640 * otherwise. 'category' may not be LC_ALL. If the platform doesn't have
119ee68b 4641 * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
609548d2
KW		 4642 * could give the wrong result. The result will very likely be correct for
4643 * languages that have commonly used non-ASCII characters, but for notably
4644 * English, it comes down to if the locale's name ends in something like
9de6fe47
KW		 4645 * "UTF-8". It errs on the side of not being a UTF-8 locale.
4646 *
4647 * If the platform is early C89, not containing mbtowc(), or we are
4648 * compiled to not pay attention to LC_CTYPE, this employs heuristics.
4649 * These work very well for non-Latin locales or those whose currency
4650 * symbol isn't a '$' nor plain ASCII text. But without LC_CTYPE and at
4651 * least MB_CUR_MAX, English locales with an ASCII currency symbol depend
4652 * on the name containing UTF-8 or not. */
7d74bb61 4653
47280b20 4654 /* Name of current locale corresponding to the input category */
8de4332b 4655 const char *save_input_locale = NULL;
47280b20
KW		 4656
4657 bool is_utf8 = FALSE; /* The return value */
7d74bb61 4658
47280b20
KW		 4659 /* The variables below are for the cache of previous lookups using this
4660 * function. The cache is a C string, described at the definition for
4661 * 'C_and_POSIX_utf8ness'.
4662 *
4663 * The first part of the cache is fixed, for the C and POSIX locales. The
4664 * varying part starts just after them. */
4665 char * utf8ness_cache = PL_locale_utf8ness + STRLENs(C_and_POSIX_utf8ness);
4666
4667 Size_t utf8ness_cache_size; /* Size of the varying portion */
4668 Size_t input_name_len; /* Length in bytes of save_input_locale */
4669 Size_t input_name_len_with_overhead; /* plus extra chars used to store
4670 the name in the cache */
4671 char * delimited; /* The name plus the delimiters used to store
4672 it in the cache */
51332242 4673 char buffer[CUR_LC_BUFFER_SIZE]; /* small buffer */
47280b20
KW		 4674 char * name_pos; /* position of 'delimited' in the cache, or 0
4675 if not there */
4676
4677
7d4bcc4a
KW		 4678# ifdef LC_ALL
4679
7d74bb61 4680 assert(category != LC_ALL);
7d4bcc4a
KW		 4681
4682# endif
7d74bb61 4683
47280b20 4684 /* Get the desired category's locale */
d6189047 4685 save_input_locale = stdize_locale(savepv(do_setlocale_r(category, NULL)));
7d74bb61 4686 if (! save_input_locale) {
47280b20 4687 Perl_croak(aTHX_
d707d779
KW		 4688 "panic: %s: %d: Could not find current %s locale, errno=%d\n",
4689 __FILE__, __LINE__, category_name(category), errno);
7d74bb61 4690 }
47280b20 4691
47280b20
KW		 4692 DEBUG_L(PerlIO_printf(Perl_debug_log,
4693 "Current locale for %s is %s\n",
4694 category_name(category), save_input_locale));
4695
4696 input_name_len = strlen(save_input_locale);
4697
4698 /* In our cache, each name is accompanied by two delimiters and a single
4699 * utf8ness digit */
4700 input_name_len_with_overhead = input_name_len + 3;
4701
51332242
N		 4702 if ( input_name_len_with_overhead <= CUR_LC_BUFFER_SIZE ) {
4703 /* we can use the buffer, avoid a malloc */
4704 delimited = buffer;
4705 } else { /* need a malloc */
4706 /* Allocate and populate space for a copy of the name surrounded by the
4707 * delimiters */
4708 Newx(delimited, input_name_len_with_overhead, char);
4709 }
4710
47280b20
KW		 4711 delimited[0] = UTF8NESS_SEP[0];
4712 Copy(save_input_locale, delimited + 1, input_name_len, char);
4713 delimited[input_name_len+1] = UTF8NESS_PREFIX[0];
4714 delimited[input_name_len+2] = '\0';
4715
4716 /* And see if that is in the cache */
4717 name_pos = instr(PL_locale_utf8ness, delimited);
4718 if (name_pos) {
4719 is_utf8 = *(name_pos + input_name_len_with_overhead - 1) - '0';
4720
4721# ifdef DEBUGGING
4722
4723 if (DEBUG_Lv_TEST || debug_initialization) {
4724 PerlIO_printf(Perl_debug_log, "UTF8ness for locale %s=%d, \n",
4725 save_input_locale, is_utf8);
4726 }
4727
4728# endif
4729
4730 /* And, if not already in that position, move it to the beginning of
4731 * the non-constant portion of the list, since it is the most recently
4732 * used. (We don't have to worry about overflow, since just moving
4733 * existing names around) */
4734 if (name_pos > utf8ness_cache) {
4735 Move(utf8ness_cache,
4736 utf8ness_cache + input_name_len_with_overhead,
4737 name_pos - utf8ness_cache, char);
4738 Copy(delimited,
4739 utf8ness_cache,
4740 input_name_len_with_overhead - 1, char);
4741 utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
4742 }
4743
51332242
N		 4744 /* free only when not using the buffer */
4745 if ( delimited != buffer ) Safefree(delimited);
b07fffd1 4746 Safefree(save_input_locale);
47280b20 4747 return is_utf8;
7d74bb61
KW		 4748 }
4749
47280b20
KW		 4750 /* Here we don't have stored the utf8ness for the input locale. We have to
4751 * calculate it */
4752
94646a69 4753# if defined(USE_LOCALE_CTYPE) \
6201c220 4754 && ( defined(HAS_NL_LANGINFO) \
94646a69 4755 || (defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)))
7d74bb61 4756
0dec74cd 4757 {
962aa53f
KW		 4758 const char *original_ctype_locale
4759 = switch_category_locale_to_template(LC_CTYPE,
4760 category,
4761 save_input_locale);
69014004 4762
7d74bb61 4763 /* Here the current LC_CTYPE is set to the locale of the category whose
0dec74cd 4764 * information is desired. This means that nl_langinfo() and mbtowc()
1d958db2 4765 * should give the correct results */
119ee68b 4766
0dec74cd
KW		 4767# ifdef MB_CUR_MAX /* But we can potentially rule out UTF-8ness, avoiding
4768 calling the functions if we have this */
4769
4770 /* Standard UTF-8 needs at least 4 bytes to represent the maximum
4771 * Unicode code point. */
4772
de3a3072
KW		 4773 DEBUG_L(PerlIO_printf(Perl_debug_log, "%s: %d: MB_CUR_MAX=%d\n",
4774 __FILE__, __LINE__, (int) MB_CUR_MAX));
0dec74cd
KW		 4775 if ((unsigned) MB_CUR_MAX < STRLENs(MAX_UNICODE_UTF8)) {
4776 is_utf8 = FALSE;
b5b2847c
KW		 4777 restore_switched_locale(LC_CTYPE, original_ctype_locale);
4778 goto finish_and_return;
0dec74cd
KW		 4779 }
4780
4781# endif
6201c220 4782# if defined(HAS_NL_LANGINFO)
7d4bcc4a 4783
0dec74cd
KW		 4784 { /* The task is easiest if the platform has this POSIX 2001 function.
4785 Except on some platforms it can wrongly return "", so have to have
4786 a fallback. And it can return that it's UTF-8, even if there are
4787 variances from that. For example, Turkish locales may use the
4788 alternate dotted I rules, and sometimes it appears to be a
4789 defective locale definition. XXX We should probably check for
9de6fe47
KW		 4790 these in the Latin1 range and warn (but on glibc, requires
4791 iswalnum() etc. due to their not handling 80-FF correctly */
4e6826bf 4792 const char *codeset = my_nl_langinfo(CODESET, FALSE);
c70a3e68 4793 /* FALSE => already in dest locale */
119ee68b 4794
af84e886 4795 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
c70a3e68
KW		 4796 "\tnllanginfo returned CODESET '%s'\n", codeset));
4797
4798 if (codeset && strNE(codeset, "")) {
1d958db2 4799
1d075173
KW		 4800 /* If the implementation of foldEQ() somehow were
4801 * to change to not go byte-by-byte, this could
4802 * read past end of string, as only one length is
4803 * checked. But currently, a premature NUL will
4804 * compare false, and it will stop there */
4805 is_utf8 = cBOOL( foldEQ(codeset, STR_WITH_LEN("UTF-8"))
4806 || foldEQ(codeset, STR_WITH_LEN("UTF8")));
1d958db2 4807
69014004
KW		 4808 DEBUG_L(PerlIO_printf(Perl_debug_log,
4809 "\tnllanginfo returned CODESET '%s'; ?UTF8 locale=%d\n",
4810 codeset, is_utf8));
b5b2847c
KW		 4811 restore_switched_locale(LC_CTYPE, original_ctype_locale);
4812 goto finish_and_return;
1d958db2 4813 }
119ee68b
KW		 4814 }
4815
7d4bcc4a 4816# endif
94646a69 4817# if defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
0dec74cd
KW		 4818 /* We can see if this is a UTF-8-like locale if have mbtowc(). It was a
4819 * late adder to C89, so very likely to have it. However, testing has
4820 * shown that, like nl_langinfo() above, there are locales that are not
4821 * strictly UTF-8 that this will return that they are */
69014004 4822
0dec74cd 4823 {
119ee68b 4824 wchar_t wc;
51fc4b19 4825 int len;
48015184 4826 dSAVEDERRNO;
51fc4b19 4827
94646a69
KW		 4828# if defined(HAS_MBRTOWC) && defined(USE_ITHREADS)
4829
4830 mbstate_t ps;
4831
4832# endif
4833
4834 /* mbrtowc() and mbtowc() convert a byte string to a wide
4835 * character. Feed a byte string to one of them and check that the
4836 * result is the expected Unicode code point */
4837
4838# if defined(HAS_MBRTOWC) && defined(USE_ITHREADS)
4839 /* Prefer this function if available, as it's reentrant */
4840
4841 memset(&ps, 0, sizeof(ps));;
4842 PERL_UNUSED_RESULT(mbrtowc(&wc, NULL, 0, &ps)); /* Reset any shift
4843 state */
48015184 4844 SETERRNO(0, 0);
94646a69 4845 len = mbrtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8), &ps);
48015184 4846 SAVE_ERRNO;
94646a69
KW		 4847
4848# else
0dec74cd 4849
5a91a58b 4850 LOCALE_LOCK;
856b881c 4851 PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
48015184 4852 SETERRNO(0, 0);
b1d4925c 4853 len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
48015184 4854 SAVE_ERRNO;
5a91a58b 4855 LOCALE_UNLOCK;
51fc4b19 4856
94646a69
KW		 4857# endif
4858
48015184 4859 RESTORE_ERRNO;
af84e886 4860 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
0dec74cd 4861 "\treturn from mbtowc; len=%d; code_point=%x; errno=%d\n",
48015184 4862 len, (unsigned int) wc, GET_ERRNO));
b1d4925c 4863
0dec74cd
KW		 4864 is_utf8 = cBOOL( len == STRLENs(REPLACEMENT_CHARACTER_UTF8)
4865 && wc == (wchar_t) UNICODE_REPLACEMENT);
119ee68b 4866 }
7d4bcc4a 4867
17dd77cd
FP		 4868# endif
4869
962aa53f 4870 restore_switched_locale(LC_CTYPE, original_ctype_locale);
47280b20 4871 goto finish_and_return;
7d74bb61 4872 }
119ee68b 4873
0dec74cd 4874# else
7d74bb61 4875
0dec74cd
KW		 4876 /* Here, we must have a C89 compiler that doesn't have mbtowc(). Next
4877 * try looking at the currency symbol to see if it disambiguates
4878 * things. Often that will be in the native script, and if the symbol
4879 * isn't in UTF-8, we know that the locale isn't. If it is non-ASCII
4880 * UTF-8, we infer that the locale is too, as the odds of a non-UTF8
4881 * string being valid UTF-8 are quite small */
fa9b773e 4882
660ee27b
KW		 4883# ifdef USE_LOCALE_MONETARY
4884
4885 /* If have LC_MONETARY, we can look at the currency symbol. Often that
4886 * will be in the native script. We do this one first because there is
4887 * just one string to examine, so potentially avoids work */
7d4bcc4a 4888
9db16864
KW		 4889 {
4890 const char *original_monetary_locale
660ee27b
KW		 4891 = switch_category_locale_to_template(LC_MONETARY,
4892 category,
4893 save_input_locale);
9db16864 4894 bool only_ascii = FALSE;
660ee27b 4895 const U8 * currency_string
4e6826bf 4896 = (const U8 *) my_nl_langinfo(CRNCYSTR, FALSE);
660ee27b
KW		 4897 /* 2nd param not relevant for this item */
4898 const U8 * first_variant;
fa9b773e 4899
660ee27b
KW		 4900 assert( *currency_string == '-'
4901 || *currency_string == '+'
4902 || *currency_string == '.');
97f4de96 4903
660ee27b 4904 currency_string++;
fa9b773e 4905
660ee27b 4906 if (is_utf8_invariant_string_loc(currency_string, 0, &first_variant))
9db16864
KW		 4907 {
4908 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));
4909 only_ascii = TRUE;
4910 }
4911 else {
660ee27b 4912 is_utf8 = is_strict_utf8_string(first_variant, 0);
9db16864 4913 }
fa9b773e 4914
9db16864 4915 restore_switched_locale(LC_MONETARY, original_monetary_locale);
fa9b773e 4916
9db16864 4917 if (! only_ascii) {
fa9b773e 4918
9db16864
KW		 4919 /* It isn't a UTF-8 locale if the symbol is not legal UTF-8;
4920 * otherwise assume the locale is UTF-8 if and only if the symbol
4921 * is non-ascii UTF-8. */
af84e886 4922 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n",
9db16864
KW		 4923 save_input_locale, is_utf8));
4924 goto finish_and_return;
4925 }
13542a67 4926 }
fa9b773e 4927
660ee27b 4928# endif /* USE_LOCALE_MONETARY */
7d4bcc4a 4929# if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME)
15f7e74e 4930
9db16864
KW		 4931 /* Still haven't found a non-ASCII string to disambiguate UTF-8 or not. Try
4932 * the names of the months and weekdays, timezone, and am/pm indicator */
4933 {
4934 const char *original_time_locale
4935 = switch_category_locale_to_template(LC_TIME,
4936 category,
4937 save_input_locale);
4938 int hour = 10;
4939 bool is_dst = FALSE;
4940 int dom = 1;
4941 int month = 0;
4942 int i;
4943 char * formatted_time;
4944
4945 /* Here the current LC_TIME is set to the locale of the category
4946 * whose information is desired. Look at all the days of the week and
4947 * month names, and the timezone and am/pm indicator for UTF-8 variant
4948 * characters. The first such a one found will tell us if the locale
4949 * is UTF-8 or not */
4950
4951 for (i = 0; i < 7 + 12; i++) { /* 7 days; 12 months */
4952 formatted_time = my_strftime("%A %B %Z %p",
4953 0, 0, hour, dom, month, 2012 - 1900, 0, 0, is_dst);
4954 if ( ! formatted_time
4955 || is_utf8_invariant_string((U8 *) formatted_time, 0))
4956 {
15f7e74e 4957
9db16864
KW		 4958 /* Here, we didn't find a non-ASCII. Try the next time through
4959 * with the complemented dst and am/pm, and try with the next
4960 * weekday. After we have gotten all weekdays, try the next
4961 * month */
4962 is_dst = ! is_dst;
4963 hour = (hour + 12) % 24;
4964 dom++;
4965 if (i > 6) {
4966 month++;
4967 }
4968 continue;
15f7e74e 4969 }
9db16864
KW		 4970
4971 /* Here, we have a non-ASCII. Return TRUE is it is valid UTF8;
4972 * false otherwise. But first, restore LC_TIME to its original
4973 * locale if we changed it */
4974 restore_switched_locale(LC_TIME, original_time_locale);
4975
af84e886 4976 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n",
9db16864
KW		 4977 save_input_locale,
4978 is_utf8_string((U8 *) formatted_time, 0)));
4979 is_utf8 = is_utf8_string((U8 *) formatted_time, 0);
4980 goto finish_and_return;
15f7e74e
KW		 4981 }
4982
9db16864
KW		 4983 /* Falling off the end of the loop indicates all the names were just
4984 * ASCII. Go on to the next test. If we changed it, restore LC_TIME
4985 * to its original locale */
962aa53f 4986 restore_switched_locale(LC_TIME, original_time_locale);
af84e886 4987 DEBUG_Lv(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));
15f7e74e
KW		 4988 }
4989
7d4bcc4a 4990# endif
15f7e74e 4991
7d4bcc4a 4992# if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST)
855aeb93 4993
9db16864
KW		 4994 /* This code is ifdefd out because it was found to not be necessary in testing
4995 * on our dromedary test machine, which has over 700 locales. There, this
4996 * added no value to looking at the currency symbol and the time strings. I
4997 * left it in so as to avoid rewriting it if real-world experience indicates
4998 * that dromedary is an outlier. Essentially, instead of returning abpve if we
4999 * haven't found illegal utf8, we continue on and examine all the strerror()
5000 * messages on the platform for utf8ness. If all are ASCII, we still don't
5001 * know the answer; but otherwise we have a pretty good indication of the
5002 * utf8ness. The reason this doesn't help much is that the messages may not
5003 * have been translated into the locale. The currency symbol and time strings
5004 * are much more likely to have been translated. */
5005 {
5006 int e;
5007 bool non_ascii = FALSE;
5008 const char *original_messages_locale
5009 = switch_category_locale_to_template(LC_MESSAGES,
5010 category,
5011 save_input_locale);
5012 const char * errmsg = NULL;
5013
5014 /* Here the current LC_MESSAGES is set to the locale of the category
5015 * whose information is desired. Look through all the messages. We
5016 * can't use Strerror() here because it may expand to code that
5017 * segfaults in miniperl */
5018
5019 for (e = 0; e <= sys_nerr; e++) {
5020 errno = 0;
5021 errmsg = sys_errlist[e];
5022 if (errno || !errmsg) {
5023 break;
5024 }
5025 errmsg = savepv(errmsg);
5026 if (! is_utf8_invariant_string((U8 *) errmsg, 0)) {
5027 non_ascii = TRUE;
5028 is_utf8 = is_utf8_string((U8 *) errmsg, 0);
5029 break;
5030 }
855aeb93 5031 }
9db16864 5032 Safefree(errmsg);
855aeb93 5033
9db16864 5034 restore_switched_locale(LC_MESSAGES, original_messages_locale);
855aeb93 5035
9db16864 5036 if (non_ascii) {
5857e934 5037
9db16864
KW		 5038 /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
5039 * any non-ascii means it is one; otherwise we assume it isn't */
af84e886 5040 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n",
9db16864
KW		 5041 save_input_locale,
5042 is_utf8));
5043 goto finish_and_return;
5044 }
855aeb93 5045
9db16864
KW		 5046 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));
5047 }
855aeb93 5048
7d4bcc4a 5049# endif
0dec74cd 5050# ifndef EBCDIC /* On os390, even if the name ends with "UTF-8', it isn't a
92c0a900 5051 UTF-8 locale */
7d4bcc4a 5052
97f4de96
KW		 5053 /* As a last resort, look at the locale name to see if it matches
5054 * qr/UTF -? * 8 /ix, or some other common locale names. This "name", the
5055 * return of setlocale(), is actually defined to be opaque, so we can't
5056 * really rely on the absence of various substrings in the name to indicate
5057 * its UTF-8ness, but if it has UTF8 in the name, it is extremely likely to
5058 * be a UTF-8 locale. Similarly for the other common names */
5059
0dec74cd 5060 {
c36d8df8 5061 const Size_t final_pos = strlen(save_input_locale) - 1;
0dec74cd 5062
c36d8df8
KW		 5063 if (final_pos >= 3) {
5064 const char *name = save_input_locale;
97f4de96 5065
c36d8df8
KW		 5066 /* Find next 'U' or 'u' and look from there */
5067 while ((name += strcspn(name, "Uu") + 1)
5068 <= save_input_locale + final_pos - 2)
97f4de96 5069 {
c36d8df8
KW		 5070 if ( isALPHA_FOLD_NE(*name, 't')
5071 || isALPHA_FOLD_NE(*(name + 1), 'f'))
5072 {
5073 continue;
5074 }
5075 name += 2;
5076 if (*(name) == '-') {
5077 if ((name > save_input_locale + final_pos - 1)) {
5078 break;
5079 }
5080 name++;
5081 }
5082 if (*(name) == '8') {
5083 DEBUG_L(PerlIO_printf(Perl_debug_log,
5084 "Locale %s ends with UTF-8 in name\n",
5085 save_input_locale));
5086 is_utf8 = TRUE;
5087 goto finish_and_return;
97f4de96 5088 }
97f4de96 5089 }
c36d8df8
KW		 5090 DEBUG_L(PerlIO_printf(Perl_debug_log,
5091 "Locale %s doesn't end with UTF-8 in name\n",
5092 save_input_locale));
97f4de96 5093 }
97f4de96 5094
4d8d465a 5095# ifdef WIN32
7d4bcc4a 5096
c36d8df8
KW		 5097 /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
5098 if (memENDs(save_input_locale, final_pos, "65001")) {
5099 DEBUG_L(PerlIO_printf(Perl_debug_log,
8a0832a1 5100 "Locale %s ends with 65001 in name, is UTF-8 locale\n",
97f4de96 5101 save_input_locale));
c36d8df8
KW		 5102 is_utf8 = TRUE;
5103 goto finish_and_return;
5104 }
7d4bcc4a 5105
4d8d465a 5106# endif
17dd77cd 5107 }
4d8d465a 5108# endif
97f4de96
KW		 5109
5110 /* Other common encodings are the ISO 8859 series, which aren't UTF-8. But
5111 * since we are about to return FALSE anyway, there is no point in doing
5112 * this extra work */
7d4bcc4a 5113
0dec74cd 5114# if 0
97f4de96
KW		 5115 if (instr(save_input_locale, "8859")) {
5116 DEBUG_L(PerlIO_printf(Perl_debug_log,
5117 "Locale %s has 8859 in name, not UTF-8 locale\n",
5118 save_input_locale));
47280b20
KW		 5119 is_utf8 = FALSE;
5120 goto finish_and_return;
97f4de96 5121 }
0dec74cd 5122# endif
97f4de96 5123
69014004
KW		 5124 DEBUG_L(PerlIO_printf(Perl_debug_log,
5125 "Assuming locale %s is not a UTF-8 locale\n",
5126 save_input_locale));
47280b20
KW		 5127 is_utf8 = FALSE;
5128
0dec74cd
KW		 5129# endif /* the code that is compiled when no modern LC_CTYPE */
5130
47280b20
KW		 5131 finish_and_return:
5132
5133 /* Cache this result so we don't have to go through all this next time. */
5134 utf8ness_cache_size = sizeof(PL_locale_utf8ness)
5135 - (utf8ness_cache - PL_locale_utf8ness);
5136
5137 /* But we can't save it if it is too large for the total space available */
5138 if (LIKELY(input_name_len_with_overhead < utf8ness_cache_size)) {
5139 Size_t utf8ness_cache_len = strlen(utf8ness_cache);
5140
5141 /* Here it can fit, but we may need to clear out the oldest cached
5142 * result(s) to do so. Check */
5143 if (utf8ness_cache_len + input_name_len_with_overhead
5144 >= utf8ness_cache_size)
5145 {
5146 /* Here we have to clear something out to make room for this.
5147 * Start looking at the rightmost place where it could fit and find
5148 * the beginning of the entry that extends past that. */
5149 char * cutoff = (char *) my_memrchr(utf8ness_cache,
5150 UTF8NESS_SEP[0],
5151 utf8ness_cache_size
5152 - input_name_len_with_overhead);
5153
5154 assert(cutoff);
5155 assert(cutoff >= utf8ness_cache);
5156
5157 /* This and all subsequent entries must be removed */
5158 *cutoff = '\0';
5159 utf8ness_cache_len = strlen(utf8ness_cache);
5160 }
5161
5162 /* Make space for the new entry */
5163 Move(utf8ness_cache,
5164 utf8ness_cache + input_name_len_with_overhead,
5165 utf8ness_cache_len + 1 /* Incl. trailing NUL */, char);
5166
5167 /* And insert it */
5168 Copy(delimited, utf8ness_cache, input_name_len_with_overhead - 1, char);
5169 utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
5170
72299e00 5171 if ((PL_locale_utf8ness[strlen(PL_locale_utf8ness)-1] & ~1) != '0') {
47280b20 5172 Perl_croak(aTHX_
7fcf9272
KW		 5173 "panic: %s: %d: Corrupt utf8ness_cache=%s\nlen=%zu,"
5174 " inserted_name=%s, its_len=%zu\n",
47280b20
KW		 5175 __FILE__, __LINE__,
5176 PL_locale_utf8ness, strlen(PL_locale_utf8ness),
5177 delimited, input_name_len_with_overhead);
5178 }
5179 }
5180
5181# ifdef DEBUGGING
5182
de3a3072
KW		 5183 if (DEBUG_Lv_TEST) {
5184 const char * s = PL_locale_utf8ness;
5185
5186 /* Audit the structure */
5187 while (s < PL_locale_utf8ness + strlen(PL_locale_utf8ness)) {
5188 const char *e;
5189
5190 if (*s != UTF8NESS_SEP[0]) {
5191 Perl_croak(aTHX_
5192 "panic: %s: %d: Corrupt utf8ness_cache: missing"
5193 " separator %.*s<-- HERE %s\n",
5194 __FILE__, __LINE__,
fe301c93 5195 (int) (s - PL_locale_utf8ness), PL_locale_utf8ness,
de3a3072
KW		 5196 s);
5197 }
5198 s++;
5199 e = strchr(s, UTF8NESS_PREFIX[0]);
5200 if (! e) {
01b91050 5201 e = PL_locale_utf8ness + strlen(PL_locale_utf8ness);
de3a3072
KW		 5202 Perl_croak(aTHX_
5203 "panic: %s: %d: Corrupt utf8ness_cache: missing"
5204 " separator %.*s<-- HERE %s\n",
5205 __FILE__, __LINE__,
fe301c93 5206 (int) (e - PL_locale_utf8ness), PL_locale_utf8ness,
de3a3072
KW		 5207 e);
5208 }
5209 e++;
5210 if (*e != '0' && *e != '1') {
5211 Perl_croak(aTHX_
5212 "panic: %s: %d: Corrupt utf8ness_cache: utf8ness"
5213 " must be [01] %.*s<-- HERE %s\n",
5214 __FILE__, __LINE__,
fe301c93
KW		 5215 (int) (e + 1 - PL_locale_utf8ness),
5216 PL_locale_utf8ness, e + 1);
de3a3072
KW		 5217 }
5218 if (ninstr(PL_locale_utf8ness, s, s-1, e)) {
5219 Perl_croak(aTHX_
5220 "panic: %s: %d: Corrupt utf8ness_cache: entry"
5221 " has duplicate %.*s<-- HERE %s\n",
5222 __FILE__, __LINE__,
fe301c93 5223 (int) (e - PL_locale_utf8ness), PL_locale_utf8ness,
de3a3072
KW		 5224 e);
5225 }
5226 s = e + 1;
5227 }
5228 }
5229
47280b20 5230 if (DEBUG_Lv_TEST || debug_initialization) {
de3a3072 5231
47280b20
KW		 5232 PerlIO_printf(Perl_debug_log,
5233 "PL_locale_utf8ness is now %s; returning %d\n",
5234 PL_locale_utf8ness, is_utf8);
5235 }
5236
5237# endif
5238
51332242
N		 5239 /* free only when not using the buffer */
5240 if ( delimited != buffer ) Safefree(delimited);
fa9b773e 5241 Safefree(save_input_locale);
47280b20 5242 return is_utf8;
7d74bb61
KW		 5243}
5244
8ef6e574 5245#endif
7d74bb61 5246
d6ded950
KW		 5247bool
5248Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
5249{
5250 /* Internal function which returns if we are in the scope of a pragma that
5251 * enables the locale category 'category'. 'compiling' should indicate if
5252 * this is during the compilation phase (TRUE) or not (FALSE). */
5253
5254 const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
5255
363d7d4a
JK		 5256 SV *these_categories = cop_hints_fetch_pvs(cop, "locale", 0);
5257 if (! these_categories || these_categories == &PL_sv_placeholder) {
d6ded950
KW		 5258 return FALSE;
5259 }
5260
5261 /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
5262 * a valid unsigned */
5263 assert(category >= -1);
363d7d4a 5264 return cBOOL(SvUV(these_categories) & (1U << (category + 1)));
d6ded950
KW		 5265}
5266
2c6ee1a7 5267char *
6ebbc862
KW		 5268Perl_my_strerror(pTHX_ const int errnum)
5269{
5270 /* Returns a mortalized copy of the text of the error message associated
5271 * with 'errnum'. It uses the current locale's text unless the platform
5272 * doesn't have the LC_MESSAGES category or we are not being called from
5273 * within the scope of 'use locale'. In the former case, it uses whatever
5274 * strerror returns; in the latter case it uses the text from the C locale.
5275 *
5276 * The function just calls strerror(), but temporarily switches, if needed,
5277 * to the C locale */
5278
5279 char *errstr;
5280
52770946 5281#ifndef USE_LOCALE_MESSAGES
6ebbc862 5282
52770946
KW		 5283 /* If platform doesn't have messages category, we don't do any switching to
5284 * the C locale; we just use whatever strerror() returns */
5285
5286 errstr = savepv(Strerror(errnum));
5287
5288#else /* Has locale messages */
5289
5290 const bool within_locale_scope = IN_LC(LC_MESSAGES);
2c6ee1a7 5291
39e69e77 5292# ifndef USE_ITHREADS
7aaa36b1 5293
39e69e77
KW		 5294 /* This function is trivial without threads. */
5295 if (within_locale_scope) {
5296 errstr = savepv(strerror(errnum));
5297 }
5298 else {
b0bde642 5299 const char * save_locale = savepv(do_setlocale_c(LC_MESSAGES, NULL));
39e69e77
KW		 5300
5301 do_setlocale_c(LC_MESSAGES, "C");
5302 errstr = savepv(strerror(errnum));
5303 do_setlocale_c(LC_MESSAGES, save_locale);
b0bde642 5304 Safefree(save_locale);
39e69e77
KW		 5305 }
5306
fd639d5f
KW		 5307# elif defined(USE_POSIX_2008_LOCALE) \
5308 && defined(HAS_STRERROR_L) \
5309 && defined(HAS_DUPLOCALE)
39e69e77
KW		 5310
5311 /* This function is also trivial if we don't have to worry about thread
5312 * safety and have strerror_l(), as it handles the switch of locales so we
5313 * don't have to deal with that. We don't have to worry about thread
5314 * safety if strerror_r() is also available. Both it and strerror_l() are
5315 * thread-safe. Plain strerror() isn't thread safe. But on threaded
5316 * builds when strerror_r() is available, the apparent call to strerror()
5317 * below is actually a macro that behind-the-scenes calls strerror_r(). */
43cb6651 5318
39e69e77 5319# ifdef HAS_STRERROR_R
7aaa36b1
KW		 5320
5321 if (within_locale_scope) {
4eb27fc5 5322 errstr = savepv(strerror(errnum));
7aaa36b1
KW		 5323 }
5324 else {
4eb27fc5 5325 errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
7aaa36b1
KW		 5326 }
5327
43cb6651
KW		 5328# else
5329
5330 /* Here we have strerror_l(), but not strerror_r() and we are on a
5331 * threaded-build. We use strerror_l() for everything, constructing a
5332 * locale to pass to it if necessary */
5333
5334 bool do_free = FALSE;
5335 locale_t locale_to_use;
5336
5337 if (within_locale_scope) {
5338 locale_to_use = uselocale((locale_t) 0);
5339 if (locale_to_use == LC_GLOBAL_LOCALE) {
5340 locale_to_use = duplocale(LC_GLOBAL_LOCALE);
5341 do_free = TRUE;
5342 }
5343 }
5344 else { /* Use C locale if not within 'use locale' scope */
5345 locale_to_use = PL_C_locale_obj;
5346 }
5347
5348 errstr = savepv(strerror_l(errnum, locale_to_use));
5349
5350 if (do_free) {
5351 freelocale(locale_to_use);
5352 }
5353
5354# endif
5355# else /* Doesn't have strerror_l() */
7aaa36b1 5356
8de4332b 5357 const char * save_locale = NULL;
c9dda6da 5358 bool locale_is_C = FALSE;
2c6ee1a7 5359
9de6fe47 5360 /* We have a critical section to prevent another thread from executing this
e9bc6d6b 5361 * same code at the same time. (On thread-safe perls, the LOCK is a
9de6fe47
KW		 5362 * no-op.) Since this is the only place in core that changes LC_MESSAGES
5363 * (unless the user has called setlocale(), this works to prevent races. */
6ebbc862
KW		 5364 LOCALE_LOCK;
5365
9c8a6dc2
KW		 5366 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5367 "my_strerror called with errnum %d\n", errnum));
6ebbc862 5368 if (! within_locale_scope) {
837ce802 5369 save_locale = do_setlocale_c(LC_MESSAGES, NULL);
c9dda6da 5370 if (! save_locale) {
d707d779
KW		 5371 Perl_croak(aTHX_
5372 "panic: %s: %d: Could not find current LC_MESSAGES locale,"
5373 " errno=%d\n", __FILE__, __LINE__, errno);
c9dda6da
KW		 5374 }
5375 else {
5376 locale_is_C = isNAME_C_OR_POSIX(save_locale);
2c6ee1a7 5377
c9dda6da
KW		 5378 /* Switch to the C locale if not already in it */
5379 if (! locale_is_C) {
2c6ee1a7 5380
c9dda6da
KW		 5381 /* The setlocale() just below likely will zap 'save_locale', so
5382 * create a copy. */
5383 save_locale = savepv(save_locale);
837ce802 5384 do_setlocale_c(LC_MESSAGES, "C");
c9dda6da 5385 }
6ebbc862 5386 }
6ebbc862 5387 } /* end of ! within_locale_scope */
9c8a6dc2
KW		 5388 else {
5389 DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n",
5390 __FILE__, __LINE__));
5391 }
a0b53297 5392
9c8a6dc2
KW		 5393 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5394 "Any locale change has been done; about to call Strerror\n"));
52770946 5395 errstr = savepv(Strerror(errnum));
6ebbc862
KW		 5396
5397 if (! within_locale_scope) {
c9dda6da 5398 if (save_locale && ! locale_is_C) {
837ce802 5399 if (! do_setlocale_c(LC_MESSAGES, save_locale)) {
d707d779
KW		 5400 Perl_croak(aTHX_
5401 "panic: %s: %d: setlocale restore failed, errno=%d\n",
5402 __FILE__, __LINE__, errno);
c9dda6da 5403 }
6ebbc862
KW		 5404 Safefree(save_locale);
5405 }
5406 }
5407
5408 LOCALE_UNLOCK;
5409
7aaa36b1 5410# endif /* End of doesn't have strerror_l */
d36adde0 5411# ifdef DEBUGGING
6affbbf0
KW		 5412
5413 if (DEBUG_Lv_TEST) {
5414 PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '");
5415 print_bytes_for_locale(errstr, errstr + strlen(errstr), 0);
5416 PerlIO_printf(Perl_debug_log, "'\n");
5417 }
5418
d36adde0
KW		 5419# endif
5420#endif /* End of does have locale messages */
2c6ee1a7 5421
52770946 5422 SAVEFREEPV(errstr);
6ebbc862 5423 return errstr;
2c6ee1a7
KW		 5424}
5425
66610fdd 5426/*
747c467a 5427
58e641fb
KW		 5428=for apidoc switch_to_global_locale
5429
75920755 5430On systems without locale support, or on typical single-threaded builds, or on
58e641fb
KW		 5431platforms that do not support per-thread locale operations, this function does
5432nothing. On such systems that do have locale support, only a locale global to
5433the whole program is available.
5434
5435On multi-threaded builds on systems that do have per-thread locale operations,
5436this function converts the thread it is running in to use the global locale.
5437This is for code that has not yet or cannot be updated to handle multi-threaded
5438locale operation. As long as only a single thread is so-converted, everything
5439works fine, as all the other threads continue to ignore the global one, so only
5440this thread looks at it.
5441
69c5e0db
KW		 5442However, on Windows systems this isn't quite true prior to Visual Studio 15,
5443at which point Microsoft fixed a bug. A race can occur if you use the
5444following operations on earlier Windows platforms:
5445
5446=over
5447
5448=item L<POSIX::localeconv|POSIX/localeconv>
5449
5450=item L<I18N::Langinfo>, items C<CRNCYSTR> and C<THOUSEP>
5451
5452=item L<perlapi/Perl_langinfo>, items C<CRNCYSTR> and C<THOUSEP>
5453
5454=back
5455
5456The first item is not fixable (except by upgrading to a later Visual Studio
5457release), but it would be possible to work around the latter two items by using
5458the Windows API functions C<GetNumberFormat> and C<GetCurrencyFormat>; patches
5459welcome.
5460
58e641fb
KW		 5461Without this function call, threads that use the L<C<setlocale(3)>> system
5462function will not work properly, as all the locale-sensitive functions will
5463look at the per-thread locale, and C<setlocale> will have no effect on this
5464thread.
5465
5466Perl code should convert to either call
5467L<C<Perl_setlocale>|perlapi/Perl_setlocale> (which is a drop-in for the system
5468C<setlocale>) or use the methods given in L<perlcall> to call
5469L<C<POSIX::setlocale>|POSIX/setlocale>. Either one will transparently properly
5470handle all cases of single- vs multi-thread, POSIX 2008-supported or not.
5471
5472Non-Perl libraries, such as C<gtk>, that call the system C<setlocale> can
5473continue to work if this function is called before transferring control to the
5474library.
5475
5476Upon return from the code that needs to use the global locale,
5477L<C<sync_locale()>|perlapi/sync_locale> should be called to restore the safe
5478multi-thread operation.
5479
5480=cut
5481*/
5482
5483void
5484Perl_switch_to_global_locale()
5485{
5486
5487#ifdef USE_THREAD_SAFE_LOCALE
5488# ifdef WIN32
5489
5490 _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
5491
5492# else
5493# ifdef HAS_QUERYLOCALE
5494
5495 setlocale(LC_ALL, querylocale(LC_ALL_MASK, uselocale((locale_t) 0)));
5496
5497# else
5498
5499 {
5500 unsigned int i;
5501
5502 for (i = 0; i < LC_ALL_INDEX; i++) {
5503 setlocale(categories[i], do_setlocale_r(categories[i], NULL));
5504 }
5505 }
5506
5507# endif
5508
5509 uselocale(LC_GLOBAL_LOCALE);
5510
5511# endif
5512#endif
5513
5514}
5515
5516/*
5517
747c467a
KW		 5518=for apidoc sync_locale
5519
b2e9ba0c
KW		 5520L<C<Perl_setlocale>|perlapi/Perl_setlocale> can be used at any time to query or
5521change the locale (though changing the locale is antisocial and dangerous on
5522multi-threaded systems that don't have multi-thread safe locale operations.
5523(See L<perllocale/Multi-threaded operation>). Using the system
5524L<C<setlocale(3)>> should be avoided. Nevertheless, certain non-Perl libraries
5525called from XS, such as C<Gtk> do so, and this can't be changed. When the
5526locale is changed by XS code that didn't use
5527L<C<Perl_setlocale>|perlapi/Perl_setlocale>, Perl needs to be told that the
5528locale has changed. Use this function to do so, before returning to Perl.
5529
5530The return value is a boolean: TRUE if the global locale at the time of call
5531was in effect; and FALSE if a per-thread locale was in effect. This can be
5532used by the caller that needs to restore things as-they-were to decide whether
5533or not to call
5534L<C<Perl_switch_to_global_locale>|perlapi/switch_to_global_locale>.
747c467a
KW		 5535
5536=cut
5537*/
5538
b2e9ba0c
KW		 5539bool
5540Perl_sync_locale()
747c467a 5541{
d36adde0
KW		 5542
5543#ifndef USE_LOCALE
5544
5545 return TRUE;
5546
5547#else
5548
e9bc6d6b 5549 const char * newlocale;
b2e9ba0c
KW		 5550 dTHX;
5551
d36adde0 5552# ifdef USE_POSIX_2008_LOCALE
b2e9ba0c
KW		 5553
5554 bool was_in_global_locale = FALSE;
5555 locale_t cur_obj = uselocale((locale_t) 0);
5556
5557 /* On Windows, unless the foreign code has turned off the thread-safe
5558 * locale setting, any plain setlocale() will have affected what we see, so
5559 * no need to worry. Otherwise, If the foreign code has done a plain
5560 * setlocale(), it will only affect the global locale on POSIX systems, but
5561 * will affect the */
5562 if (cur_obj == LC_GLOBAL_LOCALE) {
5563
d36adde0 5564# ifdef HAS_QUERY_LOCALE
b2e9ba0c
KW		 5565
5566 do_setlocale_c(LC_ALL, setlocale(LC_ALL, NULL));
5567
d36adde0 5568# else
b2e9ba0c
KW		 5569
5570 unsigned int i;
5571
5572 /* We can't trust that we can read the LC_ALL format on the
5573 * platform, so do them individually */
5574 for (i = 0; i < LC_ALL_INDEX; i++) {
5575 do_setlocale_r(categories[i], setlocale(categories[i], NULL));
5576 }
747c467a 5577
d36adde0 5578# endif
b2e9ba0c
KW		 5579
5580 was_in_global_locale = TRUE;
5581 }
5582
d36adde0 5583# else
b2e9ba0c
KW		 5584
5585 bool was_in_global_locale = TRUE;
5586
d36adde0
KW		 5587# endif
5588# ifdef USE_LOCALE_CTYPE
7d4bcc4a 5589
b0bde642 5590 newlocale = savepv(do_setlocale_c(LC_CTYPE, NULL));
9f82ea3e
KW		 5591 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5592 "%s:%d: %s\n", __FILE__, __LINE__,
5593 setlocale_debug_string(LC_CTYPE, NULL, newlocale)));
5594 new_ctype(newlocale);
b0bde642 5595 Safefree(newlocale);
747c467a 5596
d36adde0
KW		 5597# endif /* USE_LOCALE_CTYPE */
5598# ifdef USE_LOCALE_COLLATE
7d4bcc4a 5599
b0bde642 5600 newlocale = savepv(do_setlocale_c(LC_COLLATE, NULL));
9f82ea3e
KW		 5601 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5602 "%s:%d: %s\n", __FILE__, __LINE__,
5603 setlocale_debug_string(LC_COLLATE, NULL, newlocale)));
5604 new_collate(newlocale);
b0bde642 5605 Safefree(newlocale);
747c467a 5606
d36adde0
KW		 5607# endif
5608# ifdef USE_LOCALE_NUMERIC
7d4bcc4a 5609
b0bde642 5610 newlocale = savepv(do_setlocale_c(LC_NUMERIC, NULL));
9f82ea3e
KW		 5611 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5612 "%s:%d: %s\n", __FILE__, __LINE__,
5613 setlocale_debug_string(LC_NUMERIC, NULL, newlocale)));
5614 new_numeric(newlocale);
b0bde642 5615 Safefree(newlocale);
7d4bcc4a 5616
d36adde0 5617# endif /* USE_LOCALE_NUMERIC */
747c467a 5618
b2e9ba0c 5619 return was_in_global_locale;
d36adde0
KW		 5620
5621#endif
5622
747c467a
KW		 5623}
5624
5d1187d1
KW		 5625#if defined(DEBUGGING) && defined(USE_LOCALE)
5626
a4f00dcc
KW		 5627STATIC char *
5628S_setlocale_debug_string(const int category, /* category number,
5d1187d1
KW		 5629 like LC_ALL */
5630 const char* const locale, /* locale name */
5631
5632 /* return value from setlocale() when attempting to
5633 * set 'category' to 'locale' */
5634 const char* const retval)
5635{
5636 /* Returns a pointer to a NUL-terminated string in static storage with
5637 * added text about the info passed in. This is not thread safe and will
5638 * be overwritten by the next call, so this should be used just to
fa07b8e5 5639 * formulate a string to immediately print or savepv() on. */
5d1187d1 5640
8c3a0f6c 5641 static char ret[256];
7d4bcc4a 5642
e5f10d49 5643 my_strlcpy(ret, "setlocale(", sizeof(ret));
b09aaf40 5644 my_strlcat(ret, category_name(category), sizeof(ret));
fa07b8e5 5645 my_strlcat(ret, ", ", sizeof(ret));
5d1187d1
KW		 5646
5647 if (locale) {
fa07b8e5
KW		 5648 my_strlcat(ret, "\"", sizeof(ret));
5649 my_strlcat(ret, locale, sizeof(ret));
5650 my_strlcat(ret, "\"", sizeof(ret));
5d1187d1
KW		 5651 }
5652 else {
fa07b8e5 5653 my_strlcat(ret, "NULL", sizeof(ret));
5d1187d1
KW		 5654 }
5655
fa07b8e5 5656 my_strlcat(ret, ") returned ", sizeof(ret));
5d1187d1
KW		 5657
5658 if (retval) {
fa07b8e5
KW		 5659 my_strlcat(ret, "\"", sizeof(ret));
5660 my_strlcat(ret, retval, sizeof(ret));
5661 my_strlcat(ret, "\"", sizeof(ret));
5d1187d1
KW		 5662 }
5663 else {
fa07b8e5 5664 my_strlcat(ret, "NULL", sizeof(ret));
5d1187d1
KW		 5665 }
5666
5667 assert(strlen(ret) < sizeof(ret));
5668
5669 return ret;
5670}
5671
5672#endif
747c467a 5673
e9bc6d6b
KW		 5674void
5675Perl_thread_locale_init()
5676{
5677 /* Called from a thread on startup*/
5678
5679#ifdef USE_THREAD_SAFE_LOCALE
5680
5681 dTHX_DEBUGGING;
5682
5683 /* C starts the new thread in the global C locale. If we are thread-safe,
5684 * we want to not be in the global locale */
5685
5686 DEBUG_L(PerlIO_printf(Perl_debug_log,
5687 "%s:%d: new thread, initial locale is %s; calling setlocale\n",
5688 __FILE__, __LINE__, setlocale(LC_ALL, NULL)));
5689
5690# ifdef WIN32
5691
5692 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
5693
5694# else
5695
5696 Perl_setlocale(LC_ALL, "C");
5697
5698# endif
5699#endif
5700
5701}
5702
5703void
5704Perl_thread_locale_term()
5705{
5706 /* Called from a thread as it gets ready to terminate */
5707
5708#ifdef USE_THREAD_SAFE_LOCALE
5709
5710 /* C starts the new thread in the global C locale. If we are thread-safe,
5711 * we want to not be in the global locale */
5712
5713# ifndef WIN32
5714
5715 { /* Free up */
5716 locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
e72200e7 5717 if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
e9bc6d6b
KW		 5718 freelocale(cur_obj);
5719 }
5720 }
5721
5722# endif
5723#endif
5724
5725}
747c467a
KW		 5726
5727/*
14d04a33 5728 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5729 */
Unnamed repository; edit this file 'description' to name the repository.