| 1 | /* locale.c
|
|---|
| 2 | *
|
|---|
| 3 | * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
|
|---|
| 4 | * 2000, 2001, 2002, 2003, 2005, by Larry Wall and others
|
|---|
| 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 |
|
|---|
| 21 | /* utility functions for handling locale-specific stuff like what
|
|---|
| 22 | * character represents the decimal point.
|
|---|
| 23 | */
|
|---|
| 24 |
|
|---|
| 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 |
|
|---|
| 33 | #ifdef I_LANGINFO
|
|---|
| 34 | # include <langinfo.h>
|
|---|
| 35 | #endif
|
|---|
| 36 |
|
|---|
| 37 | #include "reentr.h"
|
|---|
| 38 |
|
|---|
| 39 | #if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE)
|
|---|
| 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 | */
|
|---|
| 53 | STATIC char *
|
|---|
| 54 | S_stdize_locale(pTHX_ char *locs)
|
|---|
| 55 | {
|
|---|
| 56 | const char *s = strchr(locs, '=');
|
|---|
| 57 | bool okay = TRUE;
|
|---|
| 58 |
|
|---|
| 59 | if (s) {
|
|---|
| 60 | const char * const t = strchr(s, '.');
|
|---|
| 61 | okay = FALSE;
|
|---|
| 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;
|
|---|
| 69 | }
|
|---|
| 70 | }
|
|---|
| 71 | }
|
|---|
| 72 |
|
|---|
| 73 | if (!okay)
|
|---|
| 74 | Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
|
|---|
| 75 |
|
|---|
| 76 | return locs;
|
|---|
| 77 | }
|
|---|
| 78 | #endif
|
|---|
| 79 |
|
|---|
| 80 | void
|
|---|
| 81 | Perl_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 | */
|
|---|
| 109 | void
|
|---|
| 110 | Perl_new_numeric(pTHX_ char *newnum)
|
|---|
| 111 | {
|
|---|
| 112 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 113 |
|
|---|
| 114 | if (! newnum) {
|
|---|
| 115 | Safefree(PL_numeric_name);
|
|---|
| 116 | PL_numeric_name = NULL;
|
|---|
| 117 | PL_numeric_standard = TRUE;
|
|---|
| 118 | PL_numeric_local = TRUE;
|
|---|
| 119 | return;
|
|---|
| 120 | }
|
|---|
| 121 |
|
|---|
| 122 | if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
|
|---|
| 123 | Safefree(PL_numeric_name);
|
|---|
| 124 | PL_numeric_name = stdize_locale(savepv(newnum));
|
|---|
| 125 | PL_numeric_standard = ((*newnum == 'C' && newnum[1] == '\0')
|
|---|
| 126 | || strEQ(newnum, "POSIX"));
|
|---|
| 127 | PL_numeric_local = TRUE;
|
|---|
| 128 | set_numeric_radix();
|
|---|
| 129 | }
|
|---|
| 130 |
|
|---|
| 131 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 132 | }
|
|---|
| 133 |
|
|---|
| 134 | void
|
|---|
| 135 | Perl_set_numeric_standard(pTHX)
|
|---|
| 136 | {
|
|---|
| 137 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 138 |
|
|---|
| 139 | if (! PL_numeric_standard) {
|
|---|
| 140 | setlocale(LC_NUMERIC, "C");
|
|---|
| 141 | PL_numeric_standard = TRUE;
|
|---|
| 142 | PL_numeric_local = FALSE;
|
|---|
| 143 | set_numeric_radix();
|
|---|
| 144 | }
|
|---|
| 145 |
|
|---|
| 146 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 147 | }
|
|---|
| 148 |
|
|---|
| 149 | void
|
|---|
| 150 | Perl_set_numeric_local(pTHX)
|
|---|
| 151 | {
|
|---|
| 152 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 153 |
|
|---|
| 154 | if (! PL_numeric_local) {
|
|---|
| 155 | setlocale(LC_NUMERIC, PL_numeric_name);
|
|---|
| 156 | PL_numeric_standard = FALSE;
|
|---|
| 157 | PL_numeric_local = TRUE;
|
|---|
| 158 | set_numeric_radix();
|
|---|
| 159 | }
|
|---|
| 160 |
|
|---|
| 161 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 162 | }
|
|---|
| 163 |
|
|---|
| 164 | /*
|
|---|
| 165 | * Set up for a new ctype locale.
|
|---|
| 166 | */
|
|---|
| 167 | void
|
|---|
| 168 | Perl_new_ctype(pTHX_ char *newctype)
|
|---|
| 169 | {
|
|---|
| 170 | #ifdef USE_LOCALE_CTYPE
|
|---|
| 171 | int i;
|
|---|
| 172 |
|
|---|
| 173 | for (i = 0; i < 256; i++) {
|
|---|
| 174 | if (isUPPER_LC(i))
|
|---|
| 175 | PL_fold_locale[i] = toLOWER_LC(i);
|
|---|
| 176 | else if (isLOWER_LC(i))
|
|---|
| 177 | PL_fold_locale[i] = toUPPER_LC(i);
|
|---|
| 178 | else
|
|---|
| 179 | PL_fold_locale[i] = i;
|
|---|
| 180 | }
|
|---|
| 181 |
|
|---|
| 182 | #endif /* USE_LOCALE_CTYPE */
|
|---|
| 183 | PERL_UNUSED_ARG(newctype);
|
|---|
| 184 | }
|
|---|
| 185 |
|
|---|
| 186 | /*
|
|---|
| 187 | * Set up for a new collation locale.
|
|---|
| 188 | */
|
|---|
| 189 | void
|
|---|
| 190 | Perl_new_collate(pTHX_ char *newcoll)
|
|---|
| 191 | {
|
|---|
| 192 | #ifdef USE_LOCALE_COLLATE
|
|---|
| 193 |
|
|---|
| 194 | if (! newcoll) {
|
|---|
| 195 | if (PL_collation_name) {
|
|---|
| 196 | ++PL_collation_ix;
|
|---|
| 197 | Safefree(PL_collation_name);
|
|---|
| 198 | PL_collation_name = NULL;
|
|---|
| 199 | }
|
|---|
| 200 | PL_collation_standard = TRUE;
|
|---|
| 201 | PL_collxfrm_base = 0;
|
|---|
| 202 | PL_collxfrm_mult = 2;
|
|---|
| 203 | return;
|
|---|
| 204 | }
|
|---|
| 205 |
|
|---|
| 206 | if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
|
|---|
| 207 | ++PL_collation_ix;
|
|---|
| 208 | Safefree(PL_collation_name);
|
|---|
| 209 | PL_collation_name = stdize_locale(savepv(newcoll));
|
|---|
| 210 | PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
|
|---|
| 211 | || strEQ(newcoll, "POSIX"));
|
|---|
| 212 |
|
|---|
| 213 | {
|
|---|
| 214 | /* 2: at most so many chars ('a', 'b'). */
|
|---|
| 215 | /* 50: surely no system expands a char more. */
|
|---|
| 216 | #define XFRMBUFSIZE (2 * 50)
|
|---|
| 217 | char xbuf[XFRMBUFSIZE];
|
|---|
| 218 | const Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
|
|---|
| 219 | const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
|
|---|
| 220 | const SSize_t mult = fb - fa;
|
|---|
| 221 | if (mult < 1)
|
|---|
| 222 | Perl_croak(aTHX_ "strxfrm() gets absurd");
|
|---|
| 223 | PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
|
|---|
| 224 | PL_collxfrm_mult = mult;
|
|---|
| 225 | }
|
|---|
| 226 | }
|
|---|
| 227 |
|
|---|
| 228 | #endif /* USE_LOCALE_COLLATE */
|
|---|
| 229 | }
|
|---|
| 230 |
|
|---|
| 231 | /*
|
|---|
| 232 | * Initialize locale awareness.
|
|---|
| 233 | */
|
|---|
| 234 | int
|
|---|
| 235 | Perl_init_i18nl10n(pTHX_ int printwarn)
|
|---|
| 236 | {
|
|---|
| 237 | int ok = 1;
|
|---|
| 238 | /* returns
|
|---|
| 239 | * 1 = set ok or not applicable,
|
|---|
| 240 | * 0 = fallback to C locale,
|
|---|
| 241 | * -1 = fallback to C locale failed
|
|---|
| 242 | */
|
|---|
| 243 |
|
|---|
| 244 | #if defined(USE_LOCALE)
|
|---|
| 245 |
|
|---|
| 246 | #ifdef USE_LOCALE_CTYPE
|
|---|
| 247 | char *curctype = NULL;
|
|---|
| 248 | #endif /* USE_LOCALE_CTYPE */
|
|---|
| 249 | #ifdef USE_LOCALE_COLLATE
|
|---|
| 250 | char *curcoll = NULL;
|
|---|
| 251 | #endif /* USE_LOCALE_COLLATE */
|
|---|
| 252 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 253 | char *curnum = NULL;
|
|---|
| 254 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 255 | #ifdef __GLIBC__
|
|---|
| 256 | char *language = PerlEnv_getenv("LANGUAGE");
|
|---|
| 257 | #endif
|
|---|
| 258 | char *lc_all = PerlEnv_getenv("LC_ALL");
|
|---|
| 259 | char *lang = PerlEnv_getenv("LANG");
|
|---|
| 260 | bool setlocale_failure = FALSE;
|
|---|
| 261 |
|
|---|
| 262 | #ifdef LOCALE_ENVIRON_REQUIRED
|
|---|
| 263 |
|
|---|
| 264 | /*
|
|---|
| 265 | * Ultrix setlocale(..., "") fails if there are no environment
|
|---|
| 266 | * variables from which to get a locale name.
|
|---|
| 267 | */
|
|---|
| 268 |
|
|---|
| 269 | bool done = FALSE;
|
|---|
| 270 |
|
|---|
| 271 | #ifdef LC_ALL
|
|---|
| 272 | if (lang) {
|
|---|
| 273 | if (setlocale(LC_ALL, ""))
|
|---|
| 274 | done = TRUE;
|
|---|
| 275 | else
|
|---|
| 276 | setlocale_failure = TRUE;
|
|---|
| 277 | }
|
|---|
| 278 | if (!setlocale_failure) {
|
|---|
| 279 | #ifdef USE_LOCALE_CTYPE
|
|---|
| 280 | if (! (curctype =
|
|---|
| 281 | setlocale(LC_CTYPE,
|
|---|
| 282 | (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
|
|---|
| 283 | ? "" : Nullch)))
|
|---|
| 284 | setlocale_failure = TRUE;
|
|---|
| 285 | else
|
|---|
| 286 | curctype = savepv(curctype);
|
|---|
| 287 | #endif /* USE_LOCALE_CTYPE */
|
|---|
| 288 | #ifdef USE_LOCALE_COLLATE
|
|---|
| 289 | if (! (curcoll =
|
|---|
| 290 | setlocale(LC_COLLATE,
|
|---|
| 291 | (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
|
|---|
| 292 | ? "" : Nullch)))
|
|---|
| 293 | setlocale_failure = TRUE;
|
|---|
| 294 | else
|
|---|
| 295 | curcoll = savepv(curcoll);
|
|---|
| 296 | #endif /* USE_LOCALE_COLLATE */
|
|---|
| 297 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 298 | if (! (curnum =
|
|---|
| 299 | setlocale(LC_NUMERIC,
|
|---|
| 300 | (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
|
|---|
| 301 | ? "" : Nullch)))
|
|---|
| 302 | setlocale_failure = TRUE;
|
|---|
| 303 | else
|
|---|
| 304 | curnum = savepv(curnum);
|
|---|
| 305 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 306 | }
|
|---|
| 307 |
|
|---|
| 308 | #endif /* LC_ALL */
|
|---|
| 309 |
|
|---|
| 310 | #endif /* !LOCALE_ENVIRON_REQUIRED */
|
|---|
| 311 |
|
|---|
| 312 | #ifdef LC_ALL
|
|---|
| 313 | if (! setlocale(LC_ALL, ""))
|
|---|
| 314 | setlocale_failure = TRUE;
|
|---|
| 315 | #endif /* LC_ALL */
|
|---|
| 316 |
|
|---|
| 317 | if (!setlocale_failure) {
|
|---|
| 318 | #ifdef USE_LOCALE_CTYPE
|
|---|
| 319 | if (! (curctype = setlocale(LC_CTYPE, "")))
|
|---|
| 320 | setlocale_failure = TRUE;
|
|---|
| 321 | else
|
|---|
| 322 | curctype = savepv(curctype);
|
|---|
| 323 | #endif /* USE_LOCALE_CTYPE */
|
|---|
| 324 | #ifdef USE_LOCALE_COLLATE
|
|---|
| 325 | if (! (curcoll = setlocale(LC_COLLATE, "")))
|
|---|
| 326 | setlocale_failure = TRUE;
|
|---|
| 327 | else
|
|---|
| 328 | curcoll = savepv(curcoll);
|
|---|
| 329 | #endif /* USE_LOCALE_COLLATE */
|
|---|
| 330 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 331 | if (! (curnum = setlocale(LC_NUMERIC, "")))
|
|---|
| 332 | setlocale_failure = TRUE;
|
|---|
| 333 | else
|
|---|
| 334 | curnum = savepv(curnum);
|
|---|
| 335 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 336 | }
|
|---|
| 337 |
|
|---|
| 338 | if (setlocale_failure) {
|
|---|
| 339 | char *p;
|
|---|
| 340 | bool locwarn = (printwarn > 1 ||
|
|---|
| 341 | (printwarn &&
|
|---|
| 342 | (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
|
|---|
| 343 |
|
|---|
| 344 | if (locwarn) {
|
|---|
| 345 | #ifdef LC_ALL
|
|---|
| 346 |
|
|---|
| 347 | PerlIO_printf(Perl_error_log,
|
|---|
| 348 | "perl: warning: Setting locale failed.\n");
|
|---|
| 349 |
|
|---|
| 350 | #else /* !LC_ALL */
|
|---|
| 351 |
|
|---|
| 352 | PerlIO_printf(Perl_error_log,
|
|---|
| 353 | "perl: warning: Setting locale failed for the categories:\n\t");
|
|---|
| 354 | #ifdef USE_LOCALE_CTYPE
|
|---|
| 355 | if (! curctype)
|
|---|
| 356 | PerlIO_printf(Perl_error_log, "LC_CTYPE ");
|
|---|
| 357 | #endif /* USE_LOCALE_CTYPE */
|
|---|
| 358 | #ifdef USE_LOCALE_COLLATE
|
|---|
| 359 | if (! curcoll)
|
|---|
| 360 | PerlIO_printf(Perl_error_log, "LC_COLLATE ");
|
|---|
| 361 | #endif /* USE_LOCALE_COLLATE */
|
|---|
| 362 | #ifdef USE_LOCALE_NUMERIC
|
|---|
| 363 | if (! curnum)
|
|---|
| 364 | PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
|
|---|
| 365 | #endif /* USE_LOCALE_NUMERIC */
|
|---|
| 366 | PerlIO_printf(Perl_error_log, "\n");
|
|---|
| 367 |
|
|---|
| 368 | #endif /* LC_ALL */
|
|---|
| 369 |
|
|---|
| 370 | PerlIO_printf(Perl_error_log,
|
|---|
| 371 | "perl: warning: Please check that your locale settings:\n");
|
|---|
| 372 |
|
|---|
| 373 | #ifdef __GLIBC__
|
|---|
| 374 | PerlIO_printf(Perl_error_log,
|
|---|
| 375 | "\tLANGUAGE = %c%s%c,\n",
|
|---|
| 376 | language ? '"' : '(',
|
|---|
| 377 | language ? language : "unset",
|
|---|
| 378 | language ? '"' : ')');
|
|---|
| 379 | #endif
|
|---|
| 380 |
|
|---|
| 381 | PerlIO_printf(Perl_error_log,
|
|---|
| 382 | "\tLC_ALL = %c%s%c,\n",
|
|---|
| 383 | lc_all ? '"' : '(',
|
|---|
| 384 | lc_all ? lc_all : "unset",
|
|---|
|
|---|
