3 * Copyright (c) 2001-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * A Elbereth Gilthoniel,
12 * silivren penna míriel
13 * o menel aglar elenath!
14 * Na-chaered palan-díriel
15 * o galadhremmin ennorath,
16 * Fanuilos, le linnathon
17 * nef aear, si nef aearon!
21 #define PERL_IN_LOCALE_C
29 # include <langinfo.h>
33 * Standardize the locale name from a string returned by 'setlocale'.
35 * The standard return value of setlocale() is either
36 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
37 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
38 * (the space-separated values represent the various sublocales,
39 * in some unspecificed order)
41 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
42 * which is harmful for further use of the string in setlocale().
46 S_stdize_locale(pTHX_ char *locs)
51 if ((s = strchr(locs, '='))) {
55 if ((t = strchr(s, '.'))) {
58 if ((u = strchr(t, '\n'))) {
62 Move(s + 1, locs, len, char);
71 Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
77 Perl_set_numeric_radix(pTHX)
79 #ifdef USE_LOCALE_NUMERIC
80 # ifdef HAS_LOCALECONV
84 if (lc && lc->decimal_point) {
85 if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
86 SvREFCNT_dec(PL_numeric_radix_sv);
87 PL_numeric_radix_sv = Nullsv;
90 if (PL_numeric_radix_sv)
91 sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
93 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
97 PL_numeric_radix_sv = Nullsv;
98 # endif /* HAS_LOCALECONV */
99 #endif /* USE_LOCALE_NUMERIC */
103 * Set up for a new numeric locale.
106 Perl_new_numeric(pTHX_ char *newnum)
108 #ifdef USE_LOCALE_NUMERIC
111 if (PL_numeric_name) {
112 Safefree(PL_numeric_name);
113 PL_numeric_name = NULL;
115 PL_numeric_standard = TRUE;
116 PL_numeric_local = TRUE;
120 if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
121 Safefree(PL_numeric_name);
122 PL_numeric_name = stdize_locale(savepv(newnum));
123 PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
124 PL_numeric_local = TRUE;
128 #endif /* USE_LOCALE_NUMERIC */
132 Perl_set_numeric_standard(pTHX)
134 #ifdef USE_LOCALE_NUMERIC
136 if (! PL_numeric_standard) {
137 setlocale(LC_NUMERIC, "C");
138 PL_numeric_standard = TRUE;
139 PL_numeric_local = FALSE;
143 #endif /* USE_LOCALE_NUMERIC */
147 Perl_set_numeric_local(pTHX)
149 #ifdef USE_LOCALE_NUMERIC
151 if (! PL_numeric_local) {
152 setlocale(LC_NUMERIC, PL_numeric_name);
153 PL_numeric_standard = FALSE;
154 PL_numeric_local = TRUE;
158 #endif /* USE_LOCALE_NUMERIC */
162 * Set up for a new ctype locale.
165 Perl_new_ctype(pTHX_ char *newctype)
167 #ifdef USE_LOCALE_CTYPE
171 for (i = 0; i < 256; i++) {
173 PL_fold_locale[i] = toLOWER_LC(i);
174 else if (isLOWER_LC(i))
175 PL_fold_locale[i] = toUPPER_LC(i);
177 PL_fold_locale[i] = i;
180 #endif /* USE_LOCALE_CTYPE */
184 * Set up for a new collation locale.
187 Perl_new_collate(pTHX_ char *newcoll)
189 #ifdef USE_LOCALE_COLLATE
192 if (PL_collation_name) {
194 Safefree(PL_collation_name);
195 PL_collation_name = NULL;
197 PL_collation_standard = TRUE;
198 PL_collxfrm_base = 0;
199 PL_collxfrm_mult = 2;
203 if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
205 Safefree(PL_collation_name);
206 PL_collation_name = stdize_locale(savepv(newcoll));
207 PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
210 /* 2: at most so many chars ('a', 'b'). */
211 /* 50: surely no system expands a char more. */
212 #define XFRMBUFSIZE (2 * 50)
213 char xbuf[XFRMBUFSIZE];
214 Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
215 Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
216 SSize_t mult = fb - fa;
218 Perl_croak(aTHX_ "strxfrm() gets absurd");
219 PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
220 PL_collxfrm_mult = mult;
224 #endif /* USE_LOCALE_COLLATE */
228 * Initialize locale awareness.
231 Perl_init_i18nl10n(pTHX_ int printwarn)
235 * 1 = set ok or not applicable,
236 * 0 = fallback to C locale,
237 * -1 = fallback to C locale failed
240 #if defined(USE_LOCALE)
242 #ifdef USE_LOCALE_CTYPE
243 char *curctype = NULL;
244 #endif /* USE_LOCALE_CTYPE */
245 #ifdef USE_LOCALE_COLLATE
246 char *curcoll = NULL;
247 #endif /* USE_LOCALE_COLLATE */
248 #ifdef USE_LOCALE_NUMERIC
250 #endif /* USE_LOCALE_NUMERIC */
252 char *language = PerlEnv_getenv("LANGUAGE");
254 char *lc_all = PerlEnv_getenv("LC_ALL");
255 char *lang = PerlEnv_getenv("LANG");
256 bool setlocale_failure = FALSE;
258 #ifdef LOCALE_ENVIRON_REQUIRED
261 * Ultrix setlocale(..., "") fails if there are no environment
262 * variables from which to get a locale name.
269 if (setlocale(LC_ALL, ""))
272 setlocale_failure = TRUE;
274 if (!setlocale_failure) {
275 #ifdef USE_LOCALE_CTYPE
278 (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
280 setlocale_failure = TRUE;
282 curctype = savepv(curctype);
283 #endif /* USE_LOCALE_CTYPE */
284 #ifdef USE_LOCALE_COLLATE
286 setlocale(LC_COLLATE,
287 (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
289 setlocale_failure = TRUE;
291 curcoll = savepv(curcoll);
292 #endif /* USE_LOCALE_COLLATE */
293 #ifdef USE_LOCALE_NUMERIC
295 setlocale(LC_NUMERIC,
296 (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
298 setlocale_failure = TRUE;
300 curnum = savepv(curnum);
301 #endif /* USE_LOCALE_NUMERIC */
306 #endif /* !LOCALE_ENVIRON_REQUIRED */
309 if (! setlocale(LC_ALL, ""))
310 setlocale_failure = TRUE;
313 if (!setlocale_failure) {
314 #ifdef USE_LOCALE_CTYPE
315 if (! (curctype = setlocale(LC_CTYPE, "")))
316 setlocale_failure = TRUE;
318 curctype = savepv(curctype);
319 #endif /* USE_LOCALE_CTYPE */
320 #ifdef USE_LOCALE_COLLATE
321 if (! (curcoll = setlocale(LC_COLLATE, "")))
322 setlocale_failure = TRUE;
324 curcoll = savepv(curcoll);
325 #endif /* USE_LOCALE_COLLATE */
326 #ifdef USE_LOCALE_NUMERIC
327 if (! (curnum = setlocale(LC_NUMERIC, "")))
328 setlocale_failure = TRUE;
330 curnum = savepv(curnum);
331 #endif /* USE_LOCALE_NUMERIC */
334 if (setlocale_failure) {
336 bool locwarn = (printwarn > 1 ||
338 (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
343 PerlIO_printf(Perl_error_log,
344 "perl: warning: Setting locale failed.\n");
348 PerlIO_printf(Perl_error_log,
349 "perl: warning: Setting locale failed for the categories:\n\t");
350 #ifdef USE_LOCALE_CTYPE
352 PerlIO_printf(Perl_error_log, "LC_CTYPE ");
353 #endif /* USE_LOCALE_CTYPE */
354 #ifdef USE_LOCALE_COLLATE
356 PerlIO_printf(Perl_error_log, "LC_COLLATE ");
357 #endif /* USE_LOCALE_COLLATE */
358 #ifdef USE_LOCALE_NUMERIC
360 PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
361 #endif /* USE_LOCALE_NUMERIC */
362 PerlIO_printf(Perl_error_log, "\n");
366 PerlIO_printf(Perl_error_log,
367 "perl: warning: Please check that your locale settings:\n");
370 PerlIO_printf(Perl_error_log,
371 "\tLANGUAGE = %c%s%c,\n",
372 language ? '"' : '(',
373 language ? language : "unset",
374 language ? '"' : ')');
377 PerlIO_printf(Perl_error_log,
378 "\tLC_ALL = %c%s%c,\n",
380 lc_all ? lc_all : "unset",
383 #if defined(USE_ENVIRON_ARRAY)
386 for (e = environ; *e; e++) {
387 if (strnEQ(*e, "LC_", 3)
388 && strnNE(*e, "LC_ALL=", 7)
389 && (p = strchr(*e, '=')))
390 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
391 (int)(p - *e), *e, p + 1);
395 PerlIO_printf(Perl_error_log,
396 "\t(possibly more locale environment variables)\n");
399 PerlIO_printf(Perl_error_log,
402 lang ? lang : "unset",
405 PerlIO_printf(Perl_error_log,
406 " are supported and installed on your system.\n");
411 if (setlocale(LC_ALL, "C")) {
413 PerlIO_printf(Perl_error_log,
414 "perl: warning: Falling back to the standard locale (\"C\").\n");
419 PerlIO_printf(Perl_error_log,
420 "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
427 #ifdef USE_LOCALE_CTYPE
428 || !(curctype || setlocale(LC_CTYPE, "C"))
429 #endif /* USE_LOCALE_CTYPE */
430 #ifdef USE_LOCALE_COLLATE
431 || !(curcoll || setlocale(LC_COLLATE, "C"))
432 #endif /* USE_LOCALE_COLLATE */
433 #ifdef USE_LOCALE_NUMERIC
434 || !(curnum || setlocale(LC_NUMERIC, "C"))
435 #endif /* USE_LOCALE_NUMERIC */
439 PerlIO_printf(Perl_error_log,
440 "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
444 #endif /* ! LC_ALL */
446 #ifdef USE_LOCALE_CTYPE
447 curctype = savepv(setlocale(LC_CTYPE, Nullch));
448 #endif /* USE_LOCALE_CTYPE */
449 #ifdef USE_LOCALE_COLLATE
450 curcoll = savepv(setlocale(LC_COLLATE, Nullch));
451 #endif /* USE_LOCALE_COLLATE */
452 #ifdef USE_LOCALE_NUMERIC
453 curnum = savepv(setlocale(LC_NUMERIC, Nullch));
454 #endif /* USE_LOCALE_NUMERIC */
458 #ifdef USE_LOCALE_CTYPE
460 #endif /* USE_LOCALE_CTYPE */
462 #ifdef USE_LOCALE_COLLATE
463 new_collate(curcoll);
464 #endif /* USE_LOCALE_COLLATE */
466 #ifdef USE_LOCALE_NUMERIC
468 #endif /* USE_LOCALE_NUMERIC */
472 #endif /* USE_LOCALE */
475 bool wantutf8 = FALSE;
476 char *codeset = NULL;
477 #if defined(HAS_NL_LANGINFO) && defined(CODESET)
478 codeset = nl_langinfo(CODESET);
481 (ibcmp(codeset, "UTF-8", 5) == 0 ||
482 ibcmp(codeset, "UTF8", 4) == 0))
484 #if defined(USE_LOCALE)
486 if (!wantutf8 && language &&
487 (ibcmp(language, "UTF-8", 5) == 0 ||
488 ibcmp(language, "UTF8", 4) == 0))
491 if (!wantutf8 && lc_all &&
492 (ibcmp(lc_all, "UTF-8", 5) == 0 ||
493 ibcmp(lc_all, "UTF8", 4) == 0))
495 #ifdef USE_LOCALE_CTYPE
496 if (!wantutf8 && curctype &&
497 (ibcmp(curctype, "UTF-8", 5) == 0 ||
498 ibcmp(curctype, "UTF8", 4) == 0))
501 if (!wantutf8 && lang &&
502 (ibcmp(lang, "UTF-8", 5) == 0 ||
503 ibcmp(lang, "UTF8", 4) == 0))
505 #endif /* USE_LOCALE */
510 #ifdef USE_LOCALE_CTYPE
511 if (curctype != NULL)
513 #endif /* USE_LOCALE_CTYPE */
514 #ifdef USE_LOCALE_COLLATE
517 #endif /* USE_LOCALE_COLLATE */
518 #ifdef USE_LOCALE_NUMERIC
521 #endif /* USE_LOCALE_NUMERIC */
525 /* Backwards compatibility. */
527 Perl_init_i18nl14n(pTHX_ int printwarn)
529 return init_i18nl10n(printwarn);
532 #ifdef USE_LOCALE_COLLATE
535 * mem_collxfrm() is a bit like strxfrm() but with two important
536 * differences. First, it handles embedded NULs. Second, it allocates
537 * a bit more memory than needed for the transformed data itself.
538 * The real transformed data begins at offset sizeof(collationix).
539 * Please see sv_collxfrm() to see how this is used.
542 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
545 STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
547 /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
548 /* the +1 is for the terminating NUL. */
550 xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
551 New(171, xbuf, xAlloc, char);
555 *(U32*)xbuf = PL_collation_ix;
556 xout = sizeof(PL_collation_ix);
557 for (xin = 0; xin < len; ) {
561 xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
564 if ((STRLEN)xused < xAlloc - xout)
566 xAlloc = (2 * xAlloc) + 1;
567 Renew(xbuf, xAlloc, char);
572 xin += strlen(s + xin) + 1;
575 /* Embedded NULs are understood but silently skipped
576 * because they make no sense in locale collation. */
580 *xlen = xout - sizeof(PL_collation_ix);
589 #endif /* USE_LOCALE_COLLATE */