locale.c

   1 /*    locale.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   4  *    2002, 2003, 2005, 2006, 2007, 2008 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  *     [p.238 of _The Lord of the Rings_, II/i: "Many Meetings"]
  21  */
  22
  23 /* utility functions for handling locale-specific stuff like what
  24  * character represents the decimal point.
  25  *
  26  * All C programs have an underlying locale.  Perl generally doesn't pay any
  27  * attention to it except within the scope of a 'use locale'.  For most
  28  * categories, it accomplishes this by just using different operations if it is
  29  * in such scope than if not.  However, various libc functions called by Perl
  30  * are affected by the LC_NUMERIC category, so there are macros in perl.h that
  31  * are used to toggle between the current locale and the C locale depending on
  32  * the desired behavior of those functions at the moment.
  33  */
  34
  35 #include "EXTERN.h"
  36 #define PERL_IN_LOCALE_C
  37 #include "perl.h"
  38
  39 #ifdef I_LANGINFO
  40 #   include <langinfo.h>
  41 #endif
  42
  43 #include "reentr.h"
  44
  45 #ifdef USE_LOCALE
  46
  47 /*
  48  * Standardize the locale name from a string returned by 'setlocale', possibly
  49  * modifying that string.
  50  *
  51  * The typical return value of setlocale() is either
  52  * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
  53  * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
  54  *     (the space-separated values represent the various sublocales,
  55  *      in some unspecified order).  This is not handled by this function.
  56  *
  57  * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
  58  * which is harmful for further use of the string in setlocale().  This
  59  * function removes the trailing new line and everything up through the '='
  60  *
  61  */
  62 STATIC char *
  63 S_stdize_locale(pTHX_ char *locs)
  64 {
  65     const char * const s = strchr(locs, '=');
  66     bool okay = TRUE;
  67
  68     PERL_ARGS_ASSERT_STDIZE_LOCALE;
  69
  70     if (s) {
  71         const char * const t = strchr(s, '.');
  72         okay = FALSE;
  73         if (t) {
  74             const char * const u = strchr(t, '\n');
  75             if (u && (u[1] == 0)) {
  76                 const STRLEN len = u - s;
  77                 Move(s + 1, locs, len, char);
  78                 locs[len] = 0;
  79                 okay = TRUE;
  80             }
  81         }
  82     }
  83
  84     if (!okay)
  85         Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
  86
  87     return locs;
  88 }
  89
  90 #endif
  91
  92 void
  93 Perl_set_numeric_radix(pTHX)
  94 {
  95 #ifdef USE_LOCALE_NUMERIC
  96     dVAR;
  97 # ifdef HAS_LOCALECONV
  98     const struct lconv* const lc = localeconv();
  99
 100     if (lc && lc->decimal_point) {
 101         if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
 102             SvREFCNT_dec(PL_numeric_radix_sv);
 103             PL_numeric_radix_sv = NULL;
 104         }
 105         else {
 106             if (PL_numeric_radix_sv)
 107                 sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
 108             else
 109                 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
 110             if (! is_ascii_string((U8 *) lc->decimal_point, 0)
 111                 && is_utf8_string((U8 *) lc->decimal_point, 0)
 112                 && is_cur_LC_category_utf8(LC_NUMERIC))
 113             {
 114                 SvUTF8_on(PL_numeric_radix_sv);
 115             }
 116         }
 117     }
 118     else
 119         PL_numeric_radix_sv = NULL;
 120 # endif /* HAS_LOCALECONV */
 121 #endif /* USE_LOCALE_NUMERIC */
 122 }
 123
 124 void
 125 Perl_new_numeric(pTHX_ const char *newnum)
 126 {
 127 #ifdef USE_LOCALE_NUMERIC
 128
 129     /* Called after all libc setlocale() calls affecting LC_NUMERIC, to tell
 130      * core Perl this and that 'newnum' is the name of the new locale.
 131      * It installs this locale as the current underlying default.
 132      *
 133      * The default locale and the C locale can be toggled between by use of the
 134      * set_numeric_local() and set_numeric_standard() functions, which should
 135      * probably not be called directly, but only via macros like
 136      * SET_NUMERIC_STANDARD() in perl.h.
 137      *
 138      * The toggling is necessary mainly so that a non-dot radix decimal point
 139      * character can be output, while allowing internal calculations to use a
 140      * dot.
 141      *
 142      * This sets several interpreter-level variables:
 143      * PL_numeric_name  The default locale's name: a copy of 'newnum'
 144      * PL_numeric_local A boolean indicating if the toggled state is such
 145      *                  that the current locale is the default locale
 146      * PL_numeric_standard A boolean indicating if the toggled state is such
 147      *                  that the current locale is the C locale
 148      * Note that both of the last two variables can be true at the same time,
 149      * if the underlying locale is C.  (Toggling is a no-op under these
 150      * circumstances.)
 151      *
 152      * Any code changing the locale (outside this file) should use
 153      * POSIX::setlocale, which calls this function.  Therefore this function
 154      * should be called directly only from this file and from
 155      * POSIX::setlocale() */
 156
 157     char *save_newnum;
 158     dVAR;
 159
 160     if (! newnum) {
 161         Safefree(PL_numeric_name);
 162         PL_numeric_name = NULL;
 163         PL_numeric_standard = TRUE;
 164         PL_numeric_local = TRUE;
 165         return;
 166     }
 167
 168     save_newnum = stdize_locale(savepv(newnum));
 169     if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
 170         Safefree(PL_numeric_name);
 171         PL_numeric_name = save_newnum;
 172     }
 173
 174     PL_numeric_standard = ((*save_newnum == 'C' && save_newnum[1] == '\0')
 175                             || strEQ(save_newnum, "POSIX"));
 176     PL_numeric_local = TRUE;
 177     set_numeric_radix();
 178
 179 #endif /* USE_LOCALE_NUMERIC */
 180 }
 181
 182 void
 183 Perl_set_numeric_standard(pTHX)
 184 {
 185 #ifdef USE_LOCALE_NUMERIC
 186     dVAR;
 187
 188     /* Toggle the LC_NUMERIC locale to C, if not already there.  Probably
 189      * should use the macros like SET_NUMERIC_STANDARD() in perl.h instead of
 190      * calling this directly. */
 191
 192     if (! PL_numeric_standard) {
 193         setlocale(LC_NUMERIC, "C");
 194         PL_numeric_standard = TRUE;
 195         PL_numeric_local = FALSE;
 196         set_numeric_radix();
 197     }
 198
 199 #endif /* USE_LOCALE_NUMERIC */
 200 }
 201
 202 void
 203 Perl_set_numeric_local(pTHX)
 204 {
 205 #ifdef USE_LOCALE_NUMERIC
 206     dVAR;
 207
 208     /* Toggle the LC_NUMERIC locale to the current underlying default, if not
 209      * already there.  Probably should use the macros like SET_NUMERIC_LOCAL()
 210      * in perl.h instead of calling this directly. */
 211
 212     if (! PL_numeric_local) {
 213         setlocale(LC_NUMERIC, PL_numeric_name);
 214         PL_numeric_standard = FALSE;
 215         PL_numeric_local = TRUE;
 216         set_numeric_radix();
 217     }
 218
 219 #endif /* USE_LOCALE_NUMERIC */
 220 }
 221
 222 /*
 223  * Set up for a new ctype locale.
 224  */
 225 void
 226 Perl_new_ctype(pTHX_ const char *newctype)
 227 {
 228 #ifdef USE_LOCALE_CTYPE
 229
 230     /* Called after all libc setlocale() calls affecting LC_CTYPE, to tell
 231      * core Perl this and that 'newctype' is the name of the new locale.
 232      *
 233      * This function sets up the folding arrays for all 256 bytes, assuming
 234      * that tofold() is tolc() since fold case is not a concept in POSIX,
 235      *
 236      * Any code changing the locale (outside this file) should use
 237      * POSIX::setlocale, which calls this function.  Therefore this function
 238      * should be called directly only from this file and from
 239      * POSIX::setlocale() */
 240
 241     dVAR;
 242     UV i;
 243
 244     PERL_ARGS_ASSERT_NEW_CTYPE;
 245
 246     PL_in_utf8_CTYPE_locale = is_cur_LC_category_utf8(LC_CTYPE);
 247
 248     /* A UTF-8 locale gets standard rules.  But note that code still has to
 249      * handle this specially because of the three problematic code points */
 250     if (PL_in_utf8_CTYPE_locale) {
 251         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
 252     }
 253     else {
 254         for (i = 0; i < 256; i++) {
 255             if (isUPPER_LC((U8) i))
 256                 PL_fold_locale[i] = (U8) toLOWER_LC((U8) i);
 257             else if (isLOWER_LC((U8) i))
 258                 PL_fold_locale[i] = (U8) toUPPER_LC((U8) i);
 259             else
 260                 PL_fold_locale[i] = (U8) i;
 261         }
 262     }
 263
 264 #endif /* USE_LOCALE_CTYPE */
 265     PERL_ARGS_ASSERT_NEW_CTYPE;
 266     PERL_UNUSED_ARG(newctype);
 267     PERL_UNUSED_CONTEXT;
 268 }
 269
 270 void
 271 Perl_new_collate(pTHX_ const char *newcoll)
 272 {
 273 #ifdef USE_LOCALE_COLLATE
 274
 275     /* Called after all libc setlocale() calls affecting LC_COLLATE, to tell
 276      * core Perl this and that 'newcoll' is the name of the new locale.
 277      *
 278      * Any code changing the locale (outside this file) should use
 279      * POSIX::setlocale, which calls this function.  Therefore this function
 280      * should be called directly only from this file and from
 281      * POSIX::setlocale() */
 282
 283     dVAR;
 284
 285     if (! newcoll) {
 286         if (PL_collation_name) {
 287             ++PL_collation_ix;
 288             Safefree(PL_collation_name);
 289             PL_collation_name = NULL;
 290         }
 291         PL_collation_standard = TRUE;
 292         PL_collxfrm_base = 0;
 293         PL_collxfrm_mult = 2;
 294         return;
 295     }
 296
 297     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
 298         ++PL_collation_ix;
 299         Safefree(PL_collation_name);
 300         PL_collation_name = stdize_locale(savepv(newcoll));
 301         PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
 302                                  || strEQ(newcoll, "POSIX"));
 303
 304         {
 305           /*  2: at most so many chars ('a', 'b'). */
 306           /* 50: surely no system expands a char more. */
 307 #define XFRMBUFSIZE  (2 * 50)
 308           char xbuf[XFRMBUFSIZE];
 309           const Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
 310           const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
 311           const SSize_t mult = fb - fa;
 312           if (mult < 1 && !(fa == 0 && fb == 0))
 313               Perl_croak(aTHX_ "panic: strxfrm() gets absurd - a => %"UVuf", ab => %"UVuf,
 314                          (UV) fa, (UV) fb);
 315           PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
 316           PL_collxfrm_mult = mult;
 317         }
 318     }
 319
 320 #endif /* USE_LOCALE_COLLATE */
 321 }
 322
 323 /*
 324  * Initialize locale awareness.
 325  */
 326 int
 327 Perl_init_i18nl10n(pTHX_ int printwarn)
 328 {
 329     int ok = 1;
 330     /* returns
 331      *    1 = set ok or not applicable,
 332      *    0 = fallback to C locale,
 333      *   -1 = fallback to C locale failed
 334      */
 335
 336 #if defined(USE_LOCALE)
 337     dVAR;
 338
 339 #ifdef USE_LOCALE_CTYPE
 340     char *curctype   = NULL;
 341 #endif /* USE_LOCALE_CTYPE */
 342 #ifdef USE_LOCALE_COLLATE
 343     char *curcoll    = NULL;
 344 #endif /* USE_LOCALE_COLLATE */
 345 #ifdef USE_LOCALE_NUMERIC
 346     char *curnum     = NULL;
 347 #endif /* USE_LOCALE_NUMERIC */
 348 #ifdef __GLIBC__
 349     char * const language   = PerlEnv_getenv("LANGUAGE");
 350 #endif
 351     /* NULL uses the existing already set up locale */
 352     const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
 353                                         ? NULL
 354                                         : "";
 355     char * const lc_all     = PerlEnv_getenv("LC_ALL");
 356     char * const lang       = PerlEnv_getenv("LANG");
 357     bool setlocale_failure = FALSE;
 358
 359 #ifdef LOCALE_ENVIRON_REQUIRED
 360
 361     /*
 362      * Ultrix setlocale(..., "") fails if there are no environment
 363      * variables from which to get a locale name.
 364      */
 365
 366     bool done = FALSE;
 367
 368 #   ifdef LC_ALL
 369     if (lang) {
 370         if (setlocale(LC_ALL, setlocale_init))
 371             done = TRUE;
 372         else
 373             setlocale_failure = TRUE;
 374     }
 375     if (!setlocale_failure) {
 376 #       ifdef USE_LOCALE_CTYPE
 377         Safefree(curctype);
 378         if (! (curctype =
 379                setlocale(LC_CTYPE,
 380                          (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
 381                                     ? setlocale_init : NULL)))
 382             setlocale_failure = TRUE;
 383         else
 384             curctype = savepv(curctype);
 385 #       endif /* USE_LOCALE_CTYPE */
 386 #       ifdef USE_LOCALE_COLLATE
 387         Safefree(curcoll);
 388         if (! (curcoll =
 389                setlocale(LC_COLLATE,
 390                          (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
 391                                    ? setlocale_init : NULL)))
 392             setlocale_failure = TRUE;
 393         else
 394             curcoll = savepv(curcoll);
 395 #       endif /* USE_LOCALE_COLLATE */
 396 #       ifdef USE_LOCALE_NUMERIC
 397         Safefree(curnum);
 398         if (! (curnum =
 399                setlocale(LC_NUMERIC,
 400                          (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
 401                                   ? setlocale_init : NULL)))
 402             setlocale_failure = TRUE;
 403         else
 404             curnum = savepv(curnum);
 405 #       endif /* USE_LOCALE_NUMERIC */
 406     }
 407
 408 #   endif /* LC_ALL */
 409
 410 #endif /* !LOCALE_ENVIRON_REQUIRED */
 411
 412 #ifdef LC_ALL
 413     if (! setlocale(LC_ALL, setlocale_init))
 414         setlocale_failure = TRUE;
 415 #endif /* LC_ALL */
 416
 417     if (!setlocale_failure) {
 418 #ifdef USE_LOCALE_CTYPE
 419         Safefree(curctype);
 420         if (! (curctype = setlocale(LC_CTYPE, setlocale_init)))
 421             setlocale_failure = TRUE;
 422         else
 423             curctype = savepv(curctype);
 424 #endif /* USE_LOCALE_CTYPE */
 425 #ifdef USE_LOCALE_COLLATE
 426         Safefree(curcoll);
 427         if (! (curcoll = setlocale(LC_COLLATE, setlocale_init)))
 428             setlocale_failure = TRUE;
 429         else
 430             curcoll = savepv(curcoll);
 431 #endif /* USE_LOCALE_COLLATE */
 432 #ifdef USE_LOCALE_NUMERIC
 433         Safefree(curnum);
 434         if (! (curnum = setlocale(LC_NUMERIC, setlocale_init)))
 435             setlocale_failure = TRUE;
 436         else
 437             curnum = savepv(curnum);
 438 #endif /* USE_LOCALE_NUMERIC */
 439     }
 440
 441     if (setlocale_failure) {
 442         char *p;
 443         const bool locwarn = (printwarn > 1 ||
 444                         (printwarn &&
 445                          (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
 446
 447         if (locwarn) {
 448 #ifdef LC_ALL
 449
 450             PerlIO_printf(Perl_error_log,
 451                "perl: warning: Setting locale failed.\n");
 452
 453 #else /* !LC_ALL */
 454
 455             PerlIO_printf(Perl_error_log,
 456                "perl: warning: Setting locale failed for the categories:\n\t");
 457 #ifdef USE_LOCALE_CTYPE
 458             if (! curctype)
 459                 PerlIO_printf(Perl_error_log, "LC_CTYPE ");
 460 #endif /* USE_LOCALE_CTYPE */
 461 #ifdef USE_LOCALE_COLLATE
 462             if (! curcoll)
 463                 PerlIO_printf(Perl_error_log, "LC_COLLATE ");
 464 #endif /* USE_LOCALE_COLLATE */
 465 #ifdef USE_LOCALE_NUMERIC
 466             if (! curnum)
 467                 PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
 468 #endif /* USE_LOCALE_NUMERIC */
 469             PerlIO_printf(Perl_error_log, "\n");
 470
 471 #endif /* LC_ALL */
 472
 473             PerlIO_printf(Perl_error_log,
 474                 "perl: warning: Please check that your locale settings:\n");
 475
 476 #ifdef __GLIBC__
 477             PerlIO_printf(Perl_error_log,
 478                           "\tLANGUAGE = %c%s%c,\n",
 479                           language ? '"' : '(',
 480                           language ? language : "unset",
 481                           language ? '"' : ')');
 482 #endif
 483
 484             PerlIO_printf(Perl_error_log,
 485                           "\tLC_ALL = %c%s%c,\n",
 486                           lc_all ? '"' : '(',
 487                           lc_all ? lc_all : "unset",
 488                           lc_all ? '"' : ')');
 489
 490 #if defined(USE_ENVIRON_ARRAY)
 491             {
 492               char **e;
 493               for (e = environ; *e; e++) {
 494                   if (strnEQ(*e, "LC_", 3)
 495                         && strnNE(*e, "LC_ALL=", 7)
 496                         && (p = strchr(*e, '=')))
 497                       PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
 498                                     (int)(p - *e), *e, p + 1);
 499               }
 500             }
 501 #else
 502             PerlIO_printf(Perl_error_log,
 503                           "\t(possibly more locale environment variables)\n");
 504 #endif
 505
 506             PerlIO_printf(Perl_error_log,
 507                           "\tLANG = %c%s%c\n",
 508                           lang ? '"' : '(',
 509                           lang ? lang : "unset",
 510                           lang ? '"' : ')');
 511
 512             PerlIO_printf(Perl_error_log,
 513                           "    are supported and installed on your system.\n");
 514         }
 515
 516 #ifdef LC_ALL
 517
 518         if (setlocale(LC_ALL, "C")) {
 519             if (locwarn)
 520                 PerlIO_printf(Perl_error_log,
 521       "perl: warning: Falling back to the standard locale (\"C\").\n");
 522             ok = 0;
 523         }
 524         else {
 525             if (locwarn)
 526                 PerlIO_printf(Perl_error_log,
 527       "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
 528             ok = -1;
 529         }
 530
 531 #else /* ! LC_ALL */
 532
 533         if (0
 534 #ifdef USE_LOCALE_CTYPE
 535             || !(curctype || setlocale(LC_CTYPE, "C"))
 536 #endif /* USE_LOCALE_CTYPE */
 537 #ifdef USE_LOCALE_COLLATE
 538             || !(curcoll || setlocale(LC_COLLATE, "C"))
 539 #endif /* USE_LOCALE_COLLATE */
 540 #ifdef USE_LOCALE_NUMERIC
 541             || !(curnum || setlocale(LC_NUMERIC, "C"))
 542 #endif /* USE_LOCALE_NUMERIC */
 543             )
 544         {
 545             if (locwarn)
 546                 PerlIO_printf(Perl_error_log,
 547       "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
 548             ok = -1;
 549         }
 550
 551 #endif /* ! LC_ALL */
 552
 553 #ifdef USE_LOCALE_CTYPE
 554         Safefree(curctype);
 555         curctype = savepv(setlocale(LC_CTYPE, NULL));
 556 #endif /* USE_LOCALE_CTYPE */
 557 #ifdef USE_LOCALE_COLLATE
 558         Safefree(curcoll);
 559         curcoll = savepv(setlocale(LC_COLLATE, NULL));
 560 #endif /* USE_LOCALE_COLLATE */
 561 #ifdef USE_LOCALE_NUMERIC
 562         Safefree(curnum);
 563         curnum = savepv(setlocale(LC_NUMERIC, NULL));
 564 #endif /* USE_LOCALE_NUMERIC */
 565     }
 566     else {
 567
 568 #ifdef USE_LOCALE_CTYPE
 569     new_ctype(curctype);
 570 #endif /* USE_LOCALE_CTYPE */
 571
 572 #ifdef USE_LOCALE_COLLATE
 573     new_collate(curcoll);
 574 #endif /* USE_LOCALE_COLLATE */
 575
 576 #ifdef USE_LOCALE_NUMERIC
 577     new_numeric(curnum);
 578 #endif /* USE_LOCALE_NUMERIC */
 579
 580     }
 581
 582 #if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
 583     {
 584       /* Set PL_utf8locale to TRUE if using PerlIO _and_
 585          the current LC_CTYPE locale is UTF-8.
 586          If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
 587          are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
 588          on STDIN, STDOUT, STDERR, _and_ the default open discipline.
 589       */
 590         PL_utf8locale = is_cur_LC_category_utf8(LC_CTYPE);
 591     }
 592     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
 593        This is an alternative to using the -C command line switch
 594        (the -C if present will override this). */
 595     {
 596          const char *p = PerlEnv_getenv("PERL_UNICODE");
 597          PL_unicode = p ? parse_unicode_opts(&p) : 0;
 598          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
 599              PL_utf8cache = -1;
 600     }
 601 #endif
 602
 603 #ifdef USE_LOCALE_CTYPE
 604     Safefree(curctype);
 605 #endif /* USE_LOCALE_CTYPE */
 606 #ifdef USE_LOCALE_COLLATE
 607     Safefree(curcoll);
 608 #endif /* USE_LOCALE_COLLATE */
 609 #ifdef USE_LOCALE_NUMERIC
 610     Safefree(curnum);
 611 #endif /* USE_LOCALE_NUMERIC */
 612
 613 #endif /* USE_LOCALE */
 614
 615     return ok;
 616 }
 617
 618 #ifdef USE_LOCALE_COLLATE
 619
 620 /*
 621  * mem_collxfrm() is a bit like strxfrm() but with two important
 622  * differences. First, it handles embedded NULs. Second, it allocates
 623  * a bit more memory than needed for the transformed data itself.
 624  * The real transformed data begins at offset sizeof(collationix).
 625  * Please see sv_collxfrm() to see how this is used.
 626  */
 627
 628 char *
 629 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
 630 {
 631     dVAR;
 632     char *xbuf;
 633     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
 634
 635     PERL_ARGS_ASSERT_MEM_COLLXFRM;
 636
 637     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
 638     /* the +1 is for the terminating NUL. */
 639
 640     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
 641     Newx(xbuf, xAlloc, char);
 642     if (! xbuf)
 643         goto bad;
 644
 645     *(U32*)xbuf = PL_collation_ix;
 646     xout = sizeof(PL_collation_ix);
 647     for (xin = 0; xin < len; ) {
 648         Size_t xused;
 649
 650         for (;;) {
 651             xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
 652             if (xused >= PERL_INT_MAX)
 653                 goto bad;
 654             if ((STRLEN)xused < xAlloc - xout)
 655                 break;
 656             xAlloc = (2 * xAlloc) + 1;
 657             Renew(xbuf, xAlloc, char);
 658             if (! xbuf)
 659                 goto bad;
 660         }
 661
 662         xin += strlen(s + xin) + 1;
 663         xout += xused;
 664
 665         /* Embedded NULs are understood but silently skipped
 666          * because they make no sense in locale collation. */
 667     }
 668
 669     xbuf[xout] = '\0';
 670     *xlen = xout - sizeof(PL_collation_ix);
 671     return xbuf;
 672
 673   bad:
 674     Safefree(xbuf);
 675     *xlen = 0;
 676     return NULL;
 677 }
 678
 679 #endif /* USE_LOCALE_COLLATE */
 680
 681 #ifdef USE_LOCALE
 682
 683 STATIC bool
 684 S_is_cur_LC_category_utf8(pTHX_ int category)
 685 {
 686     /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
 687      * otherwise. 'category' may not be LC_ALL.  If the platform doesn't have
 688      * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
 689      * could give the wrong result.  It errs on the side of not being a UTF-8
 690      * locale. */
 691
 692     char *save_input_locale = NULL;
 693     STRLEN final_pos;
 694
 695 #ifdef LC_ALL
 696     assert(category != LC_ALL);
 697 #endif
 698
 699     /* First dispose of the trivial cases */
 700     save_input_locale = setlocale(category, NULL);
 701     if (! save_input_locale) {
 702         return FALSE;   /* XXX maybe should croak */
 703     }
 704     save_input_locale = stdize_locale(savepv(save_input_locale));
 705     if ((*save_input_locale == 'C' && save_input_locale[1] == '\0')
 706         || strEQ(save_input_locale, "POSIX"))
 707     {
 708         Safefree(save_input_locale);
 709         return FALSE;
 710     }
 711
 712 #if defined(USE_LOCALE_CTYPE)    \
 713     && (defined(MB_CUR_MAX) || (defined(HAS_NL_LANGINFO) && defined(CODESET)))
 714
 715     { /* Next try nl_langinfo or MB_CUR_MAX if available */
 716
 717         char *save_ctype_locale = NULL;
 718         bool is_utf8;
 719
 720         if (category != LC_CTYPE) { /* These work only on LC_CTYPE */
 721
 722             /* Get the current LC_CTYPE locale */
 723             save_ctype_locale = stdize_locale(savepv(setlocale(LC_CTYPE, NULL)));
 724             if (! save_ctype_locale) {
 725                 goto cant_use_nllanginfo;
 726             }
 727
 728             /* If LC_CTYPE and the desired category use the same locale, this
 729              * means that finding the value for LC_CTYPE is the same as finding
 730              * the value for the desired category.  Otherwise, switch LC_CTYPE
 731              * to the desired category's locale */
 732             if (strEQ(save_ctype_locale, save_input_locale)) {
 733                 Safefree(save_ctype_locale);
 734                 save_ctype_locale = NULL;
 735             }
 736             else if (! setlocale(LC_CTYPE, save_input_locale)) {
 737                 Safefree(save_ctype_locale);
 738                 goto cant_use_nllanginfo;
 739             }
 740         }
 741
 742         /* Here the current LC_CTYPE is set to the locale of the category whose
 743          * information is desired.  This means that nl_langinfo() and MB_CUR_MAX
 744          * should give the correct results */
 745
 746 #   if defined(HAS_NL_LANGINFO) && defined(CODESET)
 747         {
 748             char *codeset = savepv(nl_langinfo(CODESET));
 749             if (codeset && strNE(codeset, "")) {
 750
 751                 /* If we switched LC_CTYPE, switch back */
 752                 if (save_ctype_locale) {
 753                     setlocale(LC_CTYPE, save_ctype_locale);
 754                     Safefree(save_ctype_locale);
 755                 }
 756
 757                 is_utf8 = foldEQ(codeset, STR_WITH_LEN("UTF-8"))
 758                         || foldEQ(codeset, STR_WITH_LEN("UTF8"));
 759
 760                 Safefree(codeset);
 761                 Safefree(save_input_locale);
 762                 return is_utf8;
 763             }
 764         }
 765
 766 #   endif
 767 #   ifdef MB_CUR_MAX
 768
 769         /* Here, either we don't have nl_langinfo, or it didn't return a
 770          * codeset.  Try MB_CUR_MAX */
 771
 772         /* Standard UTF-8 needs at least 4 bytes to represent the maximum
 773          * Unicode code point.  Since UTF-8 is the only non-single byte
 774          * encoding we handle, we just say any such encoding is UTF-8, and if
 775          * turns out to be wrong, other things will fail */
 776         is_utf8 = MB_CUR_MAX >= 4;
 777
 778         Safefree(save_input_locale);
 779
 780 #       ifdef HAS_MBTOWC
 781
 782         /* ... But, most system that have MB_CUR_MAX will also have mbtowc(),
 783          * since they are both in the C99 standard.  We can feed a known byte
 784          * string to the latter function, and check that it gives the expected
 785          * result */
 786         if (is_utf8) {
 787             wchar_t wc;
 788             (void) mbtowc(&wc, NULL, 0);    /* Reset any shift state */
 789             if (mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8))
 790                                                         != strlen(HYPHEN_UTF8)
 791                 || wc != (wchar_t) 0x2010)
 792             {
 793                 is_utf8 = FALSE;
 794             }
 795         }
 796 #       endif
 797
 798         /* If we switched LC_CTYPE, switch back */
 799         if (save_ctype_locale) {
 800             setlocale(LC_CTYPE, save_ctype_locale);
 801             Safefree(save_ctype_locale);
 802         }
 803
 804         return is_utf8;
 805 #   endif
 806     }
 807
 808   cant_use_nllanginfo:
 809
 810 #endif /* HAS_NL_LANGINFO etc */
 811
 812     /* nl_langinfo not available or failed somehow.  Look at the locale name to
 813      * see if it matches qr/UTF -? 8 /ix  */
 814
 815     final_pos = strlen(save_input_locale) - 1;
 816     if (final_pos >= 3) {
 817         char *name = save_input_locale;
 818
 819         /* Find next 'U' or 'u' and look from there */
 820         while ((name += strcspn(name, "Uu") + 1)
 821                                             <= save_input_locale + final_pos - 2)
 822         {
 823             if (toFOLD(*(name)) != 't'
 824                 || toFOLD(*(name + 1)) != 'f')
 825             {
 826                 continue;
 827             }
 828             name += 2;
 829             if (*(name) == '-') {
 830                 if ((name > save_input_locale + final_pos - 1)) {
 831                     break;
 832                 }
 833                 name++;
 834             }
 835             if (*(name) == '8') {
 836                 Safefree(save_input_locale);
 837                 return TRUE;
 838             }
 839         }
 840     }
 841
 842 #ifdef WIN32
 843     /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
 844     if (final_pos >= 4
 845         && *(save_input_locale + final_pos - 0) == '1'
 846         && *(save_input_locale + final_pos - 1) == '0'
 847         && *(save_input_locale + final_pos - 2) == '0'
 848         && *(save_input_locale + final_pos - 3) == '5'
 849         && *(save_input_locale + final_pos - 4) == '6')
 850     {
 851         Safefree(save_input_locale);
 852         return TRUE;
 853     }
 854 #endif
 855
 856     /* Other common encodings are the ISO 8859 series, which aren't UTF-8 */
 857     if (instr(save_input_locale, "8859")) {
 858         Safefree(save_input_locale);
 859         return FALSE;
 860     }
 861
 862 #ifdef HAS_LOCALECONV
 863
 864 #   ifdef USE_LOCALE_MONETARY
 865
 866     /* Here, there is nothing in the locale name to indicate whether the locale
 867      * is UTF-8 or not.  This "name", the return of setlocale(), is actually
 868      * defined to be opaque, so we can't really rely on the absence of various
 869      * substrings in the name to indicate its UTF-8ness.  Look at the locale's
 870      * currency symbol.  Often that will be in the native script, and if the
 871      * symbol isn't in UTF-8, we know that the locale isn't.  If it is
 872      * non-ASCII UTF-8, we infer that the locale is too.
 873      * To do this, like above for LC_CTYPE, we first set LC_MONETARY to the
 874      * locale of the desired category, if it isn't that locale already */
 875
 876     {
 877         char *save_monetary_locale = NULL;
 878         bool illegal_utf8 = FALSE;
 879         bool only_ascii = FALSE;
 880         const struct lconv* const lc = localeconv();
 881
 882         if (category != LC_MONETARY) {
 883
 884             save_monetary_locale = stdize_locale(savepv(setlocale(LC_MONETARY,
 885                                                                   NULL)));
 886             if (! save_monetary_locale) {
 887                 goto cant_use_monetary;
 888             }
 889
 890             if (strNE(save_monetary_locale, save_input_locale)) {
 891                 if (! setlocale(LC_MONETARY, save_input_locale)) {
 892                     Safefree(save_monetary_locale);
 893                     goto cant_use_monetary;
 894                 }
 895             }
 896         }
 897
 898         /* Here the current LC_MONETARY is set to the locale of the category
 899          * whose information is desired. */
 900
 901         if (lc && lc->currency_symbol) {
 902             if (! is_utf8_string((U8 *) lc->currency_symbol, 0)) {
 903                 illegal_utf8 = TRUE;
 904             }
 905             else if (is_ascii_string((U8 *) lc->currency_symbol, 0)) {
 906                 only_ascii = TRUE;
 907             }
 908         }
 909
 910         /* If we changed it, restore LC_MONETARY to its original locale */
 911         if (save_monetary_locale) {
 912             setlocale(LC_MONETARY, save_monetary_locale);
 913             Safefree(save_monetary_locale);
 914         }
 915
 916         Safefree(save_input_locale);
 917
 918         /* It isn't a UTF-8 locale if the symbol is not legal UTF-8; otherwise
 919          * assume the locale is UTF-8 if and only if the symbol is non-ascii
 920          * UTF-8.  (We can't really tell if the locale is UTF-8 or not if the
 921          * symbol is just a '$', so we err on the side of it not being UTF-8)
 922          * */
 923         return (illegal_utf8)
 924                 ? FALSE
 925                 : ! only_ascii;
 926
 927     }
 928   cant_use_monetary:
 929
 930 #   endif /* USE_LOCALE_MONETARY */
 931 #endif /* HAS_LOCALECONV */
 932
 933 #if 0 && defined(HAS_STRERROR) && defined(USE_LOCALE_MESSAGES)
 934
 935 /* This code is ifdefd out because it was found to not be necessary in testing
 936  * on our dromedary test machine, which has over 700 locales.  There, looking
 937  * at just the currency symbol gave essentially the same results as doing this
 938  * extra work.  Executing this also caused segfaults in miniperl.  I left it in
 939  * so as to avoid rewriting it if real-world experience indicates that
 940  * dromedary is an outlier.  Essentially, instead of returning abpve if we
 941  * haven't found illegal utf8, we continue on and examine all the strerror()
 942  * messages on the platform for utf8ness.  If all are ASCII, we still don't
 943  * know the answer; but otherwise we have a pretty good indication of the
 944  * utf8ness.  The reason this doesn't necessarily help much is that the
 945  * messages may not have been translated into the locale.  The currency symbol
 946  * is much more likely to have been translated.  The code below would need to
 947  * be altered somewhat to just be a continuation of testing the currency
 948  * symbol. */
 949         int e;
 950         unsigned int failures = 0, non_ascii = 0;
 951         char *save_messages_locale = NULL;
 952
 953         /* Like above for LC_CTYPE, we set LC_MESSAGES to the locale of the
 954          * desired category, if it isn't that locale already */
 955
 956         if (category != LC_MESSAGES) {
 957
 958             save_messages_locale = stdize_locale(savepv(setlocale(LC_MESSAGES,
 959                                                                   NULL)));
 960             if (! save_messages_locale) {
 961                 goto cant_use_messages;
 962             }
 963
 964             if (strEQ(save_messages_locale, save_input_locale)) {
 965                 Safefree(save_input_locale);
 966             }
 967             else if (! setlocale(LC_MESSAGES, save_input_locale)) {
 968                 Safefree(save_messages_locale);
 969                 goto cant_use_messages;
 970             }
 971         }
 972
 973         /* Here the current LC_MESSAGES is set to the locale of the category
 974          * whose information is desired.  Look through all the messages */
 975
 976         for (e = 0;
 977 #ifdef HAS_SYS_ERRLIST
 978              e <= sys_nerr
 979 #endif
 980              ; e++)
 981         {
 982             const U8* const errmsg = (U8 *) Strerror(e) ;
 983             if (!errmsg)
 984                 break;
 985             if (! is_utf8_string(errmsg, 0)) {
 986                 failures++;
 987                 break;
 988             }
 989             else if (! is_ascii_string(errmsg, 0)) {
 990                 non_ascii++;
 991             }
 992         }
 993
 994         /* And, if we changed it, restore LC_MESSAGES to its original locale */
 995         if (save_messages_locale) {
 996             setlocale(LC_MESSAGES, save_messages_locale);
 997             Safefree(save_messages_locale);
 998         }
 999
1000         /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid,
1001          * any non-ascii means it is one; otherwise we assume it isn't */
1002         return (failures) ? FALSE : non_ascii;
1003
1004     }
1005   cant_use_messages:
1006
1007 #endif
1008
1009     Safefree(save_input_locale);
1010     return FALSE;
1011 }
1012
1013 #endif
1014
1015 /*
1016  * Local variables:
1017  * c-indentation-style: bsd
1018  * c-basic-offset: 4
1019  * indent-tabs-mode: nil
1020  * End:
1021  *
1022  * ex: set ts=8 sts=4 sw=4 et:
1023  */