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