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