locale.c

   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 * const 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     const struct lconv* const lc = localeconv();
  86
  87     if (lc && lc->decimal_point) {
  88         if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
  89             SvREFCNT_dec(PL_numeric_radix_sv);
  90             PL_numeric_radix_sv = NULL;
  91         }
  92         else {
  93             if (PL_numeric_radix_sv)
  94                 sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
  95             else
  96                 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
  97         }
  98     }
  99     else
 100         PL_numeric_radix_sv = NULL;
 101 # endif /* HAS_LOCALECONV */
 102 #endif /* USE_LOCALE_NUMERIC */
 103 }
 104
 105 /*
 106  * Set up for a new numeric locale.
 107  */
 108 void
 109 Perl_new_numeric(pTHX_ char *newnum)
 110 {
 111 #ifdef USE_LOCALE_NUMERIC
 112
 113     if (! newnum) {
 114         Safefree(PL_numeric_name);
 115         PL_numeric_name = NULL;
 116         PL_numeric_standard = TRUE;
 117         PL_numeric_local = TRUE;
 118         return;
 119     }
 120
 121     if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
 122         Safefree(PL_numeric_name);
 123         PL_numeric_name = stdize_locale(savepv(newnum));
 124         PL_numeric_standard = ((*newnum == 'C' && newnum[1] == '\0')
 125                                || strEQ(newnum, "POSIX"));
 126         PL_numeric_local = TRUE;
 127         set_numeric_radix();
 128     }
 129
 130 #endif /* USE_LOCALE_NUMERIC */
 131 }
 132
 133 void
 134 Perl_set_numeric_standard(pTHX)
 135 {
 136 #ifdef USE_LOCALE_NUMERIC
 137
 138     if (! PL_numeric_standard) {
 139         setlocale(LC_NUMERIC, "C");
 140         PL_numeric_standard = TRUE;
 141         PL_numeric_local = FALSE;
 142         set_numeric_radix();
 143     }
 144
 145 #endif /* USE_LOCALE_NUMERIC */
 146 }
 147
 148 void
 149 Perl_set_numeric_local(pTHX)
 150 {
 151 #ifdef USE_LOCALE_NUMERIC
 152
 153     if (! PL_numeric_local) {
 154         setlocale(LC_NUMERIC, PL_numeric_name);
 155         PL_numeric_standard = FALSE;
 156         PL_numeric_local = TRUE;
 157         set_numeric_radix();
 158     }
 159
 160 #endif /* USE_LOCALE_NUMERIC */
 161 }
 162
 163 /*
 164  * Set up for a new ctype locale.
 165  */
 166 void
 167 Perl_new_ctype(pTHX_ char *newctype)
 168 {
 169 #ifdef USE_LOCALE_CTYPE
 170     int i;
 171
 172     for (i = 0; i < 256; i++) {
 173         if (isUPPER_LC(i))
 174             PL_fold_locale[i] = toLOWER_LC(i);
 175         else if (isLOWER_LC(i))
 176             PL_fold_locale[i] = toUPPER_LC(i);
 177         else
 178             PL_fold_locale[i] = i;
 179     }
 180
 181 #endif /* USE_LOCALE_CTYPE */
 182     PERL_UNUSED_ARG(newctype);
 183 }
 184
 185 /*
 186  * Set up for a new collation locale.
 187  */
 188 void
 189 Perl_new_collate(pTHX_ char *newcoll)
 190 {
 191 #ifdef USE_LOCALE_COLLATE
 192
 193     if (! newcoll) {
 194         if (PL_collation_name) {
 195             ++PL_collation_ix;
 196             Safefree(PL_collation_name);
 197             PL_collation_name = NULL;
 198         }
 199         PL_collation_standard = TRUE;
 200         PL_collxfrm_base = 0;
 201         PL_collxfrm_mult = 2;
 202         return;
 203     }
 204
 205     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
 206         ++PL_collation_ix;
 207         Safefree(PL_collation_name);
 208         PL_collation_name = stdize_locale(savepv(newcoll));
 209         PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
 210                                  || strEQ(newcoll, "POSIX"));
 211
 212         {
 213           /*  2: at most so many chars ('a', 'b'). */
 214           /* 50: surely no system expands a char more. */
 215 #define XFRMBUFSIZE  (2 * 50)
 216           char xbuf[XFRMBUFSIZE];
 217           const Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
 218           const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
 219           const SSize_t mult = fb - fa;
 220           if (mult < 1)
 221               Perl_croak(aTHX_ "strxfrm() gets absurd");
 222           PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
 223           PL_collxfrm_mult = mult;
 224         }
 225     }
 226
 227 #endif /* USE_LOCALE_COLLATE */
 228 }
 229
 230 /*
 231  * Initialize locale awareness.
 232  */
 233 int
 234 Perl_init_i18nl10n(pTHX_ int printwarn)
 235 {
 236     int ok = 1;
 237     /* returns
 238      *    1 = set ok or not applicable,
 239      *    0 = fallback to C locale,
 240      *   -1 = fallback to C locale failed
 241      */
 242
 243 #if defined(USE_LOCALE)
 244
 245 #ifdef USE_LOCALE_CTYPE
 246     char *curctype   = NULL;
 247 #endif /* USE_LOCALE_CTYPE */
 248 #ifdef USE_LOCALE_COLLATE
 249     char *curcoll    = NULL;
 250 #endif /* USE_LOCALE_COLLATE */
 251 #ifdef USE_LOCALE_NUMERIC
 252     char *curnum     = NULL;
 253 #endif /* USE_LOCALE_NUMERIC */
 254 #ifdef __GLIBC__
 255     char * const language   = PerlEnv_getenv("LANGUAGE");
 256 #endif
 257     char * const lc_all     = PerlEnv_getenv("LC_ALL");
 258     char * const lang       = PerlEnv_getenv("LANG");
 259     bool setlocale_failure = FALSE;
 260
 261 #ifdef LOCALE_ENVIRON_REQUIRED
 262
 263     /*
 264      * Ultrix setlocale(..., "") fails if there are no environment
 265      * variables from which to get a locale name.
 266      */
 267
 268     bool done = FALSE;
 269
 270 #ifdef LC_ALL
 271     if (lang) {
 272         if (setlocale(LC_ALL, ""))
 273             done = TRUE;
 274         else
 275             setlocale_failure = TRUE;
 276     }
 277     if (!setlocale_failure) {
 278 #ifdef USE_LOCALE_CTYPE
 279         if (! (curctype =
 280                setlocale(LC_CTYPE,
 281                          (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
 282                                     ? "" : NULL)))
 283             setlocale_failure = TRUE;
 284         else
 285             curctype = savepv(curctype);
 286 #endif /* USE_LOCALE_CTYPE */
 287 #ifdef USE_LOCALE_COLLATE
 288         if (! (curcoll =
 289                setlocale(LC_COLLATE,
 290                          (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
 291                                    ? "" : NULL)))
 292             setlocale_failure = TRUE;
 293         else
 294             curcoll = savepv(curcoll);
 295 #endif /* USE_LOCALE_COLLATE */
 296 #ifdef USE_LOCALE_NUMERIC
 297         if (! (curnum =
 298                setlocale(LC_NUMERIC,
 299                          (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
 300                                   ? "" : NULL)))
 301             setlocale_failure = TRUE;
 302         else
 303             curnum = savepv(curnum);
 304 #endif /* USE_LOCALE_NUMERIC */
 305     }
 306
 307 #endif /* LC_ALL */
 308
 309 #endif /* !LOCALE_ENVIRON_REQUIRED */
 310
 311 #ifdef LC_ALL
 312     if (! setlocale(LC_ALL, ""))
 313         setlocale_failure = TRUE;
 314 #endif /* LC_ALL */
 315
 316     if (!setlocale_failure) {
 317 #ifdef USE_LOCALE_CTYPE
 318         if (! (curctype = setlocale(LC_CTYPE, "")))
 319             setlocale_failure = TRUE;
 320         else
 321             curctype = savepv(curctype);
 322 #endif /* USE_LOCALE_CTYPE */
 323 #ifdef USE_LOCALE_COLLATE
 324         if (! (curcoll = setlocale(LC_COLLATE, "")))
 325             setlocale_failure = TRUE;
 326         else
 327             curcoll = savepv(curcoll);
 328 #endif /* USE_LOCALE_COLLATE */
 329 #ifdef USE_LOCALE_NUMERIC
 330         if (! (curnum = setlocale(LC_NUMERIC, "")))
 331             setlocale_failure = TRUE;
 332         else
 333             curnum = savepv(curnum);
 334 #endif /* USE_LOCALE_NUMERIC */
 335     }
 336
 337     if (setlocale_failure) {
 338         char *p;
 339         const bool locwarn = (printwarn > 1 ||
 340                         (printwarn &&
 341                          (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
 342
 343         if (locwarn) {
 344 #ifdef LC_ALL
 345
 346             PerlIO_printf(Perl_error_log,
 347                "perl: warning: Setting locale failed.\n");
 348
 349 #else /* !LC_ALL */
 350
 351             PerlIO_printf(Perl_error_log,
 352                "perl: warning: Setting locale failed for the categories:\n\t");
 353 #ifdef USE_LOCALE_CTYPE
 354             if (! curctype)
 355                 PerlIO_printf(Perl_error_log, "LC_CTYPE ");
 356 #endif /* USE_LOCALE_CTYPE */
 357 #ifdef USE_LOCALE_COLLATE
 358             if (! curcoll)
 359                 PerlIO_printf(Perl_error_log, "LC_COLLATE ");
 360 #endif /* USE_LOCALE_COLLATE */
 361 #ifdef USE_LOCALE_NUMERIC
 362             if (! curnum)
 363                 PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
 364 #endif /* USE_LOCALE_NUMERIC */
 365             PerlIO_printf(Perl_error_log, "\n");
 366
 367 #endif /* LC_ALL */
 368
 369             PerlIO_printf(Perl_error_log,
 370                 "perl: warning: Please check that your locale settings:\n");
 371
 372 #ifdef __GLIBC__
 373             PerlIO_printf(Perl_error_log,
 374                           "\tLANGUAGE = %c%s%c,\n",
 375                           language ? '"' : '(',
 376                           language ? language : "unset",
 377                           language ? '"' : ')');
 378 #endif
 379
 380             PerlIO_printf(Perl_error_log,
 381                           "\tLC_ALL = %c%s%c,\n",
 382                           lc_all ? '"' : '(',
 383                           lc_all ? lc_all : "unset",
 384                           lc_all ? '"' : ')');
 385
 386 #if defined(USE_ENVIRON_ARRAY)
 387             {
 388               char **e;
 389               for (e = environ; *e; e++) {
 390                   if (strnEQ(*e, "LC_", 3)
 391                         && strnNE(*e, "LC_ALL=", 7)
 392                         && (p = strchr(*e, '=')))
 393                       PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
 394                                     (int)(p - *e), *e, p + 1);
 395               }
 396             }
 397 #else
 398             PerlIO_printf(Perl_error_log,
 399                           "\t(possibly more locale environment variables)\n");
 400 #endif
 401
 402             PerlIO_printf(Perl_error_log,
 403                           "\tLANG = %c%s%c\n",
 404                           lang ? '"' : '(',
 405                           lang ? lang : "unset",
 406                           lang ? '"' : ')');
 407
 408             PerlIO_printf(Perl_error_log,
 409                           "    are supported and installed on your system.\n");
 410         }
 411
 412 #ifdef LC_ALL
 413
 414         if (setlocale(LC_ALL, "C")) {
 415             if (locwarn)
 416                 PerlIO_printf(Perl_error_log,
 417       "perl: warning: Falling back to the standard locale (\"C\").\n");
 418             ok = 0;
 419         }
 420         else {
 421             if (locwarn)
 422                 PerlIO_printf(Perl_error_log,
 423       "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
 424             ok = -1;
 425         }
 426
 427 #else /* ! LC_ALL */
 428
 429         if (0
 430 #ifdef USE_LOCALE_CTYPE
 431             || !(curctype || setlocale(LC_CTYPE, "C"))
 432 #endif /* USE_LOCALE_CTYPE */
 433 #ifdef USE_LOCALE_COLLATE
 434             || !(curcoll || setlocale(LC_COLLATE, "C"))
 435 #endif /* USE_LOCALE_COLLATE */
 436 #ifdef USE_LOCALE_NUMERIC
 437             || !(curnum || setlocale(LC_NUMERIC, "C"))
 438 #endif /* USE_LOCALE_NUMERIC */
 439             )
 440         {
 441             if (locwarn)
 442                 PerlIO_printf(Perl_error_log,
 443       "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
 444             ok = -1;
 445         }
 446
 447 #endif /* ! LC_ALL */
 448
 449 #ifdef USE_LOCALE_CTYPE
 450         curctype = savepv(setlocale(LC_CTYPE, NULL));
 451 #endif /* USE_LOCALE_CTYPE */
 452 #ifdef USE_LOCALE_COLLATE
 453         curcoll = savepv(setlocale(LC_COLLATE, NULL));
 454 #endif /* USE_LOCALE_COLLATE */
 455 #ifdef USE_LOCALE_NUMERIC
 456         curnum = savepv(setlocale(LC_NUMERIC, NULL));
 457 #endif /* USE_LOCALE_NUMERIC */
 458     }
 459     else {
 460
 461 #ifdef USE_LOCALE_CTYPE
 462     new_ctype(curctype);
 463 #endif /* USE_LOCALE_CTYPE */
 464
 465 #ifdef USE_LOCALE_COLLATE
 466     new_collate(curcoll);
 467 #endif /* USE_LOCALE_COLLATE */
 468
 469 #ifdef USE_LOCALE_NUMERIC
 470     new_numeric(curnum);
 471 #endif /* USE_LOCALE_NUMERIC */
 472
 473     }
 474
 475 #endif /* USE_LOCALE */
 476
 477 #ifdef USE_PERLIO
 478     {
 479       /* Set PL_utf8locale to TRUE if using PerlIO _and_
 480          any of the following are true:
 481          - nl_langinfo(CODESET) contains /^utf-?8/i
 482          - $ENV{LC_ALL}   contains /^utf-?8/i
 483          - $ENV{LC_CTYPE} contains /^utf-?8/i
 484          - $ENV{LANG}     contains /^utf-?8/i
 485          The LC_ALL, LC_CTYPE, LANG obey the usual override
 486          hierarchy of locale environment variables.  (LANGUAGE
 487          affects only LC_MESSAGES only under glibc.) (If present,
 488          it overrides LC_MESSAGES for GNU gettext, and it also
 489          can have more than one locale, separated by spaces,
 490          in case you need to know.)
 491          If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
 492          are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
 493          on STDIN, STDOUT, STDERR, _and_ the default open discipline.
 494       */
 495          bool utf8locale = FALSE;
 496          char *codeset = NULL;
 497 #if defined(HAS_NL_LANGINFO) && defined(CODESET)
 498          codeset = nl_langinfo(CODESET);
 499 #endif
 500          if (codeset)
 501               utf8locale = (ibcmp(codeset,  "UTF-8", 5) == 0 ||
 502                             ibcmp(codeset,  "UTF8",  4) == 0);
 503 #if defined(USE_LOCALE)
 504          else { /* nl_langinfo(CODESET) is supposed to correctly
 505                  * interpret the locale environment variables,
 506                  * but just in case it fails, let's do this manually. */
 507               if (lang)
 508                    utf8locale = (ibcmp(lang,     "UTF-8", 5) == 0 ||
 509                                  ibcmp(lang,     "UTF8",  4) == 0);
 510 #ifdef USE_LOCALE_CTYPE
 511               if (curctype)
 512                    utf8locale = (ibcmp(curctype,     "UTF-8", 5) == 0 ||
 513                                  ibcmp(curctype,     "UTF8",  4) == 0);
 514 #endif
 515               if (lc_all)
 516                    utf8locale = (ibcmp(lc_all,   "UTF-8", 5) == 0 ||
 517                                  ibcmp(lc_all,   "UTF8",  4) == 0);
 518          }
 519 #endif /* USE_LOCALE */
 520          if (utf8locale)
 521               PL_utf8locale = TRUE;
 522     }
 523     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
 524        This is an alternative to using the -C command line switch
 525        (the -C if present will override this). */
 526     {
 527          char *p = PerlEnv_getenv("PERL_UNICODE");
 528          PL_unicode = p ? parse_unicode_opts(&p) : 0;
 529          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
 530              PL_utf8cache = -1;
 531     }
 532 #endif
 533
 534 #ifdef USE_LOCALE_CTYPE
 535     Safefree(curctype);
 536 #endif /* USE_LOCALE_CTYPE */
 537 #ifdef USE_LOCALE_COLLATE
 538     Safefree(curcoll);
 539 #endif /* USE_LOCALE_COLLATE */
 540 #ifdef USE_LOCALE_NUMERIC
 541     Safefree(curnum);
 542 #endif /* USE_LOCALE_NUMERIC */
 543     return ok;
 544 }
 545
 546 #ifdef USE_LOCALE_COLLATE
 547
 548 /*
 549  * mem_collxfrm() is a bit like strxfrm() but with two important
 550  * differences. First, it handles embedded NULs. Second, it allocates
 551  * a bit more memory than needed for the transformed data itself.
 552  * The real transformed data begins at offset sizeof(collationix).
 553  * Please see sv_collxfrm() to see how this is used.
 554  */
 555
 556 char *
 557 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
 558 {
 559     char *xbuf;
 560     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
 561
 562     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
 563     /* the +1 is for the terminating NUL. */
 564
 565     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
 566     Newx(xbuf, xAlloc, char);
 567     if (! xbuf)
 568         goto bad;
 569
 570     *(U32*)xbuf = PL_collation_ix;
 571     xout = sizeof(PL_collation_ix);
 572     for (xin = 0; xin < len; ) {
 573         SSize_t xused;
 574
 575         for (;;) {
 576             xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
 577             if (xused == -1)
 578                 goto bad;
 579             if ((STRLEN)xused < xAlloc - xout)
 580                 break;
 581             xAlloc = (2 * xAlloc) + 1;
 582             Renew(xbuf, xAlloc, char);
 583             if (! xbuf)
 584                 goto bad;
 585         }
 586
 587         xin += strlen(s + xin) + 1;
 588         xout += xused;
 589
 590         /* Embedded NULs are understood but silently skipped
 591          * because they make no sense in locale collation. */
 592     }
 593
 594     xbuf[xout] = '\0';
 595     *xlen = xout - sizeof(PL_collation_ix);
 596     return xbuf;
 597
 598   bad:
 599     Safefree(xbuf);
 600     *xlen = 0;
 601     return NULL;
 602 }
 603
 604 #endif /* USE_LOCALE_COLLATE */
 605
 606 /*
 607  * Local variables:
 608  * c-indentation-style: bsd
 609  * c-basic-offset: 4
 610  * indent-tabs-mode: t
 611  * End:
 612  *
 613  * ex: set ts=8 sts=4 sw=4 noet:
 614  */