This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Time::HiRes 1.72
[perl5.git] / locale.c
CommitLineData
98994639
HS
1/* locale.c
2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
770526c1 4 * 2000, 2001, 2002, 2003, 2005, 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/*
12 * A Elbereth Gilthoniel,
13 * silivren penna míriel
14 * o menel aglar elenath!
15 * Na-chaered palan-díriel
16 * o galadhremmin ennorath,
17 * Fanuilos, le linnathon
18 * nef aear, si nef aearon!
19 */
20
166f8a29
DM
21/* utility functions for handling locale-specific stuff like what
22 * character represents the decimal point.
23 */
24
98994639
HS
25#include "EXTERN.h"
26#define PERL_IN_LOCALE_C
27#include "perl.h"
28
29#ifdef I_LOCALE
30# include <locale.h>
31#endif
32
b310b053
JH
33#ifdef I_LANGINFO
34# include <langinfo.h>
35#endif
36
a4af207c
JH
37#include "reentr.h"
38
27da23d5 39#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE)
98994639
HS
40/*
41 * Standardize the locale name from a string returned by 'setlocale'.
42 *
43 * The standard return value of setlocale() is either
44 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
45 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
46 * (the space-separated values represent the various sublocales,
47 * in some unspecificed order)
48 *
49 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
50 * which is harmful for further use of the string in setlocale().
51 *
52 */
53STATIC char *
54S_stdize_locale(pTHX_ char *locs)
55{
8772537c 56 const char *s = strchr(locs, '=');
98994639
HS
57 bool okay = TRUE;
58
8772537c
AL
59 if (s) {
60 const char * const t = strchr(s, '.');
98994639 61 okay = FALSE;
8772537c
AL
62 if (t) {
63 const char * const u = strchr(t, '\n');
64 if (u && (u[1] == 0)) {
65 const STRLEN len = u - s;
66 Move(s + 1, locs, len, char);
67 locs[len] = 0;
68 okay = TRUE;
98994639
HS
69 }
70 }
71 }
72
73 if (!okay)
74 Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
75
76 return locs;
77}
27da23d5 78#endif
98994639
HS
79
80void
81Perl_set_numeric_radix(pTHX)
82{
83#ifdef USE_LOCALE_NUMERIC
84# ifdef HAS_LOCALECONV
85 struct lconv* lc;
86
87 lc = localeconv();
88 if (lc && lc->decimal_point) {
89 if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
90 SvREFCNT_dec(PL_numeric_radix_sv);
91 PL_numeric_radix_sv = Nullsv;
92 }
93 else {
94 if (PL_numeric_radix_sv)
95 sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
96 else
97 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
98 }
99 }
100 else
101 PL_numeric_radix_sv = Nullsv;
102# endif /* HAS_LOCALECONV */
103#endif /* USE_LOCALE_NUMERIC */
104}
105
106/*
107 * Set up for a new numeric locale.
108 */
109void
8772537c 110Perl_new_numeric(pTHX_ const char *newnum)
98994639
HS
111{
112#ifdef USE_LOCALE_NUMERIC
113
114 if (! newnum) {
115 if (PL_numeric_name) {
116 Safefree(PL_numeric_name);
117 PL_numeric_name = NULL;
118 }
119 PL_numeric_standard = TRUE;
120 PL_numeric_local = TRUE;
121 return;
122 }
123
124 if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
125 Safefree(PL_numeric_name);
126 PL_numeric_name = stdize_locale(savepv(newnum));
770526c1
NC
127 PL_numeric_standard = ((*newnum == 'C' && newnum[1] == '\0')
128 || strEQ(newnum, "POSIX"));
98994639
HS
129 PL_numeric_local = TRUE;
130 set_numeric_radix();
131 }
132
133#endif /* USE_LOCALE_NUMERIC */
134}
135
136void
137Perl_set_numeric_standard(pTHX)
138{
139#ifdef USE_LOCALE_NUMERIC
140
141 if (! PL_numeric_standard) {
142 setlocale(LC_NUMERIC, "C");
143 PL_numeric_standard = TRUE;
144 PL_numeric_local = FALSE;
145 set_numeric_radix();
146 }
147
148#endif /* USE_LOCALE_NUMERIC */
149}
150
151void
152Perl_set_numeric_local(pTHX)
153{
154#ifdef USE_LOCALE_NUMERIC
155
156 if (! PL_numeric_local) {
157 setlocale(LC_NUMERIC, PL_numeric_name);
158 PL_numeric_standard = FALSE;
159 PL_numeric_local = TRUE;
160 set_numeric_radix();
161 }
162
163#endif /* USE_LOCALE_NUMERIC */
164}
165
166/*
167 * Set up for a new ctype locale.
168 */
169void
8772537c 170Perl_new_ctype(pTHX_ const char *newctype)
98994639
HS
171{
172#ifdef USE_LOCALE_CTYPE
27da23d5 173 dVAR;
98994639
HS
174 int i;
175
176 for (i = 0; i < 256; i++) {
177 if (isUPPER_LC(i))
178 PL_fold_locale[i] = toLOWER_LC(i);
179 else if (isLOWER_LC(i))
180 PL_fold_locale[i] = toUPPER_LC(i);
181 else
182 PL_fold_locale[i] = i;
183 }
184
185#endif /* USE_LOCALE_CTYPE */
8772537c 186 PERL_UNUSED_ARG(newctype);
98994639
HS
187}
188
189/*
190 * Set up for a new collation locale.
191 */
192void
8772537c 193Perl_new_collate(pTHX_ const char *newcoll)
98994639
HS
194{
195#ifdef USE_LOCALE_COLLATE
196
197 if (! newcoll) {
198 if (PL_collation_name) {
199 ++PL_collation_ix;
200 Safefree(PL_collation_name);
201 PL_collation_name = NULL;
202 }
203 PL_collation_standard = TRUE;
204 PL_collxfrm_base = 0;
205 PL_collxfrm_mult = 2;
206 return;
207 }
208
209 if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
210 ++PL_collation_ix;
211 Safefree(PL_collation_name);
212 PL_collation_name = stdize_locale(savepv(newcoll));
770526c1
NC
213 PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
214 || strEQ(newcoll, "POSIX"));
98994639
HS
215
216 {
217 /* 2: at most so many chars ('a', 'b'). */
218 /* 50: surely no system expands a char more. */
219#define XFRMBUFSIZE (2 * 50)
220 char xbuf[XFRMBUFSIZE];
8772537c
AL
221 const Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
222 const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
223 const SSize_t mult = fb - fa;
98994639
HS
224 if (mult < 1)
225 Perl_croak(aTHX_ "strxfrm() gets absurd");
eb160463 226 PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
98994639
HS
227 PL_collxfrm_mult = mult;
228 }
229 }
230
231#endif /* USE_LOCALE_COLLATE */
232}
233
234/*
235 * Initialize locale awareness.
236 */
237int
238Perl_init_i18nl10n(pTHX_ int printwarn)
239{
240 int ok = 1;
241 /* returns
242 * 1 = set ok or not applicable,
243 * 0 = fallback to C locale,
244 * -1 = fallback to C locale failed
245 */
246
247#if defined(USE_LOCALE)
248
249#ifdef USE_LOCALE_CTYPE
250 char *curctype = NULL;
251#endif /* USE_LOCALE_CTYPE */
252#ifdef USE_LOCALE_COLLATE
253 char *curcoll = NULL;
254#endif /* USE_LOCALE_COLLATE */
255#ifdef USE_LOCALE_NUMERIC
256 char *curnum = NULL;
257#endif /* USE_LOCALE_NUMERIC */
258#ifdef __GLIBC__
259 char *language = PerlEnv_getenv("LANGUAGE");
260#endif
261 char *lc_all = PerlEnv_getenv("LC_ALL");
262 char *lang = PerlEnv_getenv("LANG");
263 bool setlocale_failure = FALSE;
264
265#ifdef LOCALE_ENVIRON_REQUIRED
266
267 /*
268 * Ultrix setlocale(..., "") fails if there are no environment
269 * variables from which to get a locale name.
270 */
271
272 bool done = FALSE;
273
274#ifdef LC_ALL
275 if (lang) {
276 if (setlocale(LC_ALL, ""))
277 done = TRUE;
278 else
279 setlocale_failure = TRUE;
280 }
281 if (!setlocale_failure) {
282#ifdef USE_LOCALE_CTYPE
283 if (! (curctype =
284 setlocale(LC_CTYPE,
285 (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
286 ? "" : Nullch)))
287 setlocale_failure = TRUE;
288 else
289 curctype = savepv(curctype);
290#endif /* USE_LOCALE_CTYPE */
291#ifdef USE_LOCALE_COLLATE
292 if (! (curcoll =
293 setlocale(LC_COLLATE,
294 (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
295 ? "" : Nullch)))
296 setlocale_failure = TRUE;
297 else
298 curcoll = savepv(curcoll);
299#endif /* USE_LOCALE_COLLATE */
300#ifdef USE_LOCALE_NUMERIC
301 if (! (curnum =
302 setlocale(LC_NUMERIC,
303 (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
304 ? "" : Nullch)))
305 setlocale_failure = TRUE;
306 else
307 curnum = savepv(curnum);
308#endif /* USE_LOCALE_NUMERIC */
309 }
310
311#endif /* LC_ALL */
312
313#endif /* !LOCALE_ENVIRON_REQUIRED */
314
315#ifdef LC_ALL
316 if (! setlocale(LC_ALL, ""))
317 setlocale_failure = TRUE;
318#endif /* LC_ALL */
319
320 if (!setlocale_failure) {
321#ifdef USE_LOCALE_CTYPE
322 if (! (curctype = setlocale(LC_CTYPE, "")))
323 setlocale_failure = TRUE;
324 else
325 curctype = savepv(curctype);
326#endif /* USE_LOCALE_CTYPE */
327#ifdef USE_LOCALE_COLLATE
328 if (! (curcoll = setlocale(LC_COLLATE, "")))
329 setlocale_failure = TRUE;
330 else
331 curcoll = savepv(curcoll);
332#endif /* USE_LOCALE_COLLATE */
333#ifdef USE_LOCALE_NUMERIC
334 if (! (curnum = setlocale(LC_NUMERIC, "")))
335 setlocale_failure = TRUE;
336 else
337 curnum = savepv(curnum);
338#endif /* USE_LOCALE_NUMERIC */
339 }
340
341 if (setlocale_failure) {
342 char *p;
343 bool locwarn = (printwarn > 1 ||
344 (printwarn &&
345 (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
346
347 if (locwarn) {
348#ifdef LC_ALL
349
350 PerlIO_printf(Perl_error_log,
351 "perl: warning: Setting locale failed.\n");
352
353#else /* !LC_ALL */
354
355 PerlIO_printf(Perl_error_log,
356 "perl: warning: Setting locale failed for the categories:\n\t");
357#ifdef USE_LOCALE_CTYPE
358 if (! curctype)
359 PerlIO_printf(Perl_error_log, "LC_CTYPE ");
360#endif /* USE_LOCALE_CTYPE */
361#ifdef USE_LOCALE_COLLATE
362 if (! curcoll)
363 PerlIO_printf(Perl_error_log, "LC_COLLATE ");
364#endif /* USE_LOCALE_COLLATE */
365#ifdef USE_LOCALE_NUMERIC
366 if (! curnum)
367 PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
368#endif /* USE_LOCALE_NUMERIC */
369 PerlIO_printf(Perl_error_log, "\n");
370
371#endif /* LC_ALL */
372
373 PerlIO_printf(Perl_error_log,
374 "perl: warning: Please check that your locale settings:\n");
375
376#ifdef __GLIBC__
377 PerlIO_printf(Perl_error_log,
378 "\tLANGUAGE = %c%s%c,\n",
379 language ? '"' : '(',
380 language ? language : "unset",
381 language ? '"' : ')');
382#endif
383
384 PerlIO_printf(Perl_error_log,
385 "\tLC_ALL = %c%s%c,\n",
386 lc_all ? '"' : '(',
387 lc_all ? lc_all : "unset",
388 lc_all ? '"' : ')');
389
390#if defined(USE_ENVIRON_ARRAY)
391 {
392 char **e;
393 for (e = environ; *e; e++) {
394 if (strnEQ(*e, "LC_", 3)
395 && strnNE(*e, "LC_ALL=", 7)
396 && (p = strchr(*e, '=')))
397 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
398 (int)(p - *e), *e, p + 1);
399 }
400 }
401#else
402 PerlIO_printf(Perl_error_log,
403 "\t(possibly more locale environment variables)\n");
404#endif
405
406 PerlIO_printf(Perl_error_log,
407 "\tLANG = %c%s%c\n",
408 lang ? '"' : '(',
409 lang ? lang : "unset",
410 lang ? '"' : ')');
411
412 PerlIO_printf(Perl_error_log,
413 " are supported and installed on your system.\n");
414 }
415
416#ifdef LC_ALL
417
418 if (setlocale(LC_ALL, "C")) {
419 if (locwarn)
420 PerlIO_printf(Perl_error_log,
421 "perl: warning: Falling back to the standard locale (\"C\").\n");
422 ok = 0;
423 }
424 else {
425 if (locwarn)
426 PerlIO_printf(Perl_error_log,
427 "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
428 ok = -1;
429 }
430
431#else /* ! LC_ALL */
432
433 if (0
434#ifdef USE_LOCALE_CTYPE
435 || !(curctype || setlocale(LC_CTYPE, "C"))
436#endif /* USE_LOCALE_CTYPE */
437#ifdef USE_LOCALE_COLLATE
438 || !(curcoll || setlocale(LC_COLLATE, "C"))
439#endif /* USE_LOCALE_COLLATE */
440#ifdef USE_LOCALE_NUMERIC
441 || !(curnum || setlocale(LC_NUMERIC, "C"))
442#endif /* USE_LOCALE_NUMERIC */
443 )
444 {
445 if (locwarn)
446 PerlIO_printf(Perl_error_log,
447 "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
448 ok = -1;
449 }
450
451#endif /* ! LC_ALL */
452
453#ifdef USE_LOCALE_CTYPE
454 curctype = savepv(setlocale(LC_CTYPE, Nullch));
455#endif /* USE_LOCALE_CTYPE */
456#ifdef USE_LOCALE_COLLATE
457 curcoll = savepv(setlocale(LC_COLLATE, Nullch));
458#endif /* USE_LOCALE_COLLATE */
459#ifdef USE_LOCALE_NUMERIC
460 curnum = savepv(setlocale(LC_NUMERIC, Nullch));
461#endif /* USE_LOCALE_NUMERIC */
462 }
463 else {
464
465#ifdef USE_LOCALE_CTYPE
466 new_ctype(curctype);
467#endif /* USE_LOCALE_CTYPE */
468
469#ifdef USE_LOCALE_COLLATE
470 new_collate(curcoll);
471#endif /* USE_LOCALE_COLLATE */
472
473#ifdef USE_LOCALE_NUMERIC
474 new_numeric(curnum);
475#endif /* USE_LOCALE_NUMERIC */
b310b053 476
98994639
HS
477 }
478
479#endif /* USE_LOCALE */
480
ec71e770 481#ifdef USE_PERLIO
b310b053 482 {
fde18df1 483 /* Set PL_utf8locale to TRUE if using PerlIO _and_
ec71e770 484 any of the following are true:
085a54d9 485 - nl_langinfo(CODESET) contains /^utf-?8/i
61de9fb5 486 - $ENV{LC_ALL} contains /^utf-?8/i
085a54d9 487 - $ENV{LC_CTYPE} contains /^utf-?8/i
61de9fb5
JH
488 - $ENV{LANG} contains /^utf-?8/i
489 The LC_ALL, LC_CTYPE, LANG obey the usual override
490 hierarchy of locale environment variables. (LANGUAGE
491 affects only LC_MESSAGES only under glibc.) (If present,
492 it overrides LC_MESSAGES for GNU gettext, and it also
493 can have more than one locale, separated by spaces,
494 in case you need to know.)
8aa8f774 495 If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
a05d7ebb 496 are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
fde18df1 497 on STDIN, STDOUT, STDERR, _and_ the default open discipline.
085a54d9 498 */
fde18df1 499 bool utf8locale = FALSE;
b310b053
JH
500 char *codeset = NULL;
501#if defined(HAS_NL_LANGINFO) && defined(CODESET)
502 codeset = nl_langinfo(CODESET);
503#endif
61de9fb5 504 if (codeset)
fde18df1
JH
505 utf8locale = (ibcmp(codeset, "UTF-8", 5) == 0 ||
506 ibcmp(codeset, "UTF8", 4) == 0);
077a72a9 507#if defined(USE_LOCALE)
61de9fb5
JH
508 else { /* nl_langinfo(CODESET) is supposed to correctly
509 * interpret the locale environment variables,
510 * but just in case it fails, let's do this manually. */
511 if (lang)
fde18df1
JH
512 utf8locale = (ibcmp(lang, "UTF-8", 5) == 0 ||
513 ibcmp(lang, "UTF8", 4) == 0);
b310b053 514#ifdef USE_LOCALE_CTYPE
61de9fb5 515 if (curctype)
fde18df1
JH
516 utf8locale = (ibcmp(curctype, "UTF-8", 5) == 0 ||
517 ibcmp(curctype, "UTF8", 4) == 0);
b310b053 518#endif
61de9fb5 519 if (lc_all)
fde18df1
JH
520 utf8locale = (ibcmp(lc_all, "UTF-8", 5) == 0 ||
521 ibcmp(lc_all, "UTF8", 4) == 0);
61de9fb5 522 }
fde18df1
JH
523#endif /* USE_LOCALE */
524 if (utf8locale)
525 PL_utf8locale = TRUE;
526 }
a05d7ebb 527 /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
fde18df1
JH
528 This is an alternative to using the -C command line switch
529 (the -C if present will override this). */
530 {
dd374669 531 const char *p = PerlEnv_getenv("PERL_UNICODE");
a05d7ebb 532 PL_unicode = p ? parse_unicode_opts(&p) : 0;
b310b053 533 }
ec71e770 534#endif
b310b053 535
98994639
HS
536#ifdef USE_LOCALE_CTYPE
537 if (curctype != NULL)
538 Safefree(curctype);
539#endif /* USE_LOCALE_CTYPE */
540#ifdef USE_LOCALE_COLLATE
541 if (curcoll != NULL)
542 Safefree(curcoll);
543#endif /* USE_LOCALE_COLLATE */
544#ifdef USE_LOCALE_NUMERIC
545 if (curnum != NULL)
546 Safefree(curnum);
547#endif /* USE_LOCALE_NUMERIC */
548 return ok;
549}
550
551/* Backwards compatibility. */
552int
553Perl_init_i18nl14n(pTHX_ int printwarn)
554{
555 return init_i18nl10n(printwarn);
556}
557
558#ifdef USE_LOCALE_COLLATE
559
560/*
561 * mem_collxfrm() is a bit like strxfrm() but with two important
562 * differences. First, it handles embedded NULs. Second, it allocates
563 * a bit more memory than needed for the transformed data itself.
564 * The real transformed data begins at offset sizeof(collationix).
565 * Please see sv_collxfrm() to see how this is used.
566 */
166f8a29 567
98994639
HS
568char *
569Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
570{
571 char *xbuf;
572 STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
573
574 /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
575 /* the +1 is for the terminating NUL. */
576
577 xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
578 New(171, xbuf, xAlloc, char);
579 if (! xbuf)
580 goto bad;
581
582 *(U32*)xbuf = PL_collation_ix;
583 xout = sizeof(PL_collation_ix);
584 for (xin = 0; xin < len; ) {
585 SSize_t xused;
586
587 for (;;) {
588 xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
589 if (xused == -1)
590 goto bad;
eb160463 591 if ((STRLEN)xused < xAlloc - xout)
98994639
HS
592 break;
593 xAlloc = (2 * xAlloc) + 1;
594 Renew(xbuf, xAlloc, char);
595 if (! xbuf)
596 goto bad;
597 }
598
599 xin += strlen(s + xin) + 1;
600 xout += xused;
601
602 /* Embedded NULs are understood but silently skipped
603 * because they make no sense in locale collation. */
604 }
605
606 xbuf[xout] = '\0';
607 *xlen = xout - sizeof(PL_collation_ix);
608 return xbuf;
609
610 bad:
611 Safefree(xbuf);
612 *xlen = 0;
613 return NULL;
614}
615
616#endif /* USE_LOCALE_COLLATE */
617
66610fdd
RGS
618/*
619 * Local variables:
620 * c-indentation-style: bsd
621 * c-basic-offset: 4
622 * indent-tabs-mode: t
623 * End:
624 *
37442d52
RGS
625 * ex: set ts=8 sts=4 sw=4 noet:
626 */