Commit | Line | Data |
2d31dd6a |
1 | /* locale.c |
2 | * |
eb1102fc |
3 | * Copyright (c) 2001-2002, Larry Wall |
2d31dd6a |
4 | * |
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. |
7 | * |
8 | */ |
9 | |
10 | /* |
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! |
18 | */ |
19 | |
20 | #include "EXTERN.h" |
21 | #define PERL_IN_LOCALE_C |
22 | #include "perl.h" |
23 | |
24 | #ifdef I_LOCALE |
25 | # include <locale.h> |
26 | #endif |
27 | |
d6b7ef86 |
28 | #ifdef I_LANGINFO |
29 | # include <langinfo.h> |
30 | #endif |
31 | |
2d31dd6a |
32 | /* |
33 | * Standardize the locale name from a string returned by 'setlocale'. |
34 | * |
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) |
40 | * |
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(). |
43 | * |
44 | */ |
45 | STATIC char * |
46 | S_stdize_locale(pTHX_ char *locs) |
47 | { |
48 | char *s; |
49 | bool okay = TRUE; |
50 | |
51 | if ((s = strchr(locs, '='))) { |
52 | char *t; |
53 | |
54 | okay = FALSE; |
55 | if ((t = strchr(s, '.'))) { |
56 | char *u; |
57 | |
58 | if ((u = strchr(t, '\n'))) { |
59 | |
60 | if (u[1] == 0) { |
61 | STRLEN len = u - s; |
62 | Move(s + 1, locs, len, char); |
63 | locs[len] = 0; |
64 | okay = TRUE; |
65 | } |
66 | } |
67 | } |
68 | } |
69 | |
70 | if (!okay) |
71 | Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); |
72 | |
73 | return locs; |
74 | } |
75 | |
76 | void |
77 | Perl_set_numeric_radix(pTHX) |
78 | { |
79 | #ifdef USE_LOCALE_NUMERIC |
80 | # ifdef HAS_LOCALECONV |
81 | struct lconv* lc; |
82 | |
83 | lc = 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; |
88 | } |
89 | else { |
90 | if (PL_numeric_radix_sv) |
91 | sv_setpv(PL_numeric_radix_sv, lc->decimal_point); |
92 | else |
93 | PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); |
94 | } |
95 | } |
96 | else |
97 | PL_numeric_radix_sv = Nullsv; |
98 | # endif /* HAS_LOCALECONV */ |
99 | #endif /* USE_LOCALE_NUMERIC */ |
100 | } |
101 | |
102 | /* |
103 | * Set up for a new numeric locale. |
104 | */ |
105 | void |
106 | Perl_new_numeric(pTHX_ char *newnum) |
107 | { |
108 | #ifdef USE_LOCALE_NUMERIC |
109 | |
110 | if (! newnum) { |
111 | if (PL_numeric_name) { |
112 | Safefree(PL_numeric_name); |
113 | PL_numeric_name = NULL; |
114 | } |
115 | PL_numeric_standard = TRUE; |
116 | PL_numeric_local = TRUE; |
117 | return; |
118 | } |
119 | |
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; |
125 | set_numeric_radix(); |
126 | } |
127 | |
128 | #endif /* USE_LOCALE_NUMERIC */ |
129 | } |
130 | |
131 | void |
132 | Perl_set_numeric_standard(pTHX) |
133 | { |
134 | #ifdef USE_LOCALE_NUMERIC |
135 | |
136 | if (! PL_numeric_standard) { |
137 | setlocale(LC_NUMERIC, "C"); |
138 | PL_numeric_standard = TRUE; |
139 | PL_numeric_local = FALSE; |
140 | set_numeric_radix(); |
141 | } |
142 | |
143 | #endif /* USE_LOCALE_NUMERIC */ |
144 | } |
145 | |
146 | void |
147 | Perl_set_numeric_local(pTHX) |
148 | { |
149 | #ifdef USE_LOCALE_NUMERIC |
150 | |
151 | if (! PL_numeric_local) { |
152 | setlocale(LC_NUMERIC, PL_numeric_name); |
153 | PL_numeric_standard = FALSE; |
154 | PL_numeric_local = TRUE; |
155 | set_numeric_radix(); |
156 | } |
157 | |
158 | #endif /* USE_LOCALE_NUMERIC */ |
159 | } |
160 | |
161 | /* |
162 | * Set up for a new ctype locale. |
163 | */ |
164 | void |
165 | Perl_new_ctype(pTHX_ char *newctype) |
166 | { |
167 | #ifdef USE_LOCALE_CTYPE |
168 | |
169 | int i; |
170 | |
171 | for (i = 0; i < 256; i++) { |
172 | if (isUPPER_LC(i)) |
173 | PL_fold_locale[i] = toLOWER_LC(i); |
174 | else if (isLOWER_LC(i)) |
175 | PL_fold_locale[i] = toUPPER_LC(i); |
176 | else |
177 | PL_fold_locale[i] = i; |
178 | } |
179 | |
180 | #endif /* USE_LOCALE_CTYPE */ |
181 | } |
182 | |
183 | /* |
184 | * Set up for a new collation locale. |
185 | */ |
186 | void |
187 | Perl_new_collate(pTHX_ char *newcoll) |
188 | { |
189 | #ifdef USE_LOCALE_COLLATE |
190 | |
191 | if (! newcoll) { |
192 | if (PL_collation_name) { |
193 | ++PL_collation_ix; |
194 | Safefree(PL_collation_name); |
195 | PL_collation_name = NULL; |
196 | } |
197 | PL_collation_standard = TRUE; |
198 | PL_collxfrm_base = 0; |
199 | PL_collxfrm_mult = 2; |
200 | return; |
201 | } |
202 | |
203 | if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { |
204 | ++PL_collation_ix; |
205 | Safefree(PL_collation_name); |
206 | PL_collation_name = stdize_locale(savepv(newcoll)); |
207 | PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); |
208 | |
209 | { |
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; |
217 | if (mult < 1) |
218 | Perl_croak(aTHX_ "strxfrm() gets absurd"); |
219 | PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; |
220 | PL_collxfrm_mult = mult; |
221 | } |
222 | } |
223 | |
224 | #endif /* USE_LOCALE_COLLATE */ |
225 | } |
226 | |
227 | /* |
228 | * Initialize locale awareness. |
229 | */ |
230 | int |
231 | Perl_init_i18nl10n(pTHX_ int printwarn) |
232 | { |
233 | int ok = 1; |
234 | /* returns |
235 | * 1 = set ok or not applicable, |
236 | * 0 = fallback to C locale, |
237 | * -1 = fallback to C locale failed |
238 | */ |
239 | |
240 | #if defined(USE_LOCALE) |
241 | |
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 |
249 | char *curnum = NULL; |
250 | #endif /* USE_LOCALE_NUMERIC */ |
251 | #ifdef __GLIBC__ |
252 | char *language = PerlEnv_getenv("LANGUAGE"); |
253 | #endif |
254 | char *lc_all = PerlEnv_getenv("LC_ALL"); |
255 | char *lang = PerlEnv_getenv("LANG"); |
256 | bool setlocale_failure = FALSE; |
257 | |
258 | #ifdef LOCALE_ENVIRON_REQUIRED |
259 | |
260 | /* |
261 | * Ultrix setlocale(..., "") fails if there are no environment |
262 | * variables from which to get a locale name. |
263 | */ |
264 | |
265 | bool done = FALSE; |
266 | |
267 | #ifdef LC_ALL |
268 | if (lang) { |
269 | if (setlocale(LC_ALL, "")) |
270 | done = TRUE; |
271 | else |
272 | setlocale_failure = TRUE; |
273 | } |
274 | if (!setlocale_failure) { |
275 | #ifdef USE_LOCALE_CTYPE |
276 | if (! (curctype = |
277 | setlocale(LC_CTYPE, |
278 | (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) |
279 | ? "" : Nullch))) |
280 | setlocale_failure = TRUE; |
281 | else |
282 | curctype = savepv(curctype); |
283 | #endif /* USE_LOCALE_CTYPE */ |
284 | #ifdef USE_LOCALE_COLLATE |
285 | if (! (curcoll = |
286 | setlocale(LC_COLLATE, |
287 | (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) |
288 | ? "" : Nullch))) |
289 | setlocale_failure = TRUE; |
290 | else |
291 | curcoll = savepv(curcoll); |
292 | #endif /* USE_LOCALE_COLLATE */ |
293 | #ifdef USE_LOCALE_NUMERIC |
294 | if (! (curnum = |
295 | setlocale(LC_NUMERIC, |
296 | (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) |
297 | ? "" : Nullch))) |
298 | setlocale_failure = TRUE; |
299 | else |
300 | curnum = savepv(curnum); |
301 | #endif /* USE_LOCALE_NUMERIC */ |
302 | } |
303 | |
304 | #endif /* LC_ALL */ |
305 | |
306 | #endif /* !LOCALE_ENVIRON_REQUIRED */ |
307 | |
308 | #ifdef LC_ALL |
309 | if (! setlocale(LC_ALL, "")) |
310 | setlocale_failure = TRUE; |
311 | #endif /* LC_ALL */ |
312 | |
313 | if (!setlocale_failure) { |
314 | #ifdef USE_LOCALE_CTYPE |
315 | if (! (curctype = setlocale(LC_CTYPE, ""))) |
316 | setlocale_failure = TRUE; |
317 | else |
318 | curctype = savepv(curctype); |
319 | #endif /* USE_LOCALE_CTYPE */ |
320 | #ifdef USE_LOCALE_COLLATE |
321 | if (! (curcoll = setlocale(LC_COLLATE, ""))) |
322 | setlocale_failure = TRUE; |
323 | else |
324 | curcoll = savepv(curcoll); |
325 | #endif /* USE_LOCALE_COLLATE */ |
326 | #ifdef USE_LOCALE_NUMERIC |
327 | if (! (curnum = setlocale(LC_NUMERIC, ""))) |
328 | setlocale_failure = TRUE; |
329 | else |
330 | curnum = savepv(curnum); |
331 | #endif /* USE_LOCALE_NUMERIC */ |
332 | } |
333 | |
334 | if (setlocale_failure) { |
335 | char *p; |
336 | bool locwarn = (printwarn > 1 || |
337 | (printwarn && |
338 | (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); |
339 | |
340 | if (locwarn) { |
341 | #ifdef LC_ALL |
342 | |
343 | PerlIO_printf(Perl_error_log, |
344 | "perl: warning: Setting locale failed.\n"); |
345 | |
346 | #else /* !LC_ALL */ |
347 | |
348 | PerlIO_printf(Perl_error_log, |
349 | "perl: warning: Setting locale failed for the categories:\n\t"); |
350 | #ifdef USE_LOCALE_CTYPE |
351 | if (! curctype) |
352 | PerlIO_printf(Perl_error_log, "LC_CTYPE "); |
353 | #endif /* USE_LOCALE_CTYPE */ |
354 | #ifdef USE_LOCALE_COLLATE |
355 | if (! curcoll) |
356 | PerlIO_printf(Perl_error_log, "LC_COLLATE "); |
357 | #endif /* USE_LOCALE_COLLATE */ |
358 | #ifdef USE_LOCALE_NUMERIC |
359 | if (! curnum) |
360 | PerlIO_printf(Perl_error_log, "LC_NUMERIC "); |
361 | #endif /* USE_LOCALE_NUMERIC */ |
362 | PerlIO_printf(Perl_error_log, "\n"); |
363 | |
364 | #endif /* LC_ALL */ |
365 | |
366 | PerlIO_printf(Perl_error_log, |
367 | "perl: warning: Please check that your locale settings:\n"); |
368 | |
369 | #ifdef __GLIBC__ |
370 | PerlIO_printf(Perl_error_log, |
371 | "\tLANGUAGE = %c%s%c,\n", |
372 | language ? '"' : '(', |
373 | language ? language : "unset", |
374 | language ? '"' : ')'); |
375 | #endif |
376 | |
377 | PerlIO_printf(Perl_error_log, |
378 | "\tLC_ALL = %c%s%c,\n", |
379 | lc_all ? '"' : '(', |
380 | lc_all ? lc_all : "unset", |
381 | lc_all ? '"' : ')'); |
382 | |
383 | #if defined(USE_ENVIRON_ARRAY) |
384 | { |
385 | char **e; |
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); |
392 | } |
393 | } |
394 | #else |
395 | PerlIO_printf(Perl_error_log, |
396 | "\t(possibly more locale environment variables)\n"); |
397 | #endif |
398 | |
399 | PerlIO_printf(Perl_error_log, |
400 | "\tLANG = %c%s%c\n", |
401 | lang ? '"' : '(', |
402 | lang ? lang : "unset", |
403 | lang ? '"' : ')'); |
404 | |
405 | PerlIO_printf(Perl_error_log, |
406 | " are supported and installed on your system.\n"); |
407 | } |
408 | |
409 | #ifdef LC_ALL |
410 | |
411 | if (setlocale(LC_ALL, "C")) { |
412 | if (locwarn) |
413 | PerlIO_printf(Perl_error_log, |
414 | "perl: warning: Falling back to the standard locale (\"C\").\n"); |
415 | ok = 0; |
416 | } |
417 | else { |
418 | if (locwarn) |
419 | PerlIO_printf(Perl_error_log, |
420 | "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); |
421 | ok = -1; |
422 | } |
423 | |
424 | #else /* ! LC_ALL */ |
425 | |
426 | if (0 |
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 */ |
436 | ) |
437 | { |
438 | if (locwarn) |
439 | PerlIO_printf(Perl_error_log, |
440 | "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); |
441 | ok = -1; |
442 | } |
443 | |
444 | #endif /* ! LC_ALL */ |
445 | |
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 */ |
455 | } |
456 | else { |
457 | |
458 | #ifdef USE_LOCALE_CTYPE |
459 | new_ctype(curctype); |
460 | #endif /* USE_LOCALE_CTYPE */ |
461 | |
462 | #ifdef USE_LOCALE_COLLATE |
463 | new_collate(curcoll); |
464 | #endif /* USE_LOCALE_COLLATE */ |
465 | |
466 | #ifdef USE_LOCALE_NUMERIC |
467 | new_numeric(curnum); |
468 | #endif /* USE_LOCALE_NUMERIC */ |
d6b7ef86 |
469 | |
2d31dd6a |
470 | } |
471 | |
472 | #endif /* USE_LOCALE */ |
473 | |
d6b7ef86 |
474 | { |
475 | bool wantutf8 = FALSE; |
476 | char *codeset = NULL; |
477 | #if defined(HAS_NL_LANGINFO) && defined(CODESET) |
478 | codeset = nl_langinfo(CODESET); |
479 | #endif |
480 | if (codeset && |
481 | (ibcmp(codeset, "UTF-8", 5) == 0 || |
482 | ibcmp(codeset, "UTF8", 4) == 0)) |
483 | wantutf8 = TRUE; |
484 | #ifdef __GLIBC__ |
485 | if (!wantutf8 && language && |
486 | (ibcmp(language, "UTF-8", 5) == 0 || |
487 | ibcmp(language, "UTF8", 4) == 0)) |
488 | wantutf8 = TRUE; |
489 | #endif |
490 | if (!wantutf8 && lc_all && |
491 | (ibcmp(lc_all, "UTF-8", 5) == 0 || |
492 | ibcmp(lc_all, "UTF8", 4) == 0)) |
493 | wantutf8 = TRUE; |
494 | #ifdef USE_LOCALE_CTYPE |
495 | if (!wantutf8 && curctype && |
496 | (ibcmp(curctype, "UTF-8", 5) == 0 || |
497 | ibcmp(curctype, "UTF8", 4) == 0)) |
498 | wantutf8 = TRUE; |
499 | #endif |
500 | if (!wantutf8 && lang && |
501 | (ibcmp(lang, "UTF-8", 5) == 0 || |
502 | ibcmp(lang, "UTF8", 4) == 0)) |
503 | wantutf8 = TRUE; |
504 | if (wantutf8) |
505 | PL_wantutf8 = TRUE; |
506 | } |
507 | |
2d31dd6a |
508 | #ifdef USE_LOCALE_CTYPE |
509 | if (curctype != NULL) |
510 | Safefree(curctype); |
511 | #endif /* USE_LOCALE_CTYPE */ |
512 | #ifdef USE_LOCALE_COLLATE |
513 | if (curcoll != NULL) |
514 | Safefree(curcoll); |
515 | #endif /* USE_LOCALE_COLLATE */ |
516 | #ifdef USE_LOCALE_NUMERIC |
517 | if (curnum != NULL) |
518 | Safefree(curnum); |
519 | #endif /* USE_LOCALE_NUMERIC */ |
520 | return ok; |
521 | } |
522 | |
523 | /* Backwards compatibility. */ |
524 | int |
525 | Perl_init_i18nl14n(pTHX_ int printwarn) |
526 | { |
527 | return init_i18nl10n(printwarn); |
528 | } |
529 | |
530 | #ifdef USE_LOCALE_COLLATE |
531 | |
532 | /* |
533 | * mem_collxfrm() is a bit like strxfrm() but with two important |
534 | * differences. First, it handles embedded NULs. Second, it allocates |
535 | * a bit more memory than needed for the transformed data itself. |
536 | * The real transformed data begins at offset sizeof(collationix). |
537 | * Please see sv_collxfrm() to see how this is used. |
538 | */ |
539 | char * |
540 | Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) |
541 | { |
542 | char *xbuf; |
543 | STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ |
544 | |
545 | /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ |
546 | /* the +1 is for the terminating NUL. */ |
547 | |
548 | xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; |
549 | New(171, xbuf, xAlloc, char); |
550 | if (! xbuf) |
551 | goto bad; |
552 | |
553 | *(U32*)xbuf = PL_collation_ix; |
554 | xout = sizeof(PL_collation_ix); |
555 | for (xin = 0; xin < len; ) { |
556 | SSize_t xused; |
557 | |
558 | for (;;) { |
559 | xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); |
560 | if (xused == -1) |
561 | goto bad; |
562 | if (xused < xAlloc - xout) |
563 | break; |
564 | xAlloc = (2 * xAlloc) + 1; |
565 | Renew(xbuf, xAlloc, char); |
566 | if (! xbuf) |
567 | goto bad; |
568 | } |
569 | |
570 | xin += strlen(s + xin) + 1; |
571 | xout += xused; |
572 | |
573 | /* Embedded NULs are understood but silently skipped |
574 | * because they make no sense in locale collation. */ |
575 | } |
576 | |
577 | xbuf[xout] = '\0'; |
578 | *xlen = xout - sizeof(PL_collation_ix); |
579 | return xbuf; |
580 | |
581 | bad: |
582 | Safefree(xbuf); |
583 | *xlen = 0; |
584 | return NULL; |
585 | } |
586 | |
587 | #endif /* USE_LOCALE_COLLATE */ |
588 | |