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 code generally doesn't pay
  27  * any 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.  And, LC_MESSAGES is
  33  * switched to the C locale for outputting the message unless within the scope
  34  * of 'use locale'.
  35  *
  36  * This code now has multi-thread-safe locale handling on systems that support
  37  * that.  This is completely transparent to most XS code.  On earlier systems,
  38  * it would be possible to emulate thread-safe locales, but this likely would
  39  * involve a lot of locale switching, and would require XS code changes.
  40  * Macros could be written so that the code wouldn't have to know which type of
  41  * system is being used.  It's unlikely that we would ever do that, since most
  42  * modern systems support thread-safe locales, but there was code written to
  43  * this end, and is retained, #ifdef'd out.
  44  */
  45
  46 #include "EXTERN.h"
  47 #define PERL_IN_LOCALE_C
  48 #include "perl_langinfo.h"
  49 #include "perl.h"
  50
  51 #include "reentr.h"
  52
  53 #ifdef I_WCHAR
  54 #  include <wchar.h>
  55 #endif
  56
  57 /* If the environment says to, we can output debugging information during
  58  * initialization.  This is done before option parsing, and before any thread
  59  * creation, so can be a file-level static */
  60 #if ! defined(DEBUGGING) || defined(PERL_GLOBAL_STRUCT)
  61 #  define debug_initialization 0
  62 #  define DEBUG_INITIALIZATION_set(v)
  63 #else
  64 static bool debug_initialization = FALSE;
  65 #  define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
  66 #endif
  67
  68
  69 /* Returns the Unix errno portion; ignoring any others.  This is a macro here
  70  * instead of putting it into perl.h, because unclear to khw what should be
  71  * done generally. */
  72 #define GET_ERRNO   saved_errno
  73
  74 /* strlen() of a literal string constant.  We might want this more general,
  75  * but using it in just this file for now.  A problem with more generality is
  76  * the compiler warnings about comparing unlike signs */
  77 #define STRLENs(s)  (sizeof("" s "") - 1)
  78
  79 /* Is the C string input 'name' "C" or "POSIX"?  If so, and 'name' is the
  80  * return of setlocale(), then this is extremely likely to be the C or POSIX
  81  * locale.  However, the output of setlocale() is documented to be opaque, but
  82  * the odds are extremely small that it would return these two strings for some
  83  * other locale.  Note that VMS in these two locales includes many non-ASCII
  84  * characters as controls and punctuation (below are hex bytes):
  85  *   cntrl:  84-97 9B-9F
  86  *   punct:  A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
  87  * Oddly, none there are listed as alphas, though some represent alphabetics
  88  * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
  89 #define isNAME_C_OR_POSIX(name)                                              \
  90                              (   (name) != NULL                              \
  91                               && (( *(name) == 'C' && (*(name + 1)) == '\0') \
  92                                    || strEQ((name), "POSIX")))
  93
  94 #ifdef USE_LOCALE
  95
  96 /* This code keeps a LRU cache of the UTF-8ness of the locales it has so-far
  97  * looked up.  This is in the form of a C string:  */
  98
  99 #define UTF8NESS_SEP     "\v"
 100 #define UTF8NESS_PREFIX  "\f"
 101
 102 /* So, the string looks like:
 103  *
 104  *      \vC\a0\vPOSIX\a0\vam_ET\a0\vaf_ZA.utf8\a1\ven_US.UTF-8\a1\0
 105  *
 106  * where the digit 0 after the \a indicates that the locale starting just
 107  * after the preceding \v is not UTF-8, and the digit 1 mean it is. */
 108
 109 STATIC_ASSERT_DECL(STRLENs(UTF8NESS_SEP) == 1);
 110 STATIC_ASSERT_DECL(STRLENs(UTF8NESS_PREFIX) == 1);
 111
 112 #define C_and_POSIX_utf8ness    UTF8NESS_SEP "C"     UTF8NESS_PREFIX "0"    \
 113                                 UTF8NESS_SEP "POSIX" UTF8NESS_PREFIX "0"
 114
 115 /* The cache is initialized to C_and_POSIX_utf8ness at start up.  These are
 116  * kept there always.  The remining portion of the cache is LRU, with the
 117  * oldest looked-up locale at the tail end */
 118
 119 STATIC char *
 120 S_stdize_locale(pTHX_ char *locs)
 121 {
 122     /* Standardize the locale name from a string returned by 'setlocale',
 123      * possibly modifying that string.
 124      *
 125      * The typical return value of setlocale() is either
 126      * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
 127      * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
 128      *     (the space-separated values represent the various sublocales,
 129      *      in some unspecified order).  This is not handled by this function.
 130      *
 131      * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
 132      * which is harmful for further use of the string in setlocale().  This
 133      * function removes the trailing new line and everything up through the '='
 134      * */
 135
 136     const char * const s = strchr(locs, '=');
 137     bool okay = TRUE;
 138
 139     PERL_ARGS_ASSERT_STDIZE_LOCALE;
 140
 141     if (s) {
 142         const char * const t = strchr(s, '.');
 143         okay = FALSE;
 144         if (t) {
 145             const char * const u = strchr(t, '\n');
 146             if (u && (u[1] == 0)) {
 147                 const STRLEN len = u - s;
 148                 Move(s + 1, locs, len, char);
 149                 locs[len] = 0;
 150                 okay = TRUE;
 151             }
 152         }
 153     }
 154
 155     if (!okay)
 156         Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
 157
 158     return locs;
 159 }
 160
 161 /* Two parallel arrays; first the locale categories Perl uses on this system;
 162  * the second array is their names.  These arrays are in mostly arbitrary
 163  * order. */
 164
 165 const int categories[] = {
 166
 167 #    ifdef USE_LOCALE_NUMERIC
 168                              LC_NUMERIC,
 169 #    endif
 170 #    ifdef USE_LOCALE_CTYPE
 171                              LC_CTYPE,
 172 #    endif
 173 #    ifdef USE_LOCALE_COLLATE
 174                              LC_COLLATE,
 175 #    endif
 176 #    ifdef USE_LOCALE_TIME
 177                              LC_TIME,
 178 #    endif
 179 #    ifdef USE_LOCALE_MESSAGES
 180                              LC_MESSAGES,
 181 #    endif
 182 #    ifdef USE_LOCALE_MONETARY
 183                              LC_MONETARY,
 184 #    endif
 185 #    ifdef USE_LOCALE_ADDRESS
 186                              LC_ADDRESS,
 187 #    endif
 188 #    ifdef USE_LOCALE_IDENTIFICATION
 189                              LC_IDENTIFICATION,
 190 #    endif
 191 #    ifdef USE_LOCALE_MEASUREMENT
 192                              LC_MEASUREMENT,
 193 #    endif
 194 #    ifdef USE_LOCALE_PAPER
 195                              LC_PAPER,
 196 #    endif
 197 #    ifdef USE_LOCALE_TELEPHONE
 198                              LC_TELEPHONE,
 199 #    endif
 200 #    ifdef LC_ALL
 201                              LC_ALL,
 202 #    endif
 203                             -1  /* Placeholder because C doesn't allow a
 204                                    trailing comma, and it would get complicated
 205                                    with all the #ifdef's */
 206 };
 207
 208 /* The top-most real element is LC_ALL */
 209
 210 const char * category_names[] = {
 211
 212 #    ifdef USE_LOCALE_NUMERIC
 213                                  "LC_NUMERIC",
 214 #    endif
 215 #    ifdef USE_LOCALE_CTYPE
 216                                  "LC_CTYPE",
 217 #    endif
 218 #    ifdef USE_LOCALE_COLLATE
 219                                  "LC_COLLATE",
 220 #    endif
 221 #    ifdef USE_LOCALE_TIME
 222                                  "LC_TIME",
 223 #    endif
 224 #    ifdef USE_LOCALE_MESSAGES
 225                                  "LC_MESSAGES",
 226 #    endif
 227 #    ifdef USE_LOCALE_MONETARY
 228                                  "LC_MONETARY",
 229 #    endif
 230 #    ifdef USE_LOCALE_ADDRESS
 231                                  "LC_ADDRESS",
 232 #    endif
 233 #    ifdef USE_LOCALE_IDENTIFICATION
 234                                  "LC_IDENTIFICATION",
 235 #    endif
 236 #    ifdef USE_LOCALE_MEASUREMENT
 237                                  "LC_MEASUREMENT",
 238 #    endif
 239 #    ifdef USE_LOCALE_PAPER
 240                                  "LC_PAPER",
 241 #    endif
 242 #    ifdef USE_LOCALE_TELEPHONE
 243                                  "LC_TELEPHONE",
 244 #    endif
 245 #    ifdef LC_ALL
 246                                  "LC_ALL",
 247 #    endif
 248                                  NULL  /* Placeholder */
 249                             };
 250
 251 #  ifdef LC_ALL
 252
 253     /* On systems with LC_ALL, it is kept in the highest index position.  (-2
 254      * to account for the final unused placeholder element.) */
 255 #    define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 2)
 256
 257 #  else
 258
 259     /* On systems without LC_ALL, we pretend it is there, one beyond the real
 260      * top element, hence in the unused placeholder element. */
 261 #    define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 1)
 262
 263 #  endif
 264
 265 /* Pretending there is an LC_ALL element just above allows us to avoid most
 266  * special cases.  Most loops through these arrays in the code below are
 267  * written like 'for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)'.  They will work
 268  * on either type of system.  But the code must be written to not access the
 269  * element at 'LC_ALL_INDEX' except on platforms that have it.  This can be
 270  * checked for at compile time by using the #define LC_ALL_INDEX which is only
 271  * defined if we do have LC_ALL. */
 272
 273 STATIC const char *
 274 S_category_name(const int category)
 275 {
 276     unsigned int i;
 277
 278 #ifdef LC_ALL
 279
 280     if (category == LC_ALL) {
 281         return "LC_ALL";
 282     }
 283
 284 #endif
 285
 286     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
 287         if (category == categories[i]) {
 288             return category_names[i];
 289         }
 290     }
 291
 292     {
 293         const char suffix[] = " (unknown)";
 294         int temp = category;
 295         Size_t length = sizeof(suffix) + 1;
 296         char * unknown;
 297         dTHX;
 298
 299         if (temp < 0) {
 300             length++;
 301             temp = - temp;
 302         }
 303
 304         /* Calculate the number of digits */
 305         while (temp >= 10) {
 306             temp /= 10;
 307             length++;
 308         }
 309
 310         Newx(unknown, length, char);
 311         my_snprintf(unknown, length, "%d%s", category, suffix);
 312         SAVEFREEPV(unknown);
 313         return unknown;
 314     }
 315 }
 316
 317 /* Now create LC_foo_INDEX #defines for just those categories on this system */
 318 #  ifdef USE_LOCALE_NUMERIC
 319 #    define LC_NUMERIC_INDEX            0
 320 #    define _DUMMY_NUMERIC              LC_NUMERIC_INDEX
 321 #  else
 322 #    define _DUMMY_NUMERIC              -1
 323 #  endif
 324 #  ifdef USE_LOCALE_CTYPE
 325 #    define LC_CTYPE_INDEX              _DUMMY_NUMERIC + 1
 326 #    define _DUMMY_CTYPE                LC_CTYPE_INDEX
 327 #  else
 328 #    define _DUMMY_CTYPE                _DUMMY_NUMERIC
 329 #  endif
 330 #  ifdef USE_LOCALE_COLLATE
 331 #    define LC_COLLATE_INDEX            _DUMMY_CTYPE + 1
 332 #    define _DUMMY_COLLATE              LC_COLLATE_INDEX
 333 #  else
 334 #    define _DUMMY_COLLATE              _DUMMY_COLLATE
 335 #  endif
 336 #  ifdef USE_LOCALE_TIME
 337 #    define LC_TIME_INDEX               _DUMMY_COLLATE + 1
 338 #    define _DUMMY_TIME                 LC_TIME_INDEX
 339 #  else
 340 #    define _DUMMY_TIME                 _DUMMY_COLLATE
 341 #  endif
 342 #  ifdef USE_LOCALE_MESSAGES
 343 #    define LC_MESSAGES_INDEX           _DUMMY_TIME + 1
 344 #    define _DUMMY_MESSAGES             LC_MESSAGES_INDEX
 345 #  else
 346 #    define _DUMMY_MESSAGES             _DUMMY_TIME
 347 #  endif
 348 #  ifdef USE_LOCALE_MONETARY
 349 #    define LC_MONETARY_INDEX           _DUMMY_MESSAGES + 1
 350 #    define _DUMMY_MONETARY             LC_MONETARY_INDEX
 351 #  else
 352 #    define _DUMMY_MONETARY             _DUMMY_MESSAGES
 353 #  endif
 354 #  ifdef USE_LOCALE_ADDRESS
 355 #    define LC_ADDRESS_INDEX            _DUMMY_MONETARY + 1
 356 #    define _DUMMY_ADDRESS              LC_ADDRESS_INDEX
 357 #  else
 358 #    define _DUMMY_ADDRESS              _DUMMY_MONETARY
 359 #  endif
 360 #  ifdef USE_LOCALE_IDENTIFICATION
 361 #    define LC_IDENTIFICATION_INDEX     _DUMMY_ADDRESS + 1
 362 #    define _DUMMY_IDENTIFICATION       LC_IDENTIFICATION_INDEX
 363 #  else
 364 #    define _DUMMY_IDENTIFICATION       _DUMMY_ADDRESS
 365 #  endif
 366 #  ifdef USE_LOCALE_MEASUREMENT
 367 #    define LC_MEASUREMENT_INDEX        _DUMMY_IDENTIFICATION + 1
 368 #    define _DUMMY_MEASUREMENT          LC_MEASUREMENT_INDEX
 369 #  else
 370 #    define _DUMMY_MEASUREMENT          _DUMMY_IDENTIFICATION
 371 #  endif
 372 #  ifdef USE_LOCALE_PAPER
 373 #    define LC_PAPER_INDEX              _DUMMY_MEASUREMENT + 1
 374 #    define _DUMMY_PAPER                LC_PAPER_INDEX
 375 #  else
 376 #    define _DUMMY_PAPER                _DUMMY_MEASUREMENT
 377 #  endif
 378 #  ifdef USE_LOCALE_TELEPHONE
 379 #    define LC_TELEPHONE_INDEX          _DUMMY_PAPER + 1
 380 #    define _DUMMY_TELEPHONE            LC_TELEPHONE_INDEX
 381 #  else
 382 #    define _DUMMY_TELEPHONE            _DUMMY_PAPER
 383 #  endif
 384 #  ifdef LC_ALL
 385 #    define LC_ALL_INDEX                _DUMMY_TELEPHONE + 1
 386 #  endif
 387 #endif /* ifdef USE_LOCALE */
 388
 389 /* Windows requres a customized base-level setlocale() */
 390 #ifdef WIN32
 391 #  define my_setlocale(cat, locale) win32_setlocale(cat, locale)
 392 #else
 393 #  define my_setlocale(cat, locale) setlocale(cat, locale)
 394 #endif
 395
 396 #ifndef USE_POSIX_2008_LOCALE
 397
 398 /* "do_setlocale_c" is intended to be called when the category is a constant
 399  * known at compile time; "do_setlocale_r", not known until run time  */
 400 #  define do_setlocale_c(cat, locale) my_setlocale(cat, locale)
 401 #  define do_setlocale_r(cat, locale) my_setlocale(cat, locale)
 402
 403 #else   /* Below uses POSIX 2008 */
 404
 405 /* We emulate setlocale with our own function.  LC_foo is not valid for the
 406  * POSIX 2008 functions.  Instead LC_foo_MASK is used, which we use an array
 407  * lookup to convert to.  At compile time we have defined LC_foo_INDEX as the
 408  * proper offset into the array 'category_masks[]'.  At runtime, we have to
 409  * search through the array (as the actual numbers may not be small contiguous
 410  * positive integers which would lend themselves to array lookup). */
 411 #  define do_setlocale_c(cat, locale)                                       \
 412                         emulate_setlocale(cat, locale, cat ## _INDEX, TRUE)
 413 #  define do_setlocale_r(cat, locale) emulate_setlocale(cat, locale, 0, FALSE)
 414
 415 /* A third array, parallel to the ones above to map from category to its
 416  * equivalent mask */
 417 const int category_masks[] = {
 418 #  ifdef USE_LOCALE_NUMERIC
 419                                 LC_NUMERIC_MASK,
 420 #  endif
 421 #  ifdef USE_LOCALE_CTYPE
 422                                 LC_CTYPE_MASK,
 423 #  endif
 424 #  ifdef USE_LOCALE_COLLATE
 425                                 LC_COLLATE_MASK,
 426 #  endif
 427 #  ifdef USE_LOCALE_TIME
 428                                 LC_TIME_MASK,
 429 #  endif
 430 #  ifdef USE_LOCALE_MESSAGES
 431                                 LC_MESSAGES_MASK,
 432 #  endif
 433 #  ifdef USE_LOCALE_MONETARY
 434                                 LC_MONETARY_MASK,
 435 #  endif
 436 #  ifdef USE_LOCALE_ADDRESS
 437                                 LC_ADDRESS_MASK,
 438 #  endif
 439 #  ifdef USE_LOCALE_IDENTIFICATION
 440                                 LC_IDENTIFICATION_MASK,
 441 #  endif
 442 #  ifdef USE_LOCALE_MEASUREMENT
 443                                 LC_MEASUREMENT_MASK,
 444 #  endif
 445 #  ifdef USE_LOCALE_PAPER
 446                                 LC_PAPER_MASK,
 447 #  endif
 448 #  ifdef USE_LOCALE_TELEPHONE
 449                                 LC_TELEPHONE_MASK,
 450 #  endif
 451                                 /* LC_ALL can't be turned off by a Configure
 452                                  * option, and in Posix 2008, should always be
 453                                  * here, so compile it in unconditionally.
 454                                  * This could catch some glitches at compile
 455                                  * time */
 456                                 LC_ALL_MASK
 457                             };
 458
 459 STATIC const char *
 460 S_emulate_setlocale(const int category,
 461                     const char * locale,
 462                     unsigned int index,
 463                     const bool is_index_valid
 464                    )
 465 {
 466     /* This function effectively performs a setlocale() on just the current
 467      * thread; thus it is thread-safe.  It does this by using the POSIX 2008
 468      * locale functions to emulate the behavior of setlocale().  Similar to
 469      * regular setlocale(), the return from this function points to memory that
 470      * can be overwritten by other system calls, so needs to be copied
 471      * immediately if you need to retain it.  The difference here is that
 472      * system calls besides another setlocale() can overwrite it.
 473      *
 474      * By doing this, most locale-sensitive functions become thread-safe.  The
 475      * exceptions are mostly those that return a pointer to static memory.
 476      *
 477      * This function takes the same parameters, 'category' and 'locale', that
 478      * the regular setlocale() function does, but it also takes two additional
 479      * ones.  This is because the 2008 functions don't use a category; instead
 480      * they use a corresponding mask.  Because this function operates in both
 481      * worlds, it may need one or the other or both.  This function can
 482      * calculate the mask from the input category, but to avoid this
 483      * calculation, if the caller knows at compile time what the mask is, it
 484      * can pass it, setting 'is_index_valid' to TRUE; otherwise the mask
 485      * parameter is ignored.
 486      *
 487      * POSIX 2008, for some sick reason, chose not to provide a method to find
 488      * the category name of a locale.  Some vendors have created a
 489      * querylocale() function to do just that.  This function is a lot simpler
 490      * to implement on systems that have this.  Otherwise, we have to keep
 491      * track of what the locale has been set to, so that we can return its
 492      * name to emulate setlocale().  It's also possible for C code in some
 493      * library to change the locale without us knowing it, though as of
 494      * September 2017, there are no occurrences in CPAN of uselocale().  Some
 495      * libraries do use setlocale(), but that changes the global locale, and
 496      * threads using per-thread locales will just ignore those changes.
 497      * Another problem is that without querylocale(), we have to guess at what
 498      * was meant by setting a locale of "".  We handle this by not actually
 499      * ever setting to "" (unless querylocale exists), but to emulate what we
 500      * think should happen for "".
 501      */
 502
 503     int mask;
 504     locale_t old_obj;
 505     locale_t new_obj;
 506     dTHX;
 507
 508 #  ifdef DEBUGGING
 509
 510     if (DEBUG_Lv_TEST || debug_initialization) {
 511         PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale input=%d (%s), \"%s\", %d, %d\n", __FILE__, __LINE__, category, category_name(category), locale, index, is_index_valid);
 512     }
 513
 514 #  endif
 515
 516     /* If the input mask might be incorrect, calculate the correct one */
 517     if (! is_index_valid) {
 518         unsigned int i;
 519
 520 #  ifdef DEBUGGING
 521
 522         if (DEBUG_Lv_TEST || debug_initialization) {
 523             PerlIO_printf(Perl_debug_log, "%s:%d: finding index of category %d (%s)\n", __FILE__, __LINE__, category, category_name(category));
 524         }
 525
 526 #  endif
 527
 528         for (i = 0; i <= LC_ALL_INDEX; i++) {
 529             if (category == categories[i]) {
 530                 index = i;
 531                 goto found_index;
 532             }
 533         }
 534
 535         /* Here, we don't know about this category, so can't handle it.
 536          * Fallback to the early POSIX usages */
 537         Perl_warner(aTHX_ packWARN(WARN_LOCALE),
 538                             "Unknown locale category %d; can't set it to %s\n",
 539                                                      category, locale);
 540         return NULL;
 541
 542       found_index: ;
 543
 544 #  ifdef DEBUGGING
 545
 546         if (DEBUG_Lv_TEST || debug_initialization) {
 547             PerlIO_printf(Perl_debug_log, "%s:%d: index is %d for %s\n", __FILE__, __LINE__, index, category_name(category));
 548         }
 549
 550 #  endif
 551
 552     }
 553
 554     mask = category_masks[index];
 555
 556 #  ifdef DEBUGGING
 557
 558     if (DEBUG_Lv_TEST || debug_initialization) {
 559         PerlIO_printf(Perl_debug_log, "%s:%d: category name is %s; mask is 0x%x\n", __FILE__, __LINE__, category_names[index], mask);
 560     }
 561
 562 #  endif
 563
 564     /* If just querying what the existing locale is ... */
 565     if (locale == NULL) {
 566         locale_t cur_obj = uselocale((locale_t) 0);
 567
 568 #  ifdef DEBUGGING
 569
 570         if (DEBUG_Lv_TEST || debug_initialization) {
 571             PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale querying %p\n", __FILE__, __LINE__, cur_obj);
 572         }
 573
 574 #  endif
 575
 576         if (cur_obj == LC_GLOBAL_LOCALE) {
 577             return my_setlocale(category, NULL);
 578         }
 579
 580 #  ifdef HAS_QUERYLOCALE
 581
 582         return (char *) querylocale(mask, cur_obj);
 583
 584 #  else
 585
 586         /* If this assert fails, adjust the size of curlocales in intrpvar.h */
 587         STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX);
 588
 589 #    if defined(_NL_LOCALE_NAME) && defined(DEBUGGING)
 590
 591         {
 592             /* Internal glibc for querylocale(), but doesn't handle
 593              * empty-string ("") locale properly; who knows what other
 594              * glitches.  Check it for now, under debug. */
 595
 596             char * temp_name = nl_langinfo_l(_NL_LOCALE_NAME(category),
 597                                              uselocale((locale_t) 0));
 598             /*
 599             PerlIO_printf(Perl_debug_log, "%s:%d: temp_name=%s\n", __FILE__, __LINE__, temp_name ? temp_name : "NULL");
 600             PerlIO_printf(Perl_debug_log, "%s:%d: index=%d\n", __FILE__, __LINE__, index);
 601             PerlIO_printf(Perl_debug_log, "%s:%d: PL_curlocales[index]=%s\n", __FILE__, __LINE__, PL_curlocales[index]);
 602             */
 603             if (temp_name && PL_curlocales[index] && strNE(temp_name, "")) {
 604                 if (         strNE(PL_curlocales[index], temp_name)
 605                     && ! (   isNAME_C_OR_POSIX(temp_name)
 606                           && isNAME_C_OR_POSIX(PL_curlocales[index]))) {
 607
 608 #      ifdef USE_C_BACKTRACE
 609
 610                     dump_c_backtrace(Perl_debug_log, 20, 1);
 611
 612 #      endif
 613
 614                     Perl_croak(aTHX_ "panic: Mismatch between what Perl thinks %s is"
 615                                      " (%s) and what internal glibc thinks"
 616                                      " (%s)\n", category_names[index],
 617                                      PL_curlocales[index], temp_name);
 618                 }
 619
 620                 return temp_name;
 621             }
 622         }
 623
 624 #    endif
 625
 626         /* Without querylocale(), we have to use our record-keeping we've
 627          *  done. */
 628
 629         if (category != LC_ALL) {
 630
 631 #    ifdef DEBUGGING
 632
 633             if (DEBUG_Lv_TEST || debug_initialization) {
 634                 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[index]);
 635             }
 636
 637 #    endif
 638
 639             return PL_curlocales[index];
 640         }
 641         else {  /* For LC_ALL */
 642             unsigned int i;
 643             Size_t names_len = 0;
 644             char * all_string;
 645             bool are_all_categories_the_same_locale = TRUE;
 646
 647             /* If we have a valid LC_ALL value, just return it */
 648             if (PL_curlocales[LC_ALL_INDEX]) {
 649
 650 #    ifdef DEBUGGING
 651
 652                 if (DEBUG_Lv_TEST || debug_initialization) {
 653                     PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, PL_curlocales[LC_ALL_INDEX]);
 654                 }
 655
 656 #    endif
 657
 658                 return PL_curlocales[LC_ALL_INDEX];
 659             }
 660
 661             /* Otherwise, we need to construct a string of name=value pairs.
 662              * We use the glibc syntax, like
 663              *      LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
 664              *  First calculate the needed size.  Along the way, check if all
 665              *  the locale names are the same */
 666             for (i = 0; i < LC_ALL_INDEX; i++) {
 667
 668 #    ifdef DEBUGGING
 669
 670                 if (DEBUG_Lv_TEST || debug_initialization) {
 671                     PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
 672                 }
 673
 674 #    endif
 675
 676                 names_len += strlen(category_names[i])
 677                           + 1                       /* '=' */
 678                           + strlen(PL_curlocales[i])
 679                           + 1;                      /* ';' */
 680
 681                 if (i > 0 && strNE(PL_curlocales[i], PL_curlocales[i-1])) {
 682                     are_all_categories_the_same_locale = FALSE;
 683                 }
 684             }
 685
 686             /* If they are the same, we don't actually have to construct the
 687              * string; we just make the entry in LC_ALL_INDEX valid, and be
 688              * that single name */
 689             if (are_all_categories_the_same_locale) {
 690                 PL_curlocales[LC_ALL_INDEX] = savepv(PL_curlocales[0]);
 691                 return PL_curlocales[LC_ALL_INDEX];
 692             }
 693
 694             names_len++;    /* Trailing '\0' */
 695             SAVEFREEPV(Newx(all_string, names_len, char));
 696             *all_string = '\0';
 697
 698             /* Then fill in the string */
 699             for (i = 0; i < LC_ALL_INDEX; i++) {
 700
 701 #    ifdef DEBUGGING
 702
 703                 if (DEBUG_Lv_TEST || debug_initialization) {
 704                     PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale i=%d, name=%s, locale=%s\n", __FILE__, __LINE__, i, category_names[i], PL_curlocales[i]);
 705                 }
 706
 707 #    endif
 708
 709                 my_strlcat(all_string, category_names[i], names_len);
 710                 my_strlcat(all_string, "=", names_len);
 711                 my_strlcat(all_string, PL_curlocales[i], names_len);
 712                 my_strlcat(all_string, ";", names_len);
 713             }
 714
 715 #    ifdef DEBUGGING
 716
 717             if (DEBUG_L_TEST || debug_initialization) {
 718                 PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale returning %s\n", __FILE__, __LINE__, all_string);
 719             }
 720
 721     #endif
 722
 723             return all_string;
 724         }
 725
 726 #    ifdef EINVAL
 727
 728         SETERRNO(EINVAL, LIB_INVARG);
 729
 730 #    endif
 731
 732         return NULL;
 733
 734 #  endif
 735
 736     }
 737
 738     assert(PL_C_locale_obj);
 739
 740     /* Otherwise, we are switching locales.  This will generally entail freeing
 741      * the current one's space (at the C library's discretion).  We need to
 742      * stop using that locale before the switch.  So switch to a known locale
 743      * object that we don't otherwise mess with.  This returns the locale
 744      * object in effect at the time of the switch. */
 745     old_obj = uselocale(PL_C_locale_obj);
 746
 747 #  ifdef DEBUGGING
 748
 749     if (DEBUG_Lv_TEST || debug_initialization) {
 750         PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale was using %p\n", __FILE__, __LINE__, old_obj);
 751     }
 752
 753 #  endif
 754
 755     if (! old_obj) {
 756
 757 #  ifdef DEBUGGING
 758
 759         if (DEBUG_L_TEST || debug_initialization) {
 760             dSAVE_ERRNO;
 761             PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to C failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
 762             RESTORE_ERRNO;
 763         }
 764
 765 #  endif
 766
 767         return NULL;
 768     }
 769
 770 #  ifdef DEBUGGING
 771
 772     if (DEBUG_Lv_TEST || debug_initialization) {
 773         PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, PL_C_locale_obj);
 774     }
 775
 776 #  endif
 777
 778     /* If we weren't in a thread safe locale, set so that newlocale() below
 779      which uses 'old_obj', uses an empty one.  Same for our reserved C object.
 780      The latter is defensive coding, so that, even if there is some bug, we
 781      will never end up trying to modify either of these, as if passed to
 782      newlocale(), they can be. */
 783     if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
 784         old_obj = (locale_t) 0;
 785     }
 786
 787     /* Create the new locale (it may actually modify the current one). */
 788
 789 #  ifndef HAS_QUERYLOCALE
 790
 791     if (strEQ(locale, "")) {
 792
 793         /* For non-querylocale() systems, we do the setting of "" ourselves to
 794          * be sure that we really know what's going on.  We follow the Linux
 795          * documented behavior (but if that differs from the actual behavior,
 796          * this won't work exactly as the OS implements).  We go out and
 797          * examine the environment based on our understanding of how the system
 798          * works, and use that to figure things out */
 799
 800         const char * const lc_all = PerlEnv_getenv("LC_ALL");
 801
 802         /* Use any "LC_ALL" environment variable, as it overrides everything
 803          * else. */
 804         if (lc_all && strNE(lc_all, "")) {
 805             locale = lc_all;
 806         }
 807         else {
 808
 809             /* Otherwise, we need to dig deeper.  Unless overridden, the
 810              * default is the LANG environment variable; if it doesn't exist,
 811              * then "C" */
 812
 813             const char * default_name;
 814
 815             /* To minimize other threads messing with the environment, we copy
 816              * the variable, making it a temporary.  But this doesn't work upon
 817              * program initialization before any scopes are created, and at
 818              * this time, there's nothing else going on that would interfere.
 819              * So skip the copy in that case */
 820             if (PL_scopestack_ix == 0) {
 821                 default_name = PerlEnv_getenv("LANG");
 822             }
 823             else {
 824                 default_name = savepv(PerlEnv_getenv("LANG"));
 825             }
 826
 827             if (! default_name || strEQ(default_name, "")) {
 828                     default_name = "C";
 829             }
 830             else if (PL_scopestack_ix != 0) {
 831                 SAVEFREEPV(default_name);
 832             }
 833
 834             if (category != LC_ALL) {
 835                 const char * const name = PerlEnv_getenv(category_names[index]);
 836
 837                 /* Here we are setting a single category.  Assume will have the
 838                  * default name */
 839                 locale = default_name;
 840
 841                 /* But then look for an overriding environment variable */
 842                 if (name && strNE(name, "")) {
 843                     locale = name;
 844                 }
 845             }
 846             else {
 847                 bool did_override = FALSE;
 848                 unsigned int i;
 849
 850                 /* Here, we are getting LC_ALL.  Any categories that don't have
 851                  * a corresponding environment variable set should be set to
 852                  * LANG, or to "C" if there is no LANG.  If no individual
 853                  * categories differ from this, we can just set LC_ALL.  This
 854                  * is buggy on systems that have extra categories that we don't
 855                  * know about.  If there is an environment variable that sets
 856                  * that category, we won't know to look for it, and so our use
 857                  * of LANG or "C" improperly overrides it.  On the other hand,
 858                  * if we don't do what is done here, and there is no
 859                  * environment variable, the category's locale should be set to
 860                  * LANG or "C".  So there is no good solution.  khw thinks the
 861                  * best is to look at systems to see what categories they have,
 862                  * and include them, and then to assume that we know the
 863                  * complete set */
 864
 865                 for (i = 0; i < LC_ALL_INDEX; i++) {
 866                     const char * const env_override
 867                                     = savepv(PerlEnv_getenv(category_names[i]));
 868                     const char * this_locale = (   env_override
 869                                                 && strNE(env_override, ""))
 870                                                ? env_override
 871                                                : default_name;
 872                     emulate_setlocale(categories[i], this_locale, i, TRUE);
 873
 874                     if (strNE(this_locale, default_name)) {
 875                         did_override = TRUE;
 876                     }
 877
 878                     Safefree(env_override);
 879                 }
 880
 881                 /* If all the categories are the same, we can set LC_ALL to
 882                  * that */
 883                 if (! did_override) {
 884                     locale = default_name;
 885                 }
 886                 else {
 887
 888                     /* Here, LC_ALL is no longer valid, as some individual
 889                      * categories don't match it.  We call ourselves
 890                      * recursively, as that will execute the code that
 891                      * generates the proper locale string for this situation.
 892                      * We don't do the remainder of this function, as that is
 893                      * to update our records, and we've just done that for the
 894                      * individual categories in the loop above, and doing so
 895                      * would cause LC_ALL to be done as well */
 896                     return emulate_setlocale(LC_ALL, NULL, LC_ALL_INDEX, TRUE);
 897                 }
 898             }
 899         }
 900     }
 901     else if (strchr(locale, ';')) {
 902
 903         /* LC_ALL may actually incude a conglomeration of various categories.
 904          * Without querylocale, this code uses the glibc (as of this writing)
 905          * syntax for representing that, but that is not a stable API, and
 906          * other platforms do it differently, so we have to handle all cases
 907          * ourselves */
 908
 909         const char * s = locale;
 910         const char * e = locale + strlen(locale);
 911         const char * p = s;
 912         const char * category_end;
 913         const char * name_start;
 914         const char * name_end;
 915
 916         while (s < e) {
 917             unsigned int i;
 918
 919             /* Parse through the category */
 920             while (isWORDCHAR(*p)) {
 921                 p++;
 922             }
 923             category_end = p;
 924
 925             if (*p++ != '=') {
 926                 Perl_croak(aTHX_
 927                     "panic: %s: %d: Unexpected character in locale name '%02X",
 928                     __FILE__, __LINE__, *(p-1));
 929             }
 930
 931             /* Parse through the locale name */
 932             name_start = p;
 933             while (isGRAPH(*p) && *p != ';') {
 934                 p++;
 935             }
 936             name_end = p;
 937
 938             if (*p++ != ';') {
 939                 Perl_croak(aTHX_
 940                     "panic: %s: %d: Unexpected character in locale name '%02X",
 941                     __FILE__, __LINE__, *(p-1));
 942             }
 943
 944             /* Find the index of the category name in our lists */
 945             for (i = 0; i < LC_ALL_INDEX; i++) {
 946
 947                 /* Keep going if this isn't the index.  The strnNE() avoids a
 948                  * Perl_form(), but would fail if ever a category name could be
 949                  * a substring of another one, like if there were a
 950                  * "LC_TIME_DATE" */
 951                 if strnNE(s, category_names[i], category_end - s) {
 952                     continue;
 953                 }
 954
 955                 /* If this index is for the single category we're changing, we
 956                  * have found the locale to set it to. */
 957                 if (category == categories[i]) {
 958                     locale = Perl_form(aTHX_ "%.*s",
 959                                              (int) (name_end - name_start),
 960                                              name_start);
 961                     goto ready_to_set;
 962                 }
 963
 964                 if (category == LC_ALL) {
 965                     char * individ_locale = Perl_form(aTHX_ "%.*s", (int) (p - s), s);
 966                     emulate_setlocale(categories[i], individ_locale, i, TRUE);
 967                     Safefree(individ_locale);
 968                 }
 969             }
 970
 971             s = p;
 972         }
 973
 974         /* Here we have set all the individual categories by recursive calls.
 975          * These collectively should have fixed up LC_ALL, so can just query
 976          * what that now is */
 977         assert(category == LC_ALL);
 978
 979         return do_setlocale_c(LC_ALL, NULL);
 980     }
 981
 982   ready_to_set: ;
 983
 984 #  endif  /* end of ! querylocale */
 985
 986     /* Ready to create a new locale by modification of the exising one */
 987     new_obj = newlocale(mask, locale, old_obj);
 988
 989     if (! new_obj) {
 990         dSAVE_ERRNO;
 991
 992 #  ifdef DEBUGGING
 993
 994         if (DEBUG_L_TEST || debug_initialization) {
 995             PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale creating new object failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
 996         }
 997
 998 #  endif
 999
1000         if (! uselocale(old_obj)) {
1001
1002 #  ifdef DEBUGGING
1003
1004             if (DEBUG_L_TEST || debug_initialization) {
1005                 PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
1006             }
1007
1008 #  endif
1009
1010         }
1011         RESTORE_ERRNO;
1012         return NULL;
1013     }
1014
1015 #  ifdef DEBUGGING
1016
1017     if (DEBUG_Lv_TEST || debug_initialization) {
1018         PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p\n", __FILE__, __LINE__, new_obj);
1019     }
1020
1021 #  endif
1022
1023     /* And switch into it */
1024     if (! uselocale(new_obj)) {
1025         dSAVE_ERRNO;
1026
1027 #  ifdef DEBUGGING
1028
1029         if (DEBUG_L_TEST || debug_initialization) {
1030             PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to new object failed\n", __FILE__, __LINE__);
1031         }
1032
1033 #  endif
1034
1035         if (! uselocale(old_obj)) {
1036
1037 #  ifdef DEBUGGING
1038
1039             if (DEBUG_L_TEST || debug_initialization) {
1040                 PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO);
1041             }
1042
1043 #  endif
1044
1045         }
1046         freelocale(new_obj);
1047         RESTORE_ERRNO;
1048         return NULL;
1049     }
1050
1051 #  ifdef DEBUGGING
1052
1053     if (DEBUG_Lv_TEST || debug_initialization) {
1054         PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, new_obj);
1055     }
1056
1057 #  endif
1058
1059     /* We are done, except for updating our records (if the system doesn't keep
1060      * them) and in the case of locale "", we don't actually know what the
1061      * locale that got switched to is, as it came from the environment.  So
1062      * have to find it */
1063
1064 #  ifdef HAS_QUERYLOCALE
1065
1066     if (strEQ(locale, "")) {
1067         locale = querylocale(mask, new_obj);
1068     }
1069
1070 #  else
1071
1072     /* Here, 'locale' is the return value */
1073
1074     /* Without querylocale(), we have to update our records */
1075
1076     if (category == LC_ALL) {
1077         unsigned int i;
1078
1079         /* For LC_ALL, we change all individual categories to correspond */
1080                               /* PL_curlocales is a parallel array, so has same
1081                                * length as 'categories' */
1082         for (i = 0; i <= LC_ALL_INDEX; i++) {
1083             Safefree(PL_curlocales[i]);
1084             PL_curlocales[i] = savepv(locale);
1085         }
1086     }
1087     else {
1088
1089         /* For a single category, if it's not the same as the one in LC_ALL, we
1090          * nullify LC_ALL */
1091
1092         if (PL_curlocales[LC_ALL_INDEX] && strNE(PL_curlocales[LC_ALL_INDEX], locale)) {
1093             Safefree(PL_curlocales[LC_ALL_INDEX]);
1094             PL_curlocales[LC_ALL_INDEX] = NULL;
1095         }
1096
1097         /* Then update the category's record */
1098         Safefree(PL_curlocales[index]);
1099         PL_curlocales[index] = savepv(locale);
1100     }
1101
1102 #  endif
1103
1104     return locale;
1105 }
1106
1107 #endif /* USE_POSIX_2008_LOCALE */
1108
1109 #if 0   /* Code that was to emulate thread-safe locales on platforms that
1110            didn't natively support them */
1111
1112 /* The way this would work is that we would keep a per-thread list of the
1113  * correct locale for that thread.  Any operation that was locale-sensitive
1114  * would have to be changed so that it would look like this:
1115  *
1116  *      LOCALE_LOCK;
1117  *      setlocale to the correct locale for this operation
1118  *      do operation
1119  *      LOCALE_UNLOCK
1120  *
1121  * This leaves the global locale in the most recently used operation's, but it
1122  * was locked long enough to get the result.  If that result is static, it
1123  * needs to be copied before the unlock.
1124  *
1125  * Macros could be written like SETUP_LOCALE_DEPENDENT_OP(category) that did
1126  * the setup, but are no-ops when not needed, and similarly,
1127  * END_LOCALE_DEPENDENT_OP for the tear-down
1128  *
1129  * But every call to a locale-sensitive function would have to be changed, and
1130  * if a module didn't cooperate by using the mutex, things would break.
1131  *
1132  * This code was abandoned before being completed or tested, and is left as-is
1133 */
1134
1135 #  define do_setlocale_c(cat, locale) locking_setlocale(cat, locale, cat ## _INDEX, TRUE)
1136 #  define do_setlocale_r(cat, locale) locking_setlocale(cat, locale, 0, FALSE)
1137
1138 STATIC char *
1139 S_locking_setlocale(pTHX_
1140                     const int category,
1141                     const char * locale,
1142                     int index,
1143                     const bool is_index_valid
1144                    )
1145 {
1146     /* This function kind of performs a setlocale() on just the current thread;
1147      * thus it is kind of thread-safe.  It does this by keeping a thread-level
1148      * array of the current locales for each category.  Every time a locale is
1149      * switched to, it does the switch globally, but updates the thread's
1150      * array.  A query as to what the current locale is just returns the
1151      * appropriate element from the array, and doesn't actually call the system
1152      * setlocale().  The saving into the array is done in an uninterruptible
1153      * section of code, so is unaffected by whatever any other threads might be
1154      * doing.
1155      *
1156      * All locale-sensitive operations must work by first starting a critical
1157      * section, then switching to the thread's locale as kept by this function,
1158      * and then doing the operation, then ending the critical section.  Thus,
1159      * each gets done in the appropriate locale. simulating thread-safety.
1160      *
1161      * This function takes the same parameters, 'category' and 'locale', that
1162      * the regular setlocale() function does, but it also takes two additional
1163      * ones.  This is because as described earlier.  If we know on input the
1164      * index corresponding to the category into the array where we store the
1165      * current locales, we don't have to calculate it.  If the caller knows at
1166      * compile time what the index is, it it can pass it, setting
1167      * 'is_index_valid' to TRUE; otherwise the index parameter is ignored.
1168      *
1169      */
1170
1171     /* If the input index might be incorrect, calculate the correct one */
1172     if (! is_index_valid) {
1173         unsigned int i;
1174
1175         if (DEBUG_Lv_TEST || debug_initialization) {
1176             PerlIO_printf(Perl_debug_log, "%s:%d: converting category %d to index\n", __FILE__, __LINE__, category);
1177         }
1178
1179         for (i = 0; i <= LC_ALL_INDEX; i++) {
1180             if (category == categories[i]) {
1181                 index = i;
1182                 goto found_index;
1183             }
1184         }
1185
1186         /* Here, we don't know about this category, so can't handle it.
1187          * XXX best we can do is to unsafely set this
1188          * XXX warning */
1189
1190         return my_setlocale(category, locale);
1191
1192       found_index: ;
1193
1194         if (DEBUG_Lv_TEST || debug_initialization) {
1195             PerlIO_printf(Perl_debug_log, "%s:%d: index is 0x%x\n", __FILE__, __LINE__, index);
1196         }
1197     }
1198
1199     /* For a query, just return what's in our records */
1200     if (new_locale == NULL) {
1201         return curlocales[index];
1202     }
1203
1204
1205     /* Otherwise, we need to do the switch, and save the result, all in a
1206      * critical section */
1207
1208     Safefree(curlocales[[index]]);
1209
1210     /* It might be that this is called from an already-locked section of code.
1211      * We would have to detect and skip the LOCK/UNLOCK if so */
1212     LOCALE_LOCK;
1213
1214     curlocales[index] = savepv(my_setlocale(category, new_locale));
1215
1216     if (strEQ(new_locale, "")) {
1217
1218 #ifdef LC_ALL
1219
1220         /* The locale values come from the environment, and may not all be the
1221          * same, so for LC_ALL, we have to update all the others, while the
1222          * mutex is still locked */
1223
1224         if (category == LC_ALL) {
1225             unsigned int i;
1226             for (i = 0; i < LC_ALL_INDEX) {
1227                 curlocales[i] = my_setlocale(categories[i], NULL);
1228             }
1229         }
1230     }
1231
1232 #endif
1233
1234     LOCALE_UNLOCK;
1235
1236     return curlocales[index];
1237 }
1238
1239 #endif
1240
1241 STATIC void
1242 S_set_numeric_radix(pTHX_ const bool use_locale)
1243 {
1244     /* If 'use_locale' is FALSE, set to use a dot for the radix character.  If
1245      * TRUE, use the radix character derived from the current locale */
1246
1247 #if defined(USE_LOCALE_NUMERIC) && (   defined(HAS_LOCALECONV)              \
1248                                     || defined(HAS_NL_LANGINFO))
1249
1250     const char * radix = (use_locale)
1251                          ? my_nl_langinfo(PERL_RADIXCHAR, FALSE)
1252                                         /* FALSE => already in dest locale */
1253                          : ".";
1254
1255         sv_setpv(PL_numeric_radix_sv, radix);
1256
1257     /* If this is valid UTF-8 that isn't totally ASCII, and we are in
1258         * a UTF-8 locale, then mark the radix as being in UTF-8 */
1259     if (is_utf8_non_invariant_string((U8 *) SvPVX(PL_numeric_radix_sv),
1260                                             SvCUR(PL_numeric_radix_sv))
1261         && _is_cur_LC_category_utf8(LC_NUMERIC))
1262     {
1263         SvUTF8_on(PL_numeric_radix_sv);
1264     }
1265
1266 #  ifdef DEBUGGING
1267
1268     if (DEBUG_L_TEST || debug_initialization) {
1269         PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
1270                                            SvPVX(PL_numeric_radix_sv),
1271                                            cBOOL(SvUTF8(PL_numeric_radix_sv)));
1272     }
1273
1274 #  endif
1275 #endif /* USE_LOCALE_NUMERIC and can find the radix char */
1276
1277 }
1278
1279 STATIC void
1280 S_new_numeric(pTHX_ const char *newnum)
1281 {
1282
1283 #ifndef USE_LOCALE_NUMERIC
1284
1285     PERL_UNUSED_ARG(newnum);
1286
1287 #else
1288
1289     /* Called after each libc setlocale() call affecting LC_NUMERIC, to tell
1290      * core Perl this and that 'newnum' is the name of the new locale.
1291      * It installs this locale as the current underlying default.
1292      *
1293      * The default locale and the C locale can be toggled between by use of the
1294      * set_numeric_underlying() and set_numeric_standard() functions, which
1295      * should probably not be called directly, but only via macros like
1296      * SET_NUMERIC_STANDARD() in perl.h.
1297      *
1298      * The toggling is necessary mainly so that a non-dot radix decimal point
1299      * character can be output, while allowing internal calculations to use a
1300      * dot.
1301      *
1302      * This sets several interpreter-level variables:
1303      * PL_numeric_name  The underlying locale's name: a copy of 'newnum'
1304      * PL_numeric_underlying  A boolean indicating if the toggled state is such
1305      *                  that the current locale is the program's underlying
1306      *                  locale
1307      * PL_numeric_standard An int indicating if the toggled state is such
1308      *                  that the current locale is the C locale or
1309      *                  indistinguishable from the C locale.  If non-zero, it
1310      *                  is in C; if > 1, it means it may not be toggled away
1311      *                  from C.
1312      * PL_numeric_underlying_is_standard   A bool kept by this function
1313      *                  indicating that the underlying locale and the standard
1314      *                  C locale are indistinguishable for the purposes of
1315      *                  LC_NUMERIC.  This happens when both of the above two
1316      *                  variables are true at the same time.  (Toggling is a
1317      *                  no-op under these circumstances.)  This variable is
1318      *                  used to avoid having to recalculate.
1319      */
1320
1321     char *save_newnum;
1322
1323     if (! newnum) {
1324         Safefree(PL_numeric_name);
1325         PL_numeric_name = NULL;
1326         PL_numeric_standard = TRUE;
1327         PL_numeric_underlying = TRUE;
1328         PL_numeric_underlying_is_standard = TRUE;
1329         return;
1330     }
1331
1332     save_newnum = stdize_locale(savepv(newnum));
1333     PL_numeric_underlying = TRUE;
1334     PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum);
1335
1336     /* If its name isn't C nor POSIX, it could still be indistinguishable from
1337      * them */
1338     if (! PL_numeric_standard) {
1339         PL_numeric_standard = cBOOL(strEQ(".", my_nl_langinfo(PERL_RADIXCHAR,
1340                                             FALSE /* Don't toggle locale */  ))
1341                                  && strEQ("",  my_nl_langinfo(PERL_THOUSEP,
1342                                                               FALSE)));
1343     }
1344
1345     /* Save the new name if it isn't the same as the previous one, if any */
1346     if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) {
1347         Safefree(PL_numeric_name);
1348         PL_numeric_name = save_newnum;
1349     }
1350     else {
1351         Safefree(save_newnum);
1352     }
1353
1354     PL_numeric_underlying_is_standard = PL_numeric_standard;
1355
1356 #  ifdef HAS_POSIX_2008_LOCALE
1357
1358     PL_underlying_numeric_obj = newlocale(LC_NUMERIC_MASK,
1359                                           PL_numeric_name,
1360                                           PL_underlying_numeric_obj);
1361
1362 #endif
1363
1364     if (DEBUG_L_TEST || debug_initialization) {
1365         PerlIO_printf(Perl_debug_log, "Called new_numeric with %s, PL_numeric_name=%s\n", newnum, PL_numeric_name);
1366     }
1367
1368     /* Keep LC_NUMERIC in the C locale.  This is for XS modules, so they don't
1369      * have to worry about the radix being a non-dot.  (Core operations that
1370      * need the underlying locale change to it temporarily). */
1371     if (PL_numeric_standard) {
1372         set_numeric_radix(0);
1373     }
1374     else {
1375         set_numeric_standard();
1376     }
1377
1378 #endif /* USE_LOCALE_NUMERIC */
1379
1380 }
1381
1382 void
1383 Perl_set_numeric_standard(pTHX)
1384 {
1385
1386 #ifdef USE_LOCALE_NUMERIC
1387
1388     /* Toggle the LC_NUMERIC locale to C.  Most code should use the macros like
1389      * SET_NUMERIC_STANDARD() in perl.h instead of calling this directly.  The
1390      * macro avoids calling this routine if toggling isn't necessary according
1391      * to our records (which could be wrong if some XS code has changed the
1392      * locale behind our back) */
1393
1394     do_setlocale_c(LC_NUMERIC, "C");
1395     PL_numeric_standard = TRUE;
1396     PL_numeric_underlying = PL_numeric_underlying_is_standard;
1397     set_numeric_radix(0);
1398
1399 #  ifdef DEBUGGING
1400
1401     if (DEBUG_L_TEST || debug_initialization) {
1402         PerlIO_printf(Perl_debug_log,
1403                           "LC_NUMERIC locale now is standard C\n");
1404     }
1405
1406 #  endif
1407 #endif /* USE_LOCALE_NUMERIC */
1408
1409 }
1410
1411 void
1412 Perl_set_numeric_underlying(pTHX)
1413 {
1414
1415 #ifdef USE_LOCALE_NUMERIC
1416
1417     /* Toggle the LC_NUMERIC locale to the current underlying default.  Most
1418      * code should use the macros like SET_NUMERIC_UNDERLYING() in perl.h
1419      * instead of calling this directly.  The macro avoids calling this routine
1420      * if toggling isn't necessary according to our records (which could be
1421      * wrong if some XS code has changed the locale behind our back) */
1422
1423     do_setlocale_c(LC_NUMERIC, PL_numeric_name);
1424     PL_numeric_standard = PL_numeric_underlying_is_standard;
1425     PL_numeric_underlying = TRUE;
1426     set_numeric_radix(! PL_numeric_standard);
1427
1428 #  ifdef DEBUGGING
1429
1430     if (DEBUG_L_TEST || debug_initialization) {
1431         PerlIO_printf(Perl_debug_log,
1432                           "LC_NUMERIC locale now is %s\n",
1433                           PL_numeric_name);
1434     }
1435
1436 #  endif
1437 #endif /* USE_LOCALE_NUMERIC */
1438
1439 }
1440
1441 /*
1442  * Set up for a new ctype locale.
1443  */
1444 STATIC void
1445 S_new_ctype(pTHX_ const char *newctype)
1446 {
1447
1448 #ifndef USE_LOCALE_CTYPE
1449
1450     PERL_ARGS_ASSERT_NEW_CTYPE;
1451     PERL_UNUSED_ARG(newctype);
1452     PERL_UNUSED_CONTEXT;
1453
1454 #else
1455
1456     /* Called after each libc setlocale() call affecting LC_CTYPE, to tell
1457      * core Perl this and that 'newctype' is the name of the new locale.
1458      *
1459      * This function sets up the folding arrays for all 256 bytes, assuming
1460      * that tofold() is tolc() since fold case is not a concept in POSIX,
1461      *
1462      * Any code changing the locale (outside this file) should use
1463      * Perl_setlocale or POSIX::setlocale, which call this function.  Therefore
1464      * this function should be called directly only from this file and from
1465      * POSIX::setlocale() */
1466
1467     dVAR;
1468     unsigned int i;
1469
1470     /* Don't check for problems if we are suppressing the warnings */
1471     bool check_for_problems = ckWARN_d(WARN_LOCALE) || UNLIKELY(DEBUG_L_TEST);
1472
1473     PERL_ARGS_ASSERT_NEW_CTYPE;
1474
1475     /* We will replace any bad locale warning with 1) nothing if the new one is
1476      * ok; or 2) a new warning for the bad new locale */
1477     if (PL_warn_locale) {
1478         SvREFCNT_dec_NN(PL_warn_locale);
1479         PL_warn_locale = NULL;
1480     }
1481
1482     PL_in_utf8_CTYPE_locale = _is_cur_LC_category_utf8(LC_CTYPE);
1483
1484     /* A UTF-8 locale gets standard rules.  But note that code still has to
1485      * handle this specially because of the three problematic code points */
1486     if (PL_in_utf8_CTYPE_locale) {
1487         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
1488     }
1489
1490     /* We don't populate the other lists if a UTF-8 locale, but do check that
1491      * everything works as expected, unless checking turned off */
1492     if (check_for_problems || ! PL_in_utf8_CTYPE_locale) {
1493         /* Assume enough space for every character being bad.  4 spaces each
1494          * for the 94 printable characters that are output like "'x' "; and 5
1495          * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
1496          * NUL */
1497         char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ] = { '\0' };
1498         bool multi_byte_locale = FALSE;     /* Assume is a single-byte locale
1499                                                to start */
1500         unsigned int bad_count = 0;         /* Count of bad characters */
1501
1502         for (i = 0; i < 256; i++) {
1503             if (! PL_in_utf8_CTYPE_locale) {
1504                 if (isupper(i))
1505                     PL_fold_locale[i] = (U8) tolower(i);
1506                 else if (islower(i))
1507                     PL_fold_locale[i] = (U8) toupper(i);
1508                 else
1509                     PL_fold_locale[i] = (U8) i;
1510             }
1511
1512             /* If checking for locale problems, see if the native ASCII-range
1513              * printables plus \n and \t are in their expected categories in
1514              * the new locale.  If not, this could mean big trouble, upending
1515              * Perl's and most programs' assumptions, like having a
1516              * metacharacter with special meaning become a \w.  Fortunately,
1517              * it's very rare to find locales that aren't supersets of ASCII
1518              * nowadays.  It isn't a problem for most controls to be changed
1519              * into something else; we check only \n and \t, though perhaps \r
1520              * could be an issue as well. */
1521             if (    check_for_problems
1522                 && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
1523             {
1524                 bool is_bad = FALSE;
1525                 char name[3] = { '\0' };
1526
1527                 /* Convert the name into a string */
1528                 if (isPRINT_A(i)) {
1529                     name[0] = i;
1530                     name[1] = '\0';
1531                 }
1532                 else if (i == '\n') {
1533                     my_strlcpy(name, "\n", sizeof(name));
1534                 }
1535                 else {
1536                     my_strlcpy(name, "\t", sizeof(name));
1537                 }
1538
1539                 /* Check each possibe class */
1540                 if (UNLIKELY(cBOOL(isalnum(i)) != cBOOL(isALPHANUMERIC_A(i))))  {
1541                     is_bad = TRUE;
1542                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1543                                           "isalnum('%s') unexpectedly is %d\n",
1544                                           name, cBOOL(isalnum(i))));
1545                 }
1546                 if (UNLIKELY(cBOOL(isalpha(i)) != cBOOL(isALPHA_A(i))))  {
1547                     is_bad = TRUE;
1548                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1549                                           "isalpha('%s') unexpectedly is %d\n",
1550                                           name, cBOOL(isalpha(i))));
1551                 }
1552                 if (UNLIKELY(cBOOL(isdigit(i)) != cBOOL(isDIGIT_A(i))))  {
1553                     is_bad = TRUE;
1554                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1555                                           "isdigit('%s') unexpectedly is %d\n",
1556                                           name, cBOOL(isdigit(i))));
1557                 }
1558                 if (UNLIKELY(cBOOL(isgraph(i)) != cBOOL(isGRAPH_A(i))))  {
1559                     is_bad = TRUE;
1560                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1561                                           "isgraph('%s') unexpectedly is %d\n",
1562                                           name, cBOOL(isgraph(i))));
1563                 }
1564                 if (UNLIKELY(cBOOL(islower(i)) != cBOOL(isLOWER_A(i))))  {
1565                     is_bad = TRUE;
1566                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1567                                           "islower('%s') unexpectedly is %d\n",
1568                                           name, cBOOL(islower(i))));
1569                 }
1570                 if (UNLIKELY(cBOOL(isprint(i)) != cBOOL(isPRINT_A(i))))  {
1571                     is_bad = TRUE;
1572                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1573                                           "isprint('%s') unexpectedly is %d\n",
1574                                           name, cBOOL(isprint(i))));
1575                 }
1576                 if (UNLIKELY(cBOOL(ispunct(i)) != cBOOL(isPUNCT_A(i))))  {
1577                     is_bad = TRUE;
1578                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1579                                           "ispunct('%s') unexpectedly is %d\n",
1580                                           name, cBOOL(ispunct(i))));
1581                 }
1582                 if (UNLIKELY(cBOOL(isspace(i)) != cBOOL(isSPACE_A(i))))  {
1583                     is_bad = TRUE;
1584                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1585                                           "isspace('%s') unexpectedly is %d\n",
1586                                           name, cBOOL(isspace(i))));
1587                 }
1588                 if (UNLIKELY(cBOOL(isupper(i)) != cBOOL(isUPPER_A(i))))  {
1589                     is_bad = TRUE;
1590                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1591                                           "isupper('%s') unexpectedly is %d\n",
1592                                           name, cBOOL(isupper(i))));
1593                 }
1594                 if (UNLIKELY(cBOOL(isxdigit(i))!= cBOOL(isXDIGIT_A(i))))  {
1595                     is_bad = TRUE;
1596                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1597                                           "isxdigit('%s') unexpectedly is %d\n",
1598                                           name, cBOOL(isxdigit(i))));
1599                 }
1600                 if (UNLIKELY(tolower(i) != (int) toLOWER_A(i)))  {
1601                     is_bad = TRUE;
1602                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1603                             "tolower('%s')=0x%x instead of the expected 0x%x\n",
1604                             name, tolower(i), (int) toLOWER_A(i)));
1605                 }
1606                 if (UNLIKELY(toupper(i) != (int) toUPPER_A(i)))  {
1607                     is_bad = TRUE;
1608                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1609                             "toupper('%s')=0x%x instead of the expected 0x%x\n",
1610                             name, toupper(i), (int) toUPPER_A(i)));
1611                 }
1612                 if (UNLIKELY((i == '\n' && ! isCNTRL_LC(i))))  {
1613                     is_bad = TRUE;
1614                     DEBUG_L(PerlIO_printf(Perl_debug_log,
1615                                 "'\\n' (=%02X) is not a control\n", (int) i));
1616                 }
1617
1618                 /* Add to the list;  Separate multiple entries with a blank */
1619                 if (is_bad) {
1620                     if (bad_count) {
1621                         my_strlcat(bad_chars_list, " ", sizeof(bad_chars_list));
1622                     }
1623                     my_strlcat(bad_chars_list, name, sizeof(bad_chars_list));
1624                     bad_count++;
1625                 }
1626             }
1627         }
1628
1629 #  ifdef MB_CUR_MAX
1630
1631         /* We only handle single-byte locales (outside of UTF-8 ones; so if
1632          * this locale requires more than one byte, there are going to be
1633          * problems. */
1634         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1635                  "%s:%d: check_for_problems=%d, MB_CUR_MAX=%d\n",
1636                  __FILE__, __LINE__, check_for_problems, (int) MB_CUR_MAX));
1637
1638         if (   check_for_problems && MB_CUR_MAX > 1
1639             && ! PL_in_utf8_CTYPE_locale
1640
1641                /* Some platforms return MB_CUR_MAX > 1 for even the "C"
1642                 * locale.  Just assume that the implementation for them (plus
1643                 * for POSIX) is correct and the > 1 value is spurious.  (Since
1644                 * these are specially handled to never be considered UTF-8
1645                 * locales, as long as this is the only problem, everything
1646                 * should work fine */
1647             && strNE(newctype, "C") && strNE(newctype, "POSIX"))
1648         {
1649             multi_byte_locale = TRUE;
1650         }
1651
1652 #  endif
1653
1654         if (UNLIKELY(bad_count) || UNLIKELY(multi_byte_locale)) {
1655             if (UNLIKELY(bad_count) && PL_in_utf8_CTYPE_locale) {
1656                 PL_warn_locale = Perl_newSVpvf(aTHX_
1657                      "Locale '%s' contains (at least) the following characters"
1658                      " which have\nunexpected meanings: %s\nThe Perl program"
1659                      " will use the expected meanings",
1660                       newctype, bad_chars_list);
1661             }
1662             else {
1663                 PL_warn_locale = Perl_newSVpvf(aTHX_
1664                              "Locale '%s' may not work well.%s%s%s\n",
1665                              newctype,
1666                              (multi_byte_locale)
1667                               ? "  Some characters in it are not recognized by"
1668                                 " Perl."
1669                               : "",
1670                              (bad_count)
1671                               ? "\nThe following characters (and maybe others)"
1672                                 " may not have the same meaning as the Perl"
1673                                 " program expects:\n"
1674                               : "",
1675                              (bad_count)
1676                               ? bad_chars_list
1677                               : ""
1678                             );
1679             }
1680
1681 #  ifdef HAS_NL_LANGINFO
1682
1683             Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
1684                                     /* parameter FALSE is a don't care here */
1685                                     my_nl_langinfo(PERL_CODESET, FALSE));
1686
1687 #  endif
1688
1689             Perl_sv_catpvf(aTHX_ PL_warn_locale, "\n");
1690
1691             /* If we are actually in the scope of the locale or are debugging,
1692              * output the message now.  If not in that scope, we save the
1693              * message to be output at the first operation using this locale,
1694              * if that actually happens.  Most programs don't use locales, so
1695              * they are immune to bad ones.  */
1696             if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
1697
1698                 /* The '0' below suppresses a bogus gcc compiler warning */
1699                 Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale), 0);
1700
1701                 if (IN_LC(LC_CTYPE)) {
1702                     SvREFCNT_dec_NN(PL_warn_locale);
1703                     PL_warn_locale = NULL;
1704                 }
1705             }
1706         }
1707     }
1708
1709 #endif /* USE_LOCALE_CTYPE */
1710
1711 }
1712
1713 void
1714 Perl__warn_problematic_locale()
1715 {
1716
1717 #ifdef USE_LOCALE_CTYPE
1718
1719     dTHX;
1720
1721     /* Internal-to-core function that outputs the message in PL_warn_locale,
1722      * and then NULLS it.  Should be called only through the macro
1723      * _CHECK_AND_WARN_PROBLEMATIC_LOCALE */
1724
1725     if (PL_warn_locale) {
1726         Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
1727                              SvPVX(PL_warn_locale),
1728                              0 /* dummy to avoid compiler warning */ );
1729         SvREFCNT_dec_NN(PL_warn_locale);
1730         PL_warn_locale = NULL;
1731     }
1732
1733 #endif
1734
1735 }
1736
1737 STATIC void
1738 S_new_collate(pTHX_ const char *newcoll)
1739 {
1740
1741 #ifndef USE_LOCALE_COLLATE
1742
1743     PERL_UNUSED_ARG(newcoll);
1744     PERL_UNUSED_CONTEXT;
1745
1746 #else
1747
1748     /* Called after each libc setlocale() call affecting LC_COLLATE, to tell
1749      * core Perl this and that 'newcoll' is the name of the new locale.
1750      *
1751      * The design of locale collation is that every locale change is given an
1752      * index 'PL_collation_ix'.  The first time a string particpates in an
1753      * operation that requires collation while locale collation is active, it
1754      * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()).  That
1755      * magic includes the collation index, and the transformation of the string
1756      * by strxfrm(), q.v.  That transformation is used when doing comparisons,
1757      * instead of the string itself.  If a string changes, the magic is
1758      * cleared.  The next time the locale changes, the index is incremented,
1759      * and so we know during a comparison that the transformation is not
1760      * necessarily still valid, and so is recomputed.  Note that if the locale
1761      * changes enough times, the index could wrap (a U32), and it is possible
1762      * that a transformation would improperly be considered valid, leading to
1763      * an unlikely bug */
1764
1765     if (! newcoll) {
1766         if (PL_collation_name) {
1767             ++PL_collation_ix;
1768             Safefree(PL_collation_name);
1769             PL_collation_name = NULL;
1770         }
1771         PL_collation_standard = TRUE;
1772       is_standard_collation:
1773         PL_collxfrm_base = 0;
1774         PL_collxfrm_mult = 2;
1775         PL_in_utf8_COLLATE_locale = FALSE;
1776         PL_strxfrm_NUL_replacement = '\0';
1777         PL_strxfrm_max_cp = 0;
1778         return;
1779     }
1780
1781     /* If this is not the same locale as currently, set the new one up */
1782     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
1783         ++PL_collation_ix;
1784         Safefree(PL_collation_name);
1785         PL_collation_name = stdize_locale(savepv(newcoll));
1786         PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
1787         if (PL_collation_standard) {
1788             goto is_standard_collation;
1789         }
1790
1791         PL_in_utf8_COLLATE_locale = _is_cur_LC_category_utf8(LC_COLLATE);
1792         PL_strxfrm_NUL_replacement = '\0';
1793         PL_strxfrm_max_cp = 0;
1794
1795         /* A locale collation definition includes primary, secondary, tertiary,
1796          * etc. weights for each character.  To sort, the primary weights are
1797          * used, and only if they compare equal, then the secondary weights are
1798          * used, and only if they compare equal, then the tertiary, etc.
1799          *
1800          * strxfrm() works by taking the input string, say ABC, and creating an
1801          * output transformed string consisting of first the primary weights,
1802          * A¹B¹C¹ followed by the secondary ones, A²B²C²; and then the
1803          * tertiary, etc, yielding A¹B¹C¹ A²B²C² A³B³C³ ....  Some characters
1804          * may not have weights at every level.  In our example, let's say B
1805          * doesn't have a tertiary weight, and A doesn't have a secondary
1806          * weight.  The constructed string is then going to be
1807          *  A¹B¹C¹ B²C² A³C³ ....
1808          * This has the desired effect that strcmp() will look at the secondary
1809          * or tertiary weights only if the strings compare equal at all higher
1810          * priority weights.  The spaces shown here, like in
1811          *  "A¹B¹C¹ A²B²C² "
1812          * are not just for readability.  In the general case, these must
1813          * actually be bytes, which we will call here 'separator weights'; and
1814          * they must be smaller than any other weight value, but since these
1815          * are C strings, only the terminating one can be a NUL (some
1816          * implementations may include a non-NUL separator weight just before
1817          * the NUL).  Implementations tend to reserve 01 for the separator
1818          * weights.  They are needed so that a shorter string's secondary
1819          * weights won't be misconstrued as primary weights of a longer string,
1820          * etc.  By making them smaller than any other weight, the shorter
1821          * string will sort first.  (Actually, if all secondary weights are
1822          * smaller than all primary ones, there is no need for a separator
1823          * weight between those two levels, etc.)
1824          *
1825          * The length of the transformed string is roughly a linear function of
1826          * the input string.  It's not exactly linear because some characters
1827          * don't have weights at all levels.  When we call strxfrm() we have to
1828          * allocate some memory to hold the transformed string.  The
1829          * calculations below try to find coefficients 'm' and 'b' for this
1830          * locale so that m*x + b equals how much space we need, given the size
1831          * of the input string in 'x'.  If we calculate too small, we increase
1832          * the size as needed, and call strxfrm() again, but it is better to
1833          * get it right the first time to avoid wasted expensive string
1834          * transformations. */
1835
1836         {
1837             /* We use the string below to find how long the tranformation of it
1838              * is.  Almost all locales are supersets of ASCII, or at least the
1839              * ASCII letters.  We use all of them, half upper half lower,
1840              * because if we used fewer, we might hit just the ones that are
1841              * outliers in a particular locale.  Most of the strings being
1842              * collated will contain a preponderance of letters, and even if
1843              * they are above-ASCII, they are likely to have the same number of
1844              * weight levels as the ASCII ones.  It turns out that digits tend
1845              * to have fewer levels, and some punctuation has more, but those
1846              * are relatively sparse in text, and khw believes this gives a
1847              * reasonable result, but it could be changed if experience so
1848              * dictates. */
1849             const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
1850             char * x_longer;        /* Transformed 'longer' */
1851             Size_t x_len_longer;    /* Length of 'x_longer' */
1852
1853             char * x_shorter;   /* We also transform a substring of 'longer' */
1854             Size_t x_len_shorter;
1855
1856             /* _mem_collxfrm() is used get the transformation (though here we
1857              * are interested only in its length).  It is used because it has
1858              * the intelligence to handle all cases, but to work, it needs some
1859              * values of 'm' and 'b' to get it started.  For the purposes of
1860              * this calculation we use a very conservative estimate of 'm' and
1861              * 'b'.  This assumes a weight can be multiple bytes, enough to
1862              * hold any UV on the platform, and there are 5 levels, 4 weight
1863              * bytes, and a trailing NUL.  */
1864             PL_collxfrm_base = 5;
1865             PL_collxfrm_mult = 5 * sizeof(UV);
1866
1867             /* Find out how long the transformation really is */
1868             x_longer = _mem_collxfrm(longer,
1869                                      sizeof(longer) - 1,
1870                                      &x_len_longer,
1871
1872                                      /* We avoid converting to UTF-8 in the
1873                                       * called function by telling it the
1874                                       * string is in UTF-8 if the locale is a
1875                                       * UTF-8 one.  Since the string passed
1876                                       * here is invariant under UTF-8, we can
1877                                       * claim it's UTF-8 even though it isn't.
1878                                       * */
1879                                      PL_in_utf8_COLLATE_locale);
1880             Safefree(x_longer);
1881
1882             /* Find out how long the transformation of a substring of 'longer'
1883              * is.  Together the lengths of these transformations are
1884              * sufficient to calculate 'm' and 'b'.  The substring is all of
1885              * 'longer' except the first character.  This minimizes the chances
1886              * of being swayed by outliers */
1887             x_shorter = _mem_collxfrm(longer + 1,
1888                                       sizeof(longer) - 2,
1889                                       &x_len_shorter,
1890                                       PL_in_utf8_COLLATE_locale);
1891             Safefree(x_shorter);
1892
1893             /* If the results are nonsensical for this simple test, the whole
1894              * locale definition is suspect.  Mark it so that locale collation
1895              * is not active at all for it.  XXX Should we warn? */
1896             if (   x_len_shorter == 0
1897                 || x_len_longer == 0
1898                 || x_len_shorter >= x_len_longer)
1899             {
1900                 PL_collxfrm_mult = 0;
1901                 PL_collxfrm_base = 0;
1902             }
1903             else {
1904                 SSize_t base;       /* Temporary */
1905
1906                 /* We have both:    m * strlen(longer)  + b = x_len_longer
1907                  *                  m * strlen(shorter) + b = x_len_shorter;
1908                  * subtracting yields:
1909                  *          m * (strlen(longer) - strlen(shorter))
1910                  *                             = x_len_longer - x_len_shorter
1911                  * But we have set things up so that 'shorter' is 1 byte smaller
1912                  * than 'longer'.  Hence:
1913                  *          m = x_len_longer - x_len_shorter
1914                  *
1915                  * But if something went wrong, make sure the multiplier is at
1916                  * least 1.
1917                  */
1918                 if (x_len_longer > x_len_shorter) {
1919                     PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
1920                 }
1921                 else {
1922                     PL_collxfrm_mult = 1;
1923                 }
1924
1925                 /*     mx + b = len
1926                  * so:      b = len - mx
1927                  * but in case something has gone wrong, make sure it is
1928                  * non-negative */
1929                 base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
1930                 if (base < 0) {
1931                     base = 0;
1932                 }
1933
1934                 /* Add 1 for the trailing NUL */
1935                 PL_collxfrm_base = base + 1;
1936             }
1937
1938 #  ifdef DEBUGGING
1939
1940             if (DEBUG_L_TEST || debug_initialization) {
1941                 PerlIO_printf(Perl_debug_log,
1942                     "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, "
1943                     "x_len_longer=%zu,"
1944                     " collate multipler=%zu, collate base=%zu\n",
1945                     __FILE__, __LINE__,
1946                     PL_in_utf8_COLLATE_locale,
1947                     x_len_shorter, x_len_longer,
1948                     PL_collxfrm_mult, PL_collxfrm_base);
1949             }
1950 #  endif
1951
1952         }
1953     }
1954
1955 #endif /* USE_LOCALE_COLLATE */
1956
1957 }
1958
1959 #ifdef WIN32
1960
1961 STATIC char *
1962 S_win32_setlocale(pTHX_ int category, const char* locale)
1963 {
1964     /* This, for Windows, emulates POSIX setlocale() behavior.  There is no
1965      * difference between the two unless the input locale is "", which normally
1966      * means on Windows to get the machine default, which is set via the
1967      * computer's "Regional and Language Options" (or its current equivalent).
1968      * In POSIX, it instead means to find the locale from the user's
1969      * environment.  This routine changes the Windows behavior to first look in
1970      * the environment, and, if anything is found, use that instead of going to
1971      * the machine default.  If there is no environment override, the machine
1972      * default is used, by calling the real setlocale() with "".
1973      *
1974      * The POSIX behavior is to use the LC_ALL variable if set; otherwise to
1975      * use the particular category's variable if set; otherwise to use the LANG
1976      * variable. */
1977
1978     bool override_LC_ALL = FALSE;
1979     char * result;
1980     unsigned int i;
1981
1982     if (locale && strEQ(locale, "")) {
1983
1984 #  ifdef LC_ALL
1985
1986         locale = PerlEnv_getenv("LC_ALL");
1987         if (! locale) {
1988             if (category ==  LC_ALL) {
1989                 override_LC_ALL = TRUE;
1990             }
1991             else {
1992
1993 #  endif
1994
1995                 for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
1996                     if (category == categories[i]) {
1997                         locale = PerlEnv_getenv(category_names[i]);
1998                         goto found_locale;
1999                     }
2000                 }
2001
2002                 locale = PerlEnv_getenv("LANG");
2003                 if (! locale) {
2004                     locale = "";
2005                 }
2006
2007               found_locale: ;
2008
2009 #  ifdef LC_ALL
2010
2011             }
2012         }
2013
2014 #  endif
2015
2016     }
2017
2018     result = setlocale(category, locale);
2019     DEBUG_L(STMT_START {
2020                 dSAVE_ERRNO;
2021                 PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
2022                             setlocale_debug_string(category, locale, result));
2023                 RESTORE_ERRNO;
2024             } STMT_END);
2025
2026     if (! override_LC_ALL)  {
2027         return result;
2028     }
2029
2030     /* Here the input category was LC_ALL, and we have set it to what is in the
2031      * LANG variable or the system default if there is no LANG.  But these have
2032      * lower priority than the other LC_foo variables, so override it for each
2033      * one that is set.  (If they are set to "", it means to use the same thing
2034      * we just set LC_ALL to, so can skip) */
2035
2036     for (i = 0; i < LC_ALL_INDEX; i++) {
2037         result = PerlEnv_getenv(category_names[i]);
2038         if (result && strNE(result, "")) {
2039             setlocale(categories[i], result);
2040             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
2041                 __FILE__, __LINE__,
2042                 setlocale_debug_string(categories[i], result, "not captured")));
2043         }
2044     }
2045
2046     result = setlocale(LC_ALL, NULL);
2047     DEBUG_L(STMT_START {
2048                 dSAVE_ERRNO;
2049                 PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
2050                                __FILE__, __LINE__,
2051                                setlocale_debug_string(LC_ALL, NULL, result));
2052                 RESTORE_ERRNO;
2053             } STMT_END);
2054
2055     return result;
2056 }
2057
2058 #endif
2059
2060 /*
2061
2062 =head1 Locale-related functions and macros
2063
2064 =for apidoc Perl_setlocale
2065
2066 This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
2067 taking the same parameters, and returning the same information, except that it
2068 returns the correct underlying C<LC_NUMERIC> locale, instead of C<C> always, as
2069 perl keeps that locale category as C<C>, changing it briefly during the
2070 operations where the underlying one is required.
2071
2072 Another reason it isn't completely a drop-in replacement is that it is
2073 declared to return S<C<const char *>>, whereas the system setlocale omits the
2074 C<const>.  (If it were being written today, plain setlocale would be declared
2075 const, since it is illegal to change the information it returns; doing so leads
2076 to segfaults.)
2077
2078 Finally, C<Perl_setlocale> works under all circumstances, whereas plain
2079 C<setlocale> can be completely ineffective on some platforms under some
2080 configurations.
2081
2082 C<Perl_setlocale> should not be used to change the locale except on systems
2083 where the predefined variable C<${^SAFE_LOCALES}> is 1.  On some such systems,
2084 the system C<setlocale()> is ineffective, returning the wrong information, and
2085 failing to actually change the locale.  C<Perl_setlocale>, however works
2086 properly in all circumstances.
2087
2088 The return points to a per-thread static buffer, which is overwritten the next
2089 time C<Perl_setlocale> is called from the same thread.
2090
2091 =cut
2092
2093 */
2094
2095 const char *
2096 Perl_setlocale(const int category, const char * locale)
2097 {
2098     /* This wraps POSIX::setlocale() */
2099
2100     const char * retval;
2101     const char * newlocale;
2102     dSAVEDERRNO;
2103     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2104     dTHX;
2105
2106 #ifdef USE_LOCALE_NUMERIC
2107
2108     /* A NULL locale means only query what the current one is.  We have the
2109      * LC_NUMERIC name saved, because we are normally switched into the C
2110      * locale for it.  For an LC_ALL query, switch back to get the correct
2111      * results.  All other categories don't require special handling */
2112     if (locale == NULL) {
2113         if (category == LC_NUMERIC) {
2114
2115             /* We don't have to copy this return value, as it is a per-thread
2116              * variable, and won't change until a future setlocale */
2117             return PL_numeric_name;
2118         }
2119
2120 #  ifdef LC_ALL
2121
2122         else if (category == LC_ALL) {
2123             STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2124         }
2125
2126 #  endif
2127
2128     }
2129
2130 #endif
2131
2132     retval = save_to_buffer(do_setlocale_r(category, locale),
2133                             &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
2134     SAVE_ERRNO;
2135
2136 #if defined(USE_LOCALE_NUMERIC) && defined(LC_ALL)
2137
2138     if (locale == NULL && category == LC_ALL) {
2139         RESTORE_LC_NUMERIC();
2140     }
2141
2142 #endif
2143
2144     DEBUG_L(PerlIO_printf(Perl_debug_log,
2145         "%s:%d: %s\n", __FILE__, __LINE__,
2146             setlocale_debug_string(category, locale, retval)));
2147
2148     RESTORE_ERRNO;
2149
2150     if (! retval) {
2151         return NULL;
2152     }
2153
2154     /* If locale == NULL, we are just querying the state */
2155     if (locale == NULL) {
2156         return retval;
2157     }
2158
2159     /* Now that have switched locales, we have to update our records to
2160      * correspond. */
2161
2162     switch (category) {
2163
2164 #ifdef USE_LOCALE_CTYPE
2165
2166         case LC_CTYPE:
2167             new_ctype(retval);
2168             break;
2169
2170 #endif
2171 #ifdef USE_LOCALE_COLLATE
2172
2173         case LC_COLLATE:
2174             new_collate(retval);
2175             break;
2176
2177 #endif
2178 #ifdef USE_LOCALE_NUMERIC
2179
2180         case LC_NUMERIC:
2181             new_numeric(retval);
2182             break;
2183
2184 #endif
2185 #ifdef LC_ALL
2186
2187         case LC_ALL:
2188
2189             /* LC_ALL updates all the things we care about.  The values may not
2190              * be the same as 'retval', as the locale "" may have set things
2191              * individually */
2192
2193 #  ifdef USE_LOCALE_CTYPE
2194
2195             newlocale = do_setlocale_c(LC_CTYPE, NULL);
2196             new_ctype(newlocale);
2197
2198 #  endif /* USE_LOCALE_CTYPE */
2199 #  ifdef USE_LOCALE_COLLATE
2200
2201             newlocale = do_setlocale_c(LC_COLLATE, NULL);
2202             new_collate(newlocale);
2203
2204 #  endif
2205 #  ifdef USE_LOCALE_NUMERIC
2206
2207             newlocale = do_setlocale_c(LC_NUMERIC, NULL);
2208             new_numeric(newlocale);
2209
2210 #  endif /* USE_LOCALE_NUMERIC */
2211 #endif /* LC_ALL */
2212
2213         default:
2214             break;
2215     }
2216
2217     return retval;
2218
2219 }
2220
2221 PERL_STATIC_INLINE const char *
2222 S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t offset)
2223 {
2224     /* Copy the NUL-terminated 'string' to 'buf' + 'offset'.  'buf' has size 'buf_size',
2225      * growing it if necessary */
2226
2227     Size_t string_size;
2228
2229     PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
2230
2231     if (! string) {
2232         return NULL;
2233     }
2234
2235     string_size = strlen(string) + offset + 1;
2236
2237     if (*buf_size == 0) {
2238         Newx(*buf, string_size, char);
2239         *buf_size = string_size;
2240     }
2241     else if (string_size > *buf_size) {
2242         Renew(*buf, string_size, char);
2243         *buf_size = string_size;
2244     }
2245
2246     Copy(string, *buf + offset, string_size - offset, char);
2247     return *buf;
2248 }
2249
2250 /*
2251
2252 =for apidoc Perl_langinfo
2253
2254 This is an (almost) drop-in replacement for the system C<L<nl_langinfo(3)>>,
2255 taking the same C<item> parameter values, and returning the same information.
2256 But it is more thread-safe than regular C<nl_langinfo()>, and hides the quirks
2257 of Perl's locale handling from your code, and can be used on systems that lack
2258 a native C<nl_langinfo>.
2259
2260 Expanding on these:
2261
2262 =over
2263
2264 =item *
2265
2266 The reason it isn't quite a drop-in replacement is actually an advantage.  The
2267 only difference is that it returns S<C<const char *>>, whereas plain
2268 C<nl_langinfo()> returns S<C<char *>>, but you are (only by documentation)
2269 forbidden to write into the buffer.  By declaring this C<const>, the compiler
2270 enforces this restriction, so if it is violated, you know at compilation time,
2271 rather than getting segfaults at runtime.
2272
2273 =item *
2274
2275 It delivers the correct results for the C<RADIXCHAR> and C<THOUSEP> items,
2276 without you having to write extra code.  The reason for the extra code would be
2277 because these are from the C<LC_NUMERIC> locale category, which is normally
2278 kept set to the C locale by Perl, no matter what the underlying locale is
2279 supposed to be, and so to get the expected results, you have to temporarily
2280 toggle into the underlying locale, and later toggle back.  (You could use plain
2281 C<nl_langinfo> and C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this but
2282 then you wouldn't get the other advantages of C<Perl_langinfo()>; not keeping
2283 C<LC_NUMERIC> in the C locale would break a lot of CPAN, which is expecting the
2284 radix (decimal point) character to be a dot.)
2285
2286 =item *
2287
2288 The system function it replaces can have its static return buffer trashed,
2289 not only by a subesequent call to that function, but by a C<freelocale>,
2290 C<setlocale>, or other locale change.  The returned buffer of this function is
2291 not changed until the next call to it, so the buffer is never in a trashed
2292 state.
2293
2294 =item *
2295
2296 Its return buffer is per-thread, so it also is never overwritten by a call to
2297 this function from another thread;  unlike the function it replaces.
2298
2299 =item *
2300
2301 But most importantly, it works on systems that don't have C<nl_langinfo>, such
2302 as Windows, hence makes your code more portable.  Of the fifty-some possible
2303 items specified by the POSIX 2008 standard,
2304 L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
2305 only two are completely unimplemented (though the loss of one of these is
2306 significant).  It uses various techniques to recover the other items, including
2307 calling C<L<localeconv(3)>>, and C<L<strftime(3)>>, both of which are specified
2308 in C89, so should be always be available.  Later C<strftime()> versions have
2309 additional capabilities; C<""> is returned for those not available on your
2310 system.
2311
2312 It is important to note that when called with an item that is recovered by
2313 using C<localeconv>, the buffer from any previous explicit call to
2314 C<localeconv> will be overwritten.  This means you must save that buffer's
2315 contents if you need to access them after a call to this function.
2316
2317 The details for those items which may differ from what this emulation returns
2318 and what a native C<nl_langinfo()> would return are:
2319
2320 =over
2321
2322 =item C<CODESET>
2323
2324 =item C<ERA>
2325
2326 Unimplemented, so returns C<"">.
2327
2328 =item C<YESEXPR>
2329
2330 =item C<YESSTR>
2331
2332 =item C<NOEXPR>
2333
2334 =item C<NOSTR>
2335
2336 Only the values for English are returned.  C<YESSTR> and C<NOSTR> have been
2337 removed from POSIX 2008, and are retained here for backwards compatibility.
2338 Your platform's C<nl_langinfo> may not support them.
2339
2340 =item C<D_FMT>
2341
2342 Always evaluates to C<%x>, the locale's appropriate date representation.
2343
2344 =item C<T_FMT>
2345
2346 Always evaluates to C<%X>, the locale's appropriate time representation.
2347
2348 =item C<D_T_FMT>
2349
2350 Always evaluates to C<%c>, the locale's appropriate date and time
2351 representation.
2352
2353 =item C<CRNCYSTR>
2354
2355 The return may be incorrect for those rare locales where the currency symbol
2356 replaces the radix character.
2357 Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
2358 to work differently.
2359
2360 =item C<ALT_DIGITS>
2361
2362 Currently this gives the same results as Linux does.
2363 Send email to L<mailto:perlbug@perl.org> if you have examples of it needing
2364 to work differently.
2365
2366 =item C<ERA_D_FMT>
2367
2368 =item C<ERA_T_FMT>
2369
2370 =item C<ERA_D_T_FMT>
2371
2372 =item C<T_FMT_AMPM>
2373
2374 These are derived by using C<strftime()>, and not all versions of that function
2375 know about them.  C<""> is returned for these on such systems.
2376
2377 =back
2378
2379 =back
2380
2381 When using C<Perl_langinfo> on systems that don't have a native
2382 C<nl_langinfo()>, you must
2383
2384  #include "perl_langinfo.h"
2385
2386 before the C<perl.h> C<#include>.  You can replace your C<langinfo.h>
2387 C<#include> with this one.  (Doing it this way keeps out the symbols that plain
2388 C<langinfo.h> imports into the namespace for code that doesn't need it.)
2389
2390 You also should not use the bare C<langinfo.h> item names, but should preface
2391 them with C<PERL_>, so use C<PERL_RADIXCHAR> instead of plain C<RADIXCHAR>.
2392 The C<PERL_I<foo>> versions will also work for this function on systems that do
2393 have a native C<nl_langinfo>.
2394
2395 The original impetus for C<Perl_langinfo()> was so that code that needs to
2396 find out the current currency symbol, floating point radix character, or digit
2397 grouping separator can use, on all systems, the simpler and more
2398 thread-friendly C<nl_langinfo> API instead of C<L<localeconv(3)>> which is a
2399 pain to make thread-friendly.  For other fields returned by C<localeconv>, it
2400 is better to use the methods given in L<perlcall> to call
2401 L<C<POSIX::localeconv()>|POSIX/localeconv>, which is thread-friendly.
2402
2403 =cut
2404
2405 */
2406
2407 const char *
2408 #ifdef HAS_NL_LANGINFO
2409 Perl_langinfo(const nl_item item)
2410 #else
2411 Perl_langinfo(const int item)
2412 #endif
2413 {
2414     return my_nl_langinfo(item, TRUE);
2415 }
2416
2417 const char *
2418 #ifdef HAS_NL_LANGINFO
2419 S_my_nl_langinfo(const nl_item item, bool toggle)
2420 #else
2421 S_my_nl_langinfo(const int item, bool toggle)
2422 #endif
2423 {
2424     dTHX;
2425     const char * retval;
2426
2427     /* We only need to toggle into the underlying LC_NUMERIC locale for these
2428      * two items, and only if not already there */
2429     if (toggle && ((   item != PERL_RADIXCHAR && item != PERL_THOUSEP)
2430                     || PL_numeric_underlying))
2431     {
2432         toggle = FALSE;
2433     }
2434
2435 #if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available.  */
2436 #  if   ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L)      \
2437      || ! defined(HAS_POSIX_2008_LOCALE)
2438
2439     /* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC
2440      * for those items dependent on it.  This must be copied to a buffer before
2441      * switching back, as some systems destroy the buffer when setlocale() is
2442      * called */
2443
2444     {
2445         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2446
2447         if (toggle) {
2448             STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2449         }
2450
2451         LOCALE_LOCK;    /* Prevent interference from another thread executing
2452                            this code section (the only call to nl_langinfo in
2453                            the core) */
2454
2455
2456         /* Copy to a per-thread buffer, which is also one that won't be
2457          * destroyed by a subsequent setlocale(), such as the
2458          * RESTORE_LC_NUMERIC may do just below. */
2459         retval = save_to_buffer(nl_langinfo(item),
2460                                 &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
2461
2462         LOCALE_UNLOCK;
2463
2464         if (toggle) {
2465             RESTORE_LC_NUMERIC();
2466         }
2467     }
2468
2469 #  else /* Use nl_langinfo_l(), avoiding both a mutex and changing the locale */
2470
2471     {
2472         bool do_free = FALSE;
2473         locale_t cur = uselocale((locale_t) 0);
2474
2475         if (cur == LC_GLOBAL_LOCALE) {
2476             cur = duplocale(LC_GLOBAL_LOCALE);
2477             do_free = TRUE;
2478         }
2479
2480         if (toggle) {
2481             if (PL_underlying_numeric_obj) {
2482                 cur = PL_underlying_numeric_obj;
2483             }
2484             else {
2485                 cur = newlocale(LC_NUMERIC_MASK, PL_numeric_name, cur);
2486                 do_free = TRUE;
2487             }
2488         }
2489
2490         /* We have to save it to a buffer, because the freelocale() just below
2491          * can invalidate the internal one */
2492         retval = save_to_buffer(nl_langinfo_l(item, cur),
2493                                 &PL_langinfo_buf, &PL_langinfo_bufsize, 0);
2494
2495         if (do_free) {
2496             freelocale(cur);
2497         }
2498     }
2499
2500 #  endif
2501
2502     if (strEQ(retval, "")) {
2503         if (item == PERL_YESSTR) {
2504             return "yes";
2505         }
2506         if (item == PERL_NOSTR) {
2507             return "no";
2508         }
2509     }
2510
2511     return retval;
2512
2513 #else   /* Below, emulate nl_langinfo as best we can */
2514
2515     {
2516
2517 #  ifdef HAS_LOCALECONV
2518
2519         const struct lconv* lc;
2520         const char * temp;
2521         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2522
2523 #  endif
2524 #  ifdef HAS_STRFTIME
2525
2526         struct tm tm;
2527         bool return_format = FALSE; /* Return the %format, not the value */
2528         const char * format;
2529
2530 #  endif
2531
2532         /* We copy the results to a per-thread buffer, even if not
2533          * multi-threaded.  This is in part to simplify this code, and partly
2534          * because we need a buffer anyway for strftime(), and partly because a
2535          * call of localeconv() could otherwise wipe out the buffer, and the
2536          * programmer would not be expecting this, as this is a nl_langinfo()
2537          * substitute after all, so s/he might be thinking their localeconv()
2538          * is safe until another localeconv() call. */
2539
2540         switch (item) {
2541             Size_t len;
2542
2543             /* These 2 are unimplemented */
2544             case PERL_CODESET:
2545             case PERL_ERA:      /* For use with strftime() %E modifier */
2546
2547             default:
2548                 return "";
2549
2550             /* We use only an English set, since we don't know any more */
2551             case PERL_YESEXPR:   return "^[+1yY]";
2552             case PERL_YESSTR:    return "yes";
2553             case PERL_NOEXPR:    return "^[-0nN]";
2554             case PERL_NOSTR:     return "no";
2555
2556 #  ifdef HAS_LOCALECONV
2557
2558             case PERL_CRNCYSTR:
2559
2560                 /* We don't bother with localeconv_l() because any system that
2561                  * has it is likely to also have nl_langinfo() */
2562
2563                 LOCALE_LOCK;    /* Prevent interference with other threads
2564                                    using localeconv() */
2565
2566                 lc = localeconv();
2567                 if (   ! lc
2568                     || ! lc->currency_symbol
2569                     || strEQ("", lc->currency_symbol))
2570                 {
2571                     LOCALE_UNLOCK;
2572                     return "";
2573                 }
2574
2575                 /* Leave the first spot empty to be filled in below */
2576                 retval = save_to_buffer(lc->currency_symbol, &PL_langinfo_buf,
2577                                         &PL_langinfo_bufsize, 1);
2578                 if (lc->mon_decimal_point && strEQ(lc->mon_decimal_point, ""))
2579                 { /*  khw couldn't figure out how the localedef specifications
2580                       would show that the $ should replace the radix; this is
2581                       just a guess as to how it might work.*/
2582                     PL_langinfo_buf[0] = '.';
2583                 }
2584                 else if (lc->p_cs_precedes) {
2585                     PL_langinfo_buf[0] = '-';
2586                 }
2587                 else {
2588                     PL_langinfo_buf[0] = '+';
2589                 }
2590
2591                 LOCALE_UNLOCK;
2592                 break;
2593
2594             case PERL_RADIXCHAR:
2595             case PERL_THOUSEP:
2596
2597                 if (toggle) {
2598                     STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2599                 }
2600
2601                 LOCALE_LOCK;    /* Prevent interference with other threads
2602                                    using localeconv() */
2603
2604                 lc = localeconv();
2605                 if (! lc) {
2606                     temp = "";
2607                 }
2608                 else {
2609                     temp = (item == PERL_RADIXCHAR)
2610                              ? lc->decimal_point
2611                              : lc->thousands_sep;
2612                     if (! temp) {
2613                         temp = "";
2614                     }
2615                 }
2616
2617                 retval = save_to_buffer(temp, &PL_langinfo_buf,
2618                                         &PL_langinfo_bufsize, 0);
2619
2620                 LOCALE_UNLOCK;
2621
2622                 if (toggle) {
2623                     RESTORE_LC_NUMERIC();
2624                 }
2625
2626                 break;
2627
2628 #  endif
2629 #  ifdef HAS_STRFTIME
2630
2631             /* These are defined by C89, so we assume that strftime supports
2632              * them, and so are returned unconditionally; they may not be what
2633              * the locale actually says, but should give good enough results
2634              * for someone using them as formats (as opposed to trying to parse
2635              * them to figure out what the locale says).  The other format
2636              * items are actually tested to verify they work on the platform */
2637             case PERL_D_FMT:         return "%x";
2638             case PERL_T_FMT:         return "%X";
2639             case PERL_D_T_FMT:       return "%c";
2640
2641             /* These formats are only available in later strfmtime's */
2642             case PERL_ERA_D_FMT: case PERL_ERA_T_FMT: case PERL_ERA_D_T_FMT:
2643             case PERL_T_FMT_AMPM:
2644
2645             /* The rest can be gotten from most versions of strftime(). */
2646             case PERL_ABDAY_1: case PERL_ABDAY_2: case PERL_ABDAY_3:
2647             case PERL_ABDAY_4: case PERL_ABDAY_5: case PERL_ABDAY_6:
2648             case PERL_ABDAY_7:
2649             case PERL_ALT_DIGITS:
2650             case PERL_AM_STR: case PERL_PM_STR:
2651             case PERL_ABMON_1: case PERL_ABMON_2: case PERL_ABMON_3:
2652             case PERL_ABMON_4: case PERL_ABMON_5: case PERL_ABMON_6:
2653             case PERL_ABMON_7: case PERL_ABMON_8: case PERL_ABMON_9:
2654             case PERL_ABMON_10: case PERL_ABMON_11: case PERL_ABMON_12:
2655             case PERL_DAY_1: case PERL_DAY_2: case PERL_DAY_3: case PERL_DAY_4:
2656             case PERL_DAY_5: case PERL_DAY_6: case PERL_DAY_7:
2657             case PERL_MON_1: case PERL_MON_2: case PERL_MON_3: case PERL_MON_4:
2658             case PERL_MON_5: case PERL_MON_6: case PERL_MON_7: case PERL_MON_8:
2659             case PERL_MON_9: case PERL_MON_10: case PERL_MON_11:
2660             case PERL_MON_12:
2661
2662                 LOCALE_LOCK;
2663
2664                 init_tm(&tm);   /* Precaution against core dumps */
2665                 tm.tm_sec = 30;
2666                 tm.tm_min = 30;
2667                 tm.tm_hour = 6;
2668                 tm.tm_year = 2017 - 1900;
2669                 tm.tm_wday = 0;
2670                 tm.tm_mon = 0;
2671                 switch (item) {
2672                     default:
2673                         LOCALE_UNLOCK;
2674                         Perl_croak(aTHX_
2675                                     "panic: %s: %d: switch case: %d problem",
2676                                        __FILE__, __LINE__, item);
2677                         NOT_REACHED; /* NOTREACHED */
2678
2679                     case PERL_PM_STR: tm.tm_hour = 18;
2680                     case PERL_AM_STR:
2681                         format = "%p";
2682                         break;
2683
2684                     case PERL_ABDAY_7: tm.tm_wday++;
2685                     case PERL_ABDAY_6: tm.tm_wday++;
2686                     case PERL_ABDAY_5: tm.tm_wday++;
2687                     case PERL_ABDAY_4: tm.tm_wday++;
2688                     case PERL_ABDAY_3: tm.tm_wday++;
2689                     case PERL_ABDAY_2: tm.tm_wday++;
2690                     case PERL_ABDAY_1:
2691                         format = "%a";
2692                         break;
2693
2694                     case PERL_DAY_7: tm.tm_wday++;
2695                     case PERL_DAY_6: tm.tm_wday++;
2696                     case PERL_DAY_5: tm.tm_wday++;
2697                     case PERL_DAY_4: tm.tm_wday++;
2698                     case PERL_DAY_3: tm.tm_wday++;
2699                     case PERL_DAY_2: tm.tm_wday++;
2700                     case PERL_DAY_1:
2701                         format = "%A";
2702                         break;
2703
2704                     case PERL_ABMON_12: tm.tm_mon++;
2705                     case PERL_ABMON_11: tm.tm_mon++;
2706                     case PERL_ABMON_10: tm.tm_mon++;
2707                     case PERL_ABMON_9: tm.tm_mon++;
2708                     case PERL_ABMON_8: tm.tm_mon++;
2709                     case PERL_ABMON_7: tm.tm_mon++;
2710                     case PERL_ABMON_6: tm.tm_mon++;
2711                     case PERL_ABMON_5: tm.tm_mon++;
2712                     case PERL_ABMON_4: tm.tm_mon++;
2713                     case PERL_ABMON_3: tm.tm_mon++;
2714                     case PERL_ABMON_2: tm.tm_mon++;
2715                     case PERL_ABMON_1:
2716                         format = "%b";
2717                         break;
2718
2719                     case PERL_MON_12: tm.tm_mon++;
2720                     case PERL_MON_11: tm.tm_mon++;
2721                     case PERL_MON_10: tm.tm_mon++;
2722                     case PERL_MON_9: tm.tm_mon++;
2723                     case PERL_MON_8: tm.tm_mon++;
2724                     case PERL_MON_7: tm.tm_mon++;
2725                     case PERL_MON_6: tm.tm_mon++;
2726                     case PERL_MON_5: tm.tm_mon++;
2727                     case PERL_MON_4: tm.tm_mon++;
2728                     case PERL_MON_3: tm.tm_mon++;
2729                     case PERL_MON_2: tm.tm_mon++;
2730                     case PERL_MON_1:
2731                         format = "%B";
2732                         break;
2733
2734                     case PERL_T_FMT_AMPM:
2735                         format = "%r";
2736                         return_format = TRUE;
2737                         break;
2738
2739                     case PERL_ERA_D_FMT:
2740                         format = "%Ex";
2741                         return_format = TRUE;
2742                         break;
2743
2744                     case PERL_ERA_T_FMT:
2745                         format = "%EX";
2746                         return_format = TRUE;
2747                         break;
2748
2749                     case PERL_ERA_D_T_FMT:
2750                         format = "%Ec";
2751                         return_format = TRUE;
2752                         break;
2753
2754                     case PERL_ALT_DIGITS:
2755                         tm.tm_wday = 0;
2756                         format = "%Ow"; /* Find the alternate digit for 0 */
2757                         break;
2758                 }
2759
2760                 /* We can't use my_strftime() because it doesn't look at
2761                  * tm_wday  */
2762                 while (0 == strftime(PL_langinfo_buf, PL_langinfo_bufsize,
2763                                      format, &tm))
2764                 {
2765                     /* A zero return means one of:
2766                      *  a)  there wasn't enough space in PL_langinfo_buf
2767                      *  b)  the format, like a plain %p, returns empty
2768                      *  c)  it was an illegal format, though some
2769                      *      implementations of strftime will just return the
2770                      *      illegal format as a plain character sequence.
2771                      *
2772                      *  To quickly test for case 'b)', try again but precede
2773                      *  the format with a plain character.  If that result is
2774                      *  still empty, the problem is either 'a)' or 'c)' */
2775
2776                     Size_t format_size = strlen(format) + 1;
2777                     Size_t mod_size = format_size + 1;
2778                     char * mod_format;
2779                     char * temp_result;
2780
2781                     Newx(mod_format, mod_size, char);
2782                     Newx(temp_result, PL_langinfo_bufsize, char);
2783                     *mod_format = ' ';
2784                     my_strlcpy(mod_format + 1, format, mod_size);
2785                     len = strftime(temp_result,
2786                                    PL_langinfo_bufsize,
2787                                    mod_format, &tm);
2788                     Safefree(mod_format);
2789                     Safefree(temp_result);
2790
2791                     /* If 'len' is non-zero, it means that we had a case like
2792                      * %p which means the current locale doesn't use a.m. or
2793                      * p.m., and that is valid */
2794                     if (len == 0) {
2795
2796                         /* Here, still didn't work.  If we get well beyond a
2797                          * reasonable size, bail out to prevent an infinite
2798                          * loop. */
2799
2800                         if (PL_langinfo_bufsize > 100 * format_size) {
2801                             *PL_langinfo_buf = '\0';
2802                         }
2803                         else {
2804                             /* Double the buffer size to retry;  Add 1 in case
2805                              * original was 0, so we aren't stuck at 0.  */
2806                             PL_langinfo_bufsize *= 2;
2807                             PL_langinfo_bufsize++;
2808                             Renew(PL_langinfo_buf, PL_langinfo_bufsize, char);
2809                             continue;
2810                         }
2811                     }
2812
2813                     break;
2814                 }
2815
2816                 /* Here, we got a result.
2817                  *
2818                  * If the item is 'ALT_DIGITS', PL_langinfo_buf contains the
2819                  * alternate format for wday 0.  If the value is the same as
2820                  * the normal 0, there isn't an alternate, so clear the buffer.
2821                  * */
2822                 if (   item == PERL_ALT_DIGITS
2823                     && strEQ(PL_langinfo_buf, "0"))
2824                 {
2825                     *PL_langinfo_buf = '\0';
2826                 }
2827
2828                 /* ALT_DIGITS is problematic.  Experiments on it showed that
2829                  * strftime() did not always work properly when going from
2830                  * alt-9 to alt-10.  Only a few locales have this item defined,
2831                  * and in all of them on Linux that khw was able to find,
2832                  * nl_langinfo() merely returned the alt-0 character, possibly
2833                  * doubled.  Most Unicode digits are in blocks of 10
2834                  * consecutive code points, so that is sufficient information
2835                  * for those scripts, as we can infer alt-1, alt-2, ....  But
2836                  * for a Japanese locale, a CJK ideographic 0 is returned, and
2837                  * the CJK digits are not in code point order, so you can't
2838                  * really infer anything.  The localedef for this locale did
2839                  * specify the succeeding digits, so that strftime() works
2840                  * properly on them, without needing to infer anything.  But
2841                  * the nl_langinfo() return did not give sufficient information
2842                  * for the caller to understand what's going on.  So until
2843                  * there is evidence that it should work differently, this
2844                  * returns the alt-0 string for ALT_DIGITS.
2845                  *
2846                  * wday was chosen because its range is all a single digit.
2847                  * Things like tm_sec have two digits as the minimum: '00' */
2848
2849                 LOCALE_UNLOCK;
2850
2851                 retval = PL_langinfo_buf;
2852
2853                 /* If to return the format, not the value, overwrite the buffer
2854                  * with it.  But some strftime()s will keep the original format
2855                  * if illegal, so change those to "" */
2856                 if (return_format) {
2857                     if (strEQ(PL_langinfo_buf, format)) {
2858                         *PL_langinfo_buf = '\0';
2859                     }
2860                     else {
2861                         retval = save_to_buffer(format, &PL_langinfo_buf,
2862                                                 &PL_langinfo_bufsize, 0);
2863                     }
2864                 }
2865
2866                 break;
2867
2868 #  endif
2869
2870         }
2871     }
2872
2873     return retval;
2874
2875 #endif
2876
2877 }
2878
2879 /*
2880  * Initialize locale awareness.
2881  */
2882 int
2883 Perl_init_i18nl10n(pTHX_ int printwarn)
2884 {
2885     /* printwarn is
2886      *
2887      *    0 if not to output warning when setup locale is bad
2888      *    1 if to output warning based on value of PERL_BADLANG
2889      *    >1 if to output regardless of PERL_BADLANG
2890      *
2891      * returns
2892      *    1 = set ok or not applicable,
2893      *    0 = fallback to a locale of lower priority
2894      *   -1 = fallback to all locales failed, not even to the C locale
2895      *
2896      * Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
2897      * set, debugging information is output.
2898      *
2899      * This looks more complicated than it is, mainly due to the #ifdefs.
2900      *
2901      * We try to set LC_ALL to the value determined by the environment.  If
2902      * there is no LC_ALL on this platform, we try the individual categories we
2903      * know about.  If this works, we are done.
2904      *
2905      * But if it doesn't work, we have to do something else.  We search the
2906      * environment variables ourselves instead of relying on the system to do
2907      * it.  We look at, in order, LC_ALL, LANG, a system default locale (if we
2908      * think there is one), and the ultimate fallback "C".  This is all done in
2909      * the same loop as above to avoid duplicating code, but it makes things
2910      * more complex.  The 'trial_locales' array is initialized with just one
2911      * element; it causes the behavior described in the paragraph above this to
2912      * happen.  If that fails, we add elements to 'trial_locales', and do extra
2913      * loop iterations to cause the behavior described in this paragraph.
2914      *
2915      * On Ultrix, the locale MUST come from the environment, so there is
2916      * preliminary code to set it.  I (khw) am not sure that it is necessary,
2917      * and that this couldn't be folded into the loop, but barring any real
2918      * platforms to test on, it's staying as-is
2919      *
2920      * A slight complication is that in embedded Perls, the locale may already
2921      * be set-up, and we don't want to get it from the normal environment
2922      * variables.  This is handled by having a special environment variable
2923      * indicate we're in this situation.  We simply set setlocale's 2nd
2924      * parameter to be a NULL instead of "".  That indicates to setlocale that
2925      * it is not to change anything, but to return the current value,
2926      * effectively initializing perl's db to what the locale already is.
2927      *
2928      * We play the same trick with NULL if a LC_ALL succeeds.  We call
2929      * setlocale() on the individual categores with NULL to get their existing
2930      * values for our db, instead of trying to change them.
2931      * */
2932
2933     int ok = 1;
2934
2935 #ifndef USE_LOCALE
2936
2937     PERL_UNUSED_ARG(printwarn);
2938
2939 #else  /* USE_LOCALE */
2940 #  ifdef __GLIBC__
2941
2942     const char * const language   = savepv(PerlEnv_getenv("LANGUAGE"));
2943
2944 #  endif
2945
2946     /* NULL uses the existing already set up locale */
2947     const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
2948                                         ? NULL
2949                                         : "";
2950     const char* trial_locales[5];   /* 5 = 1 each for "", LC_ALL, LANG, "", C */
2951     unsigned int trial_locales_count;
2952     const char * const lc_all     = savepv(PerlEnv_getenv("LC_ALL"));
2953     const char * const lang       = savepv(PerlEnv_getenv("LANG"));
2954     bool setlocale_failure = FALSE;
2955     unsigned int i;
2956
2957     /* A later getenv() could zap this, so only use here */
2958     const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
2959
2960     const bool locwarn = (printwarn > 1
2961                           || (          printwarn
2962                               && (    ! bad_lang_use_once
2963                                   || (
2964                                          /* disallow with "" or "0" */
2965                                          *bad_lang_use_once
2966                                        && strNE("0", bad_lang_use_once)))));
2967
2968     /* setlocale() return vals; not copied so must be looked at immediately */
2969     const char * sl_result[NOMINAL_LC_ALL_INDEX + 1];
2970
2971     /* current locale for given category; should have been copied so aren't
2972      * volatile */
2973     const char * curlocales[NOMINAL_LC_ALL_INDEX + 1];
2974
2975 #  ifdef WIN32
2976
2977     /* In some systems you can find out the system default locale
2978      * and use that as the fallback locale. */
2979 #    define SYSTEM_DEFAULT_LOCALE
2980 #  endif
2981 #  ifdef SYSTEM_DEFAULT_LOCALE
2982
2983     const char *system_default_locale = NULL;
2984
2985 #  endif
2986
2987 #  ifndef DEBUGGING
2988 #    define DEBUG_LOCALE_INIT(a,b,c)
2989 #  else
2990
2991     DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
2992
2993 #    define DEBUG_LOCALE_INIT(category, locale, result)                     \
2994         STMT_START {                                                        \
2995                 if (debug_initialization) {                                 \
2996                     PerlIO_printf(Perl_debug_log,                           \
2997                                   "%s:%d: %s\n",                            \
2998                                   __FILE__, __LINE__,                       \
2999                                   setlocale_debug_string(category,          \
3000                                                           locale,           \
3001                                                           result));         \
3002                 }                                                           \
3003         } STMT_END
3004
3005 /* Make sure the parallel arrays are properly set up */
3006 #    ifdef USE_LOCALE_NUMERIC
3007     assert(categories[LC_NUMERIC_INDEX] == LC_NUMERIC);
3008     assert(strEQ(category_names[LC_NUMERIC_INDEX], "LC_NUMERIC"));
3009 #      ifdef USE_POSIX_2008_LOCALE
3010     assert(category_masks[LC_NUMERIC_INDEX] == LC_NUMERIC_MASK);
3011 #      endif
3012 #    endif
3013 #    ifdef USE_LOCALE_CTYPE
3014     assert(categories[LC_CTYPE_INDEX] == LC_CTYPE);
3015     assert(strEQ(category_names[LC_CTYPE_INDEX], "LC_CTYPE"));
3016 #      ifdef USE_POSIX_2008_LOCALE
3017     assert(category_masks[LC_CTYPE_INDEX] == LC_CTYPE_MASK);
3018 #      endif
3019 #    endif
3020 #    ifdef USE_LOCALE_COLLATE
3021     assert(categories[LC_COLLATE_INDEX] == LC_COLLATE);
3022     assert(strEQ(category_names[LC_COLLATE_INDEX], "LC_COLLATE"));
3023 #      ifdef USE_POSIX_2008_LOCALE
3024     assert(category_masks[LC_COLLATE_INDEX] == LC_COLLATE_MASK);
3025 #      endif
3026 #    endif
3027 #    ifdef USE_LOCALE_TIME
3028     assert(categories[LC_TIME_INDEX] == LC_TIME);
3029     assert(strEQ(category_names[LC_TIME_INDEX], "LC_TIME"));
3030 #      ifdef USE_POSIX_2008_LOCALE
3031     assert(category_masks[LC_TIME_INDEX] == LC_TIME_MASK);
3032 #      endif
3033 #    endif
3034 #    ifdef USE_LOCALE_MESSAGES
3035     assert(categories[LC_MESSAGES_INDEX] == LC_MESSAGES);
3036     assert(strEQ(category_names[LC_MESSAGES_INDEX], "LC_MESSAGES"));
3037 #      ifdef USE_POSIX_2008_LOCALE
3038     assert(category_masks[LC_MESSAGES_INDEX] == LC_MESSAGES_MASK);
3039 #      endif
3040 #    endif
3041 #    ifdef USE_LOCALE_MONETARY
3042     assert(categories[LC_MONETARY_INDEX] == LC_MONETARY);
3043     assert(strEQ(category_names[LC_MONETARY_INDEX], "LC_MONETARY"));
3044 #      ifdef USE_POSIX_2008_LOCALE
3045     assert(category_masks[LC_MONETARY_INDEX] == LC_MONETARY_MASK);
3046 #      endif
3047 #    endif
3048 #    ifdef USE_LOCALE_ADDRESS
3049     assert(categories[LC_ADDRESS_INDEX] == LC_ADDRESS);
3050     assert(strEQ(category_names[LC_ADDRESS_INDEX], "LC_ADDRESS"));
3051 #      ifdef USE_POSIX_2008_LOCALE
3052     assert(category_masks[LC_ADDRESS_INDEX] == LC_ADDRESS_MASK);
3053 #      endif
3054 #    endif
3055 #    ifdef USE_LOCALE_IDENTIFICATION
3056     assert(categories[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION);
3057     assert(strEQ(category_names[LC_IDENTIFICATION_INDEX], "LC_IDENTIFICATION"));
3058 #      ifdef USE_POSIX_2008_LOCALE
3059     assert(category_masks[LC_IDENTIFICATION_INDEX] == LC_IDENTIFICATION_MASK);
3060 #      endif
3061 #    endif
3062 #    ifdef USE_LOCALE_MEASUREMENT
3063     assert(categories[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT);
3064     assert(strEQ(category_names[LC_MEASUREMENT_INDEX], "LC_MEASUREMENT"));
3065 #      ifdef USE_POSIX_2008_LOCALE
3066     assert(category_masks[LC_MEASUREMENT_INDEX] == LC_MEASUREMENT_MASK);
3067 #      endif
3068 #    endif
3069 #    ifdef USE_LOCALE_PAPER
3070     assert(categories[LC_PAPER_INDEX] == LC_PAPER);
3071     assert(strEQ(category_names[LC_PAPER_INDEX], "LC_PAPER"));
3072 #      ifdef USE_POSIX_2008_LOCALE
3073     assert(category_masks[LC_PAPER_INDEX] == LC_PAPER_MASK);
3074 #      endif
3075 #    endif
3076 #    ifdef USE_LOCALE_TELEPHONE
3077     assert(categories[LC_TELEPHONE_INDEX] == LC_TELEPHONE);
3078     assert(strEQ(category_names[LC_TELEPHONE_INDEX], "LC_TELEPHONE"));
3079 #      ifdef USE_POSIX_2008_LOCALE
3080     assert(category_masks[LC_TELEPHONE_INDEX] == LC_TELEPHONE_MASK);
3081 #      endif
3082 #    endif
3083 #    ifdef LC_ALL
3084     assert(categories[LC_ALL_INDEX] == LC_ALL);
3085     assert(strEQ(category_names[LC_ALL_INDEX], "LC_ALL"));
3086     assert(NOMINAL_LC_ALL_INDEX == LC_ALL_INDEX);
3087 #      ifdef USE_POSIX_2008_LOCALE
3088     assert(category_masks[LC_ALL_INDEX] == LC_ALL_MASK);
3089 #      endif
3090 #    endif
3091 #  endif    /* DEBUGGING */
3092
3093     /* Initialize the cache of the program's UTF-8ness for the always known
3094      * locales C and POSIX */
3095     my_strlcpy(PL_locale_utf8ness, C_and_POSIX_utf8ness,
3096                sizeof(PL_locale_utf8ness));
3097
3098 #  ifdef USE_THREAD_SAFE_LOCALE
3099 #    ifdef WIN32
3100
3101     _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
3102
3103 #    endif
3104 #  endif
3105 #  if defined(LC_ALL_MASK) && defined(HAS_POSIX_2008_LOCALE)
3106
3107     PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
3108     if (! PL_C_locale_obj) {
3109         Perl_croak_nocontext(
3110             "panic: Cannot create POSIX 2008 C locale object; errno=%d", errno);
3111     }
3112     if (DEBUG_Lv_TEST || debug_initialization) {
3113         PerlIO_printf(Perl_debug_log, "%s:%d: created C object %p\n", __FILE__, __LINE__, PL_C_locale_obj);
3114     }
3115
3116 #  endif
3117
3118     PL_numeric_radix_sv = newSVpvs(".");
3119
3120 #  if defined(USE_POSIX_2008_LOCALE) && ! defined(HAS_QUERYLOCALE)
3121
3122     /* Initialize our records.  If we have POSIX 2008, we have LC_ALL */
3123     do_setlocale_c(LC_ALL, my_setlocale(LC_ALL, NULL));
3124
3125 #  endif
3126 #  ifdef LOCALE_ENVIRON_REQUIRED
3127
3128     /*
3129      * Ultrix setlocale(..., "") fails if there are no environment
3130      * variables from which to get a locale name.
3131      */
3132
3133 #    ifndef LC_ALL
3134 #      error Ultrix without LC_ALL not implemented
3135 #    else
3136
3137     {
3138         bool done = FALSE;
3139         if (lang) {
3140             sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, setlocale_init);
3141             DEBUG_LOCALE_INIT(LC_ALL, setlocale_init, sl_result[LC_ALL_INDEX]);
3142             if (sl_result[LC_ALL_INDEX])
3143                 done = TRUE;
3144             else
3145                 setlocale_failure = TRUE;
3146         }
3147         if (! setlocale_failure) {
3148             const char * locale_param;
3149             for (i = 0; i < LC_ALL_INDEX; i++) {
3150                 locale_param = (! done && (lang || PerlEnv_getenv(category_names[i])))
3151                             ? setlocale_init
3152                             : NULL;
3153                 sl_result[i] = do_setlocale_r(categories[i], locale_param);
3154                 if (! sl_result[i]) {
3155                     setlocale_failure = TRUE;
3156                 }
3157                 DEBUG_LOCALE_INIT(categories[i], locale_param, sl_result[i]);
3158             }
3159         }
3160     }
3161
3162 #    endif /* LC_ALL */
3163 #  endif /* LOCALE_ENVIRON_REQUIRED */
3164
3165     /* We try each locale in the list until we get one that works, or exhaust
3166      * the list.  Normally the loop is executed just once.  But if setting the
3167      * locale fails, inside the loop we add fallback trials to the array and so
3168      * will execute the loop multiple times */
3169     trial_locales[0] = setlocale_init;
3170     trial_locales_count = 1;
3171
3172     for (i= 0; i < trial_locales_count; i++) {
3173         const char * trial_locale = trial_locales[i];
3174
3175         if (i > 0) {
3176
3177             /* XXX This is to preserve old behavior for LOCALE_ENVIRON_REQUIRED
3178              * when i==0, but I (khw) don't think that behavior makes much
3179              * sense */
3180             setlocale_failure = FALSE;
3181
3182 #  ifdef SYSTEM_DEFAULT_LOCALE
3183 #    ifdef WIN32    /* Note that assumes Win32 has LC_ALL */
3184
3185             /* On Windows machines, an entry of "" after the 0th means to use
3186              * the system default locale, which we now proceed to get. */
3187             if (strEQ(trial_locale, "")) {
3188                 unsigned int j;
3189
3190                 /* Note that this may change the locale, but we are going to do
3191                  * that anyway just below */
3192                 system_default_locale = do_setlocale_c(LC_ALL, "");
3193                 DEBUG_LOCALE_INIT(LC_ALL, "", system_default_locale);
3194
3195                 /* Skip if invalid or if it's already on the list of locales to
3196                  * try */
3197                 if (! system_default_locale) {
3198                     goto next_iteration;
3199                 }
3200                 for (j = 0; j < trial_locales_count; j++) {
3201                     if (strEQ(system_default_locale, trial_locales[j])) {
3202                         goto next_iteration;
3203                     }
3204                 }
3205
3206                 trial_locale = system_default_locale;
3207             }
3208 #    else
3209 #      error SYSTEM_DEFAULT_LOCALE only implemented for Win32
3210 #    endif
3211 #  endif /* SYSTEM_DEFAULT_LOCALE */
3212
3213         }   /* For i > 0 */
3214
3215 #  ifdef LC_ALL
3216
3217         sl_result[LC_ALL_INDEX] = do_setlocale_c(LC_ALL, trial_locale);
3218         DEBUG_LOCALE_INIT(LC_ALL, trial_locale, sl_result[LC_ALL_INDEX]);
3219         if (! sl_result[LC_ALL_INDEX]) {
3220             setlocale_failure = TRUE;
3221         }
3222         else {
3223             /* Since LC_ALL succeeded, it should have changed all the other
3224              * categories it can to its value; so we massage things so that the
3225              * setlocales below just return their category's current values.
3226              * This adequately handles the case in NetBSD where LC_COLLATE may
3227              * not be defined for a locale, and setting it individually will
3228              * fail, whereas setting LC_ALL succeeds, leaving LC_COLLATE set to
3229              * the POSIX locale. */
3230             trial_locale = NULL;
3231         }
3232
3233 #  endif /* LC_ALL */
3234
3235         if (! setlocale_failure) {
3236             unsigned int j;
3237             for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
3238                 curlocales[j]
3239                         = savepv(do_setlocale_r(categories[j], trial_locale));
3240                 if (! curlocales[j]) {
3241                     setlocale_failure = TRUE;
3242                 }
3243                 DEBUG_LOCALE_INIT(categories[j], trial_locale, curlocales[j]);
3244             }
3245
3246             if (! setlocale_failure) {  /* All succeeded */
3247                 break;  /* Exit trial_locales loop */
3248             }
3249         }
3250
3251         /* Here, something failed; will need to try a fallback. */
3252         ok = 0;
3253
3254         if (i == 0) {
3255             unsigned int j;
3256
3257             if (locwarn) { /* Output failure info only on the first one */
3258
3259 #  ifdef LC_ALL
3260
3261                 PerlIO_printf(Perl_error_log,
3262                 "perl: warning: Setting locale failed.\n");
3263
3264 #  else /* !LC_ALL */
3265
3266                 PerlIO_printf(Perl_error_log,
3267                 "perl: warning: Setting locale failed for the categories:\n\t");
3268
3269                 for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
3270                     if (! curlocales[j]) {
3271                         PerlIO_printf(Perl_error_log, category_names[j]);
3272                     }
3273                     else {
3274                         Safefree(curlocales[j]);
3275                     }
3276                 }
3277
3278 #  endif /* LC_ALL */
3279
3280                 PerlIO_printf(Perl_error_log,
3281                     "perl: warning: Please check that your locale settings:\n");
3282
3283 #  ifdef __GLIBC__
3284
3285                 PerlIO_printf(Perl_error_log,
3286                             "\tLANGUAGE = %c%s%c,\n",
3287                             language ? '"' : '(',
3288                             language ? language : "unset",
3289                             language ? '"' : ')');
3290 #  endif
3291
3292                 PerlIO_printf(Perl_error_log,
3293                             "\tLC_ALL = %c%s%c,\n",
3294                             lc_all ? '"' : '(',
3295                             lc_all ? lc_all : "unset",
3296                             lc_all ? '"' : ')');
3297
3298 #  if defined(USE_ENVIRON_ARRAY)
3299
3300                 {
3301                     char **e;
3302
3303                     /* Look through the environment for any variables of the
3304                      * form qr/ ^ LC_ [A-Z]+ = /x, except LC_ALL which was
3305                      * already handled above.  These are assumed to be locale
3306                      * settings.  Output them and their values. */
3307                     for (e = environ; *e; e++) {
3308                         const STRLEN prefix_len = sizeof("LC_") - 1;
3309                         STRLEN uppers_len;
3310
3311                         if (     strBEGINs(*e, "LC_")
3312                             && ! strBEGINs(*e, "LC_ALL=")
3313                             && (uppers_len = strspn(*e + prefix_len,
3314                                              "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
3315                             && ((*e)[prefix_len + uppers_len] == '='))
3316                         {
3317                             PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
3318                                 (int) (prefix_len + uppers_len), *e,
3319                                 *e + prefix_len + uppers_len + 1);
3320                         }
3321                     }
3322                 }
3323
3324 #  else
3325
3326                 PerlIO_printf(Perl_error_log,
3327                             "\t(possibly more locale environment variables)\n");
3328
3329 #  endif
3330
3331                 PerlIO_printf(Perl_error_log,
3332                             "\tLANG = %c%s%c\n",
3333                             lang ? '"' : '(',
3334                             lang ? lang : "unset",
3335                             lang ? '"' : ')');
3336
3337                 PerlIO_printf(Perl_error_log,
3338                             "    are supported and installed on your system.\n");
3339             }
3340
3341             /* Calculate what fallback locales to try.  We have avoided this
3342              * until we have to, because failure is quite unlikely.  This will
3343              * usually change the upper bound of the loop we are in.
3344              *
3345              * Since the system's default way of setting the locale has not
3346              * found one that works, We use Perl's defined ordering: LC_ALL,
3347              * LANG, and the C locale.  We don't try the same locale twice, so
3348              * don't add to the list if already there.  (On POSIX systems, the
3349              * LC_ALL element will likely be a repeat of the 0th element "",
3350              * but there's no harm done by doing it explicitly.
3351              *
3352              * Note that this tries the LC_ALL environment variable even on
3353              * systems which have no LC_ALL locale setting.  This may or may
3354              * not have been originally intentional, but there's no real need
3355              * to change the behavior. */
3356             if (lc_all) {
3357                 for (j = 0; j < trial_locales_count; j++) {
3358                     if (strEQ(lc_all, trial_locales[j])) {
3359                         goto done_lc_all;
3360                     }
3361                 }
3362                 trial_locales[trial_locales_count++] = lc_all;
3363             }
3364           done_lc_all:
3365
3366             if (lang) {
3367                 for (j = 0; j < trial_locales_count; j++) {
3368                     if (strEQ(lang, trial_locales[j])) {
3369                         goto done_lang;
3370                     }
3371                 }
3372                 trial_locales[trial_locales_count++] = lang;
3373             }
3374           done_lang:
3375
3376 #  if defined(WIN32) && defined(LC_ALL)
3377
3378             /* For Windows, we also try the system default locale before "C".
3379              * (If there exists a Windows without LC_ALL we skip this because
3380              * it gets too complicated.  For those, the "C" is the next
3381              * fallback possibility).  The "" is the same as the 0th element of
3382              * the array, but the code at the loop above knows to treat it
3383              * differently when not the 0th */
3384             trial_locales[trial_locales_count++] = "";
3385
3386 #  endif
3387
3388             for (j = 0; j < trial_locales_count; j++) {
3389                 if (strEQ("C", trial_locales[j])) {
3390                     goto done_C;
3391                 }
3392             }
3393             trial_locales[trial_locales_count++] = "C";
3394
3395           done_C: ;
3396         }   /* end of first time through the loop */
3397
3398 #  ifdef WIN32
3399
3400       next_iteration: ;
3401
3402 #  endif
3403
3404     }   /* end of looping through the trial locales */
3405
3406     if (ok < 1) {   /* If we tried to fallback */
3407         const char* msg;
3408         if (! setlocale_failure) {  /* fallback succeeded */
3409            msg = "Falling back to";
3410         }
3411         else {  /* fallback failed */
3412             unsigned int j;
3413
3414             /* We dropped off the end of the loop, so have to decrement i to
3415              * get back to the value the last time through */
3416             i--;
3417
3418             ok = -1;
3419             msg = "Failed to fall back to";
3420
3421             /* To continue, we should use whatever values we've got */
3422
3423             for (j = 0; j < NOMINAL_LC_ALL_INDEX; j++) {
3424                 Safefree(curlocales[j]);
3425                 curlocales[j] = savepv(do_setlocale_r(categories[j], NULL));
3426                 DEBUG_LOCALE_INIT(categories[j], NULL, curlocales[j]);
3427             }
3428         }
3429
3430         if (locwarn) {
3431             const char * description;
3432             const char * name = "";
3433             if (strEQ(trial_locales[i], "C")) {
3434                 description = "the standard locale";
3435                 name = "C";
3436             }
3437
3438 #  ifdef SYSTEM_DEFAULT_LOCALE
3439
3440             else if (strEQ(trial_locales[i], "")) {
3441                 description = "the system default locale";
3442                 if (system_default_locale) {
3443                     name = system_default_locale;
3444                 }
3445             }
3446
3447 #  endif /* SYSTEM_DEFAULT_LOCALE */
3448
3449             else {
3450                 description = "a fallback locale";
3451                 name = trial_locales[i];
3452             }
3453             if (name && strNE(name, "")) {
3454                 PerlIO_printf(Perl_error_log,
3455                     "perl: warning: %s %s (\"%s\").\n", msg, description, name);
3456             }
3457             else {
3458                 PerlIO_printf(Perl_error_log,
3459                                    "perl: warning: %s %s.\n", msg, description);
3460             }
3461         }
3462     } /* End of tried to fallback */
3463
3464     /* Done with finding the locales; update our records */
3465
3466 #  ifdef USE_LOCALE_CTYPE
3467
3468     new_ctype(curlocales[LC_CTYPE_INDEX]);
3469
3470 #  endif
3471 #  ifdef USE_LOCALE_COLLATE
3472
3473     new_collate(curlocales[LC_COLLATE_INDEX]);
3474
3475 #  endif
3476 #  ifdef USE_LOCALE_NUMERIC
3477
3478     new_numeric(curlocales[LC_NUMERIC_INDEX]);
3479
3480 #  endif
3481
3482     for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
3483
3484 #  if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
3485
3486         /* This caches whether each category's locale is UTF-8 or not.  This
3487          * may involve changing the locale.  It is ok to do this at
3488          * initialization time before any threads have started, but not later
3489          * unless thread-safe operations are used.
3490          * Caching means that if the program heeds our dictate not to change
3491          * locales in threaded applications, this data will remain valid, and
3492          * it may get queried without having to change locales.  If the
3493          * environment is such that all categories have the same locale, this
3494          * isn't needed, as the code will not change the locale; but this
3495          * handles the uncommon case where the environment has disparate
3496          * locales for the categories */
3497         (void) _is_cur_LC_category_utf8(categories[i]);
3498
3499 #  endif
3500
3501         Safefree(curlocales[i]);
3502     }
3503
3504 #  if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
3505
3506     /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
3507      * locale is UTF-8.  The call to new_ctype() just above has already
3508      * calculated the latter value and saved it in PL_in_utf8_CTYPE_locale. If
3509      * both PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
3510      * are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer on
3511      * STDIN, STDOUT, STDERR, _and_ the default open discipline.  */
3512     PL_utf8locale = PL_in_utf8_CTYPE_locale;
3513
3514     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
3515        This is an alternative to using the -C command line switch
3516        (the -C if present will override this). */
3517     {
3518          const char *p = PerlEnv_getenv("PERL_UNICODE");
3519          PL_unicode = p ? parse_unicode_opts(&p) : 0;
3520          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3521              PL_utf8cache = -1;
3522     }
3523
3524 #  endif
3525 #  ifdef __GLIBC__
3526
3527     Safefree(language);
3528
3529 #  endif
3530
3531     Safefree(lc_all);
3532     Safefree(lang);
3533
3534 #endif /* USE_LOCALE */
3535 #ifdef DEBUGGING
3536
3537     /* So won't continue to output stuff */
3538     DEBUG_INITIALIZATION_set(FALSE);
3539
3540 #endif
3541
3542     return ok;
3543 }
3544
3545 #ifdef USE_LOCALE_COLLATE
3546
3547 char *
3548 Perl__mem_collxfrm(pTHX_ const char *input_string,
3549                          STRLEN len,    /* Length of 'input_string' */
3550                          STRLEN *xlen,  /* Set to length of returned string
3551                                            (not including the collation index
3552                                            prefix) */
3553                          bool utf8      /* Is the input in UTF-8? */
3554                    )
3555 {
3556
3557     /* _mem_collxfrm() is a bit like strxfrm() but with two important
3558      * differences. First, it handles embedded NULs. Second, it allocates a bit
3559      * more memory than needed for the transformed data itself.  The real
3560      * transformed data begins at offset COLLXFRM_HDR_LEN.  *xlen is set to
3561      * the length of that, and doesn't include the collation index size.
3562      * Please see sv_collxfrm() to see how this is used. */
3563
3564 #define COLLXFRM_HDR_LEN    sizeof(PL_collation_ix)
3565
3566     char * s = (char *) input_string;
3567     STRLEN s_strlen = strlen(input_string);
3568     char *xbuf = NULL;
3569     STRLEN xAlloc;          /* xalloc is a reserved word in VC */
3570     STRLEN length_in_chars;
3571     bool first_time = TRUE; /* Cleared after first loop iteration */
3572
3573     PERL_ARGS_ASSERT__MEM_COLLXFRM;
3574
3575     /* Must be NUL-terminated */
3576     assert(*(input_string + len) == '\0');
3577
3578     /* If this locale has defective collation, skip */
3579     if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
3580         DEBUG_L(PerlIO_printf(Perl_debug_log,
3581                       "_mem_collxfrm: locale's collation is defective\n"));
3582         goto bad;
3583     }
3584
3585     /* Replace any embedded NULs with the control that sorts before any others.
3586      * This will give as good as possible results on strings that don't
3587      * otherwise contain that character, but otherwise there may be
3588      * less-than-perfect results with that character and NUL.  This is
3589      * unavoidable unless we replace strxfrm with our own implementation. */
3590     if (UNLIKELY(s_strlen < len)) {   /* Only execute if there is an embedded
3591                                          NUL */
3592         char * e = s + len;
3593         char * sans_nuls;
3594         STRLEN sans_nuls_len;
3595         int try_non_controls;
3596         char this_replacement_char[] = "?\0";   /* Room for a two-byte string,
3597                                                    making sure 2nd byte is NUL.
3598                                                  */
3599         STRLEN this_replacement_len;
3600
3601         /* If we don't know what non-NUL control character sorts lowest for
3602          * this locale, find it */
3603         if (PL_strxfrm_NUL_replacement == '\0') {
3604             int j;
3605             char * cur_min_x = NULL;    /* The min_char's xfrm, (except it also
3606                                            includes the collation index
3607                                            prefixed. */
3608
3609             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
3610
3611             /* Unlikely, but it may be that no control will work to replace
3612              * NUL, in which case we instead look for any character.  Controls
3613              * are preferred because collation order is, in general, context
3614              * sensitive, with adjoining characters affecting the order, and
3615              * controls are less likely to have such interactions, allowing the
3616              * NUL-replacement to stand on its own.  (Another way to look at it
3617              * is to imagine what would happen if the NUL were replaced by a
3618              * combining character; it wouldn't work out all that well.) */
3619             for (try_non_controls = 0;
3620                  try_non_controls < 2;
3621                  try_non_controls++)
3622             {
3623                 /* Look through all legal code points (NUL isn't) */
3624                 for (j = 1; j < 256; j++) {
3625                     char * x;       /* j's xfrm plus collation index */
3626                     STRLEN x_len;   /* length of 'x' */
3627                     STRLEN trial_len = 1;
3628                     char cur_source[] = { '\0', '\0' };
3629
3630                     /* Skip non-controls the first time through the loop.  The
3631                      * controls in a UTF-8 locale are the L1 ones */
3632                     if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
3633                                                ? ! isCNTRL_L1(j)
3634                                                : ! isCNTRL_LC(j))
3635                     {
3636                         continue;
3637                     }
3638
3639                     /* Create a 1-char string of the current code point */
3640                     cur_source[0] = (char) j;
3641
3642                     /* Then transform it */
3643                     x = _mem_collxfrm(cur_source, trial_len, &x_len,
3644                                       0 /* The string is not in UTF-8 */);
3645
3646                     /* Ignore any character that didn't successfully transform.
3647                      * */
3648                     if (! x) {
3649                         continue;
3650                     }
3651
3652                     /* If this character's transformation is lower than
3653                      * the current lowest, this one becomes the lowest */
3654                     if (   cur_min_x == NULL
3655                         || strLT(x         + COLLXFRM_HDR_LEN,
3656                                  cur_min_x + COLLXFRM_HDR_LEN))
3657                     {
3658                         PL_strxfrm_NUL_replacement = j;
3659                         cur_min_x = x;
3660                     }
3661                     else {
3662                         Safefree(x);
3663                     }
3664                 } /* end of loop through all 255 characters */
3665
3666                 /* Stop looking if found */
3667                 if (cur_min_x) {
3668                     break;
3669                 }
3670
3671                 /* Unlikely, but possible, if there aren't any controls that
3672                  * work in the locale, repeat the loop, looking for any
3673                  * character that works */
3674                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3675                 "_mem_collxfrm: No control worked.  Trying non-controls\n"));
3676             } /* End of loop to try first the controls, then any char */
3677
3678             if (! cur_min_x) {
3679                 DEBUG_L(PerlIO_printf(Perl_debug_log,
3680                     "_mem_collxfrm: Couldn't find any character to replace"
3681                     " embedded NULs in locale %s with", PL_collation_name));
3682                 goto bad;
3683             }
3684
3685             DEBUG_L(PerlIO_printf(Perl_debug_log,
3686                     "_mem_collxfrm: Replacing embedded NULs in locale %s with "
3687                     "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
3688
3689             Safefree(cur_min_x);
3690         } /* End of determining the character that is to replace NULs */
3691
3692         /* If the replacement is variant under UTF-8, it must match the
3693          * UTF8-ness of the original */
3694         if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
3695             this_replacement_char[0] =
3696                                 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
3697             this_replacement_char[1] =
3698                                 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
3699             this_replacement_len = 2;
3700         }
3701         else {
3702             this_replacement_char[0] = PL_strxfrm_NUL_replacement;
3703             /* this_replacement_char[1] = '\0' was done at initialization */
3704             this_replacement_len = 1;
3705         }
3706
3707         /* The worst case length for the replaced string would be if every
3708          * character in it is NUL.  Multiply that by the length of each
3709          * replacement, and allow for a trailing NUL */
3710         sans_nuls_len = (len * this_replacement_len) + 1;
3711         Newx(sans_nuls, sans_nuls_len, char);
3712         *sans_nuls = '\0';
3713
3714         /* Replace each NUL with the lowest collating control.  Loop until have
3715          * exhausted all the NULs */
3716         while (s + s_strlen < e) {
3717             my_strlcat(sans_nuls, s, sans_nuls_len);
3718
3719             /* Do the actual replacement */
3720             my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
3721
3722             /* Move past the input NUL */
3723             s += s_strlen + 1;
3724             s_strlen = strlen(s);
3725         }
3726
3727         /* And add anything that trails the final NUL */
3728         my_strlcat(sans_nuls, s, sans_nuls_len);
3729
3730         /* Switch so below we transform this modified string */
3731         s = sans_nuls;
3732         len = strlen(s);
3733     } /* End of replacing NULs */
3734
3735     /* Make sure the UTF8ness of the string and locale match */
3736     if (utf8 != PL_in_utf8_COLLATE_locale) {
3737         /* XXX convert above Unicode to 10FFFF? */
3738         const char * const t = s;   /* Temporary so we can later find where the
3739                                        input was */
3740
3741         /* Here they don't match.  Change the string's to be what the locale is
3742          * expecting */
3743
3744         if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
3745             s = (char *) bytes_to_utf8((const U8 *) s, &len);
3746             utf8 = TRUE;
3747         }
3748         else {   /* locale is not UTF-8; but input is; downgrade the input */
3749
3750             s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
3751
3752             /* If the downgrade was successful we are done, but if the input
3753              * contains things that require UTF-8 to represent, have to do
3754              * damage control ... */
3755             if (UNLIKELY(utf8)) {
3756
3757                 /* What we do is construct a non-UTF-8 string with
3758                  *  1) the characters representable by a single byte converted
3759                  *     to be so (if necessary);
3760                  *  2) and the rest converted to collate the same as the
3761                  *     highest collating representable character.  That makes
3762                  *     them collate at the end.  This is similar to how we
3763                  *     handle embedded NULs, but we use the highest collating
3764                  *     code point instead of the smallest.  Like the NUL case,
3765                  *     this isn't perfect, but is the best we can reasonably
3766                  *     do.  Every above-255 code point will sort the same as
3767                  *     the highest-sorting 0-255 code point.  If that code
3768                  *     point can combine in a sequence with some other code
3769                  *     points for weight calculations, us changing something to
3770                  *     be it can adversely affect the results.  But in most
3771                  *     cases, it should work reasonably.  And note that this is
3772                  *     really an illegal situation: using code points above 255
3773                  *     on a locale where only 0-255 are valid.  If two strings
3774                  *     sort entirely equal, then the sort order for the
3775                  *     above-255 code points will be in code point order. */
3776
3777                 utf8 = FALSE;
3778
3779                 /* If we haven't calculated the code point with the maximum
3780                  * collating order for this locale, do so now */
3781                 if (! PL_strxfrm_max_cp) {
3782                     int j;
3783
3784                     /* The current transformed string that collates the
3785                      * highest (except it also includes the prefixed collation
3786                      * index. */
3787                     char * cur_max_x = NULL;
3788
3789                     /* Look through all legal code points (NUL isn't) */
3790                     for (j = 1; j < 256; j++) {
3791                         char * x;
3792                         STRLEN x_len;
3793                         char cur_source[] = { '\0', '\0' };
3794
3795                         /* Create a 1-char string of the current code point */
3796                         cur_source[0] = (char) j;
3797
3798                         /* Then transform it */
3799                         x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
3800
3801                         /* If something went wrong (which it shouldn't), just
3802                          * ignore this code point */
3803                         if (! x) {
3804                             continue;
3805                         }
3806
3807                         /* If this character's transformation is higher than
3808                          * the current highest, this one becomes the highest */
3809                         if (   cur_max_x == NULL
3810                             || strGT(x         + COLLXFRM_HDR_LEN,
3811                                      cur_max_x + COLLXFRM_HDR_LEN))
3812                         {
3813                             PL_strxfrm_max_cp = j;
3814                             cur_max_x = x;
3815                         }
3816                         else {
3817                             Safefree(x);
3818                         }
3819                     }
3820
3821                     if (! cur_max_x) {
3822                         DEBUG_L(PerlIO_printf(Perl_debug_log,
3823                             "_mem_collxfrm: Couldn't find any character to"
3824                             " replace above-Latin1 chars in locale %s with",
3825                             PL_collation_name));
3826                         goto bad;
3827                     }
3828
3829                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3830                             "_mem_collxfrm: highest 1-byte collating character"
3831                             " in locale %s is 0x%02X\n",
3832                             PL_collation_name,
3833                             PL_strxfrm_max_cp));
3834
3835                     Safefree(cur_max_x);
3836                 }
3837
3838                 /* Here we know which legal code point collates the highest.
3839                  * We are ready to construct the non-UTF-8 string.  The length
3840                  * will be at least 1 byte smaller than the input string
3841                  * (because we changed at least one 2-byte character into a
3842                  * single byte), but that is eaten up by the trailing NUL */
3843                 Newx(s, len, char);
3844
3845                 {
3846                     STRLEN i;
3847                     STRLEN d= 0;
3848                     char * e = (char *) t + len;
3849
3850                     for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
3851                         U8 cur_char = t[i];
3852                         if (UTF8_IS_INVARIANT(cur_char)) {
3853                             s[d++] = cur_char;
3854                         }
3855                         else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
3856                             s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
3857                         }
3858                         else {  /* Replace illegal cp with highest collating
3859                                    one */
3860                             s[d++] = PL_strxfrm_max_cp;
3861                         }
3862                     }
3863                     s[d++] = '\0';
3864                     Renew(s, d, char);   /* Free up unused space */
3865                 }
3866             }
3867         }
3868
3869         /* Here, we have constructed a modified version of the input.  It could
3870          * be that we already had a modified copy before we did this version.
3871          * If so, that copy is no longer needed */
3872         if (t != input_string) {
3873             Safefree(t);
3874         }
3875     }
3876
3877     length_in_chars = (utf8)
3878                       ? utf8_length((U8 *) s, (U8 *) s + len)
3879                       : len;
3880
3881     /* The first element in the output is the collation id, used by
3882      * sv_collxfrm(); then comes the space for the transformed string.  The
3883      * equation should give us a good estimate as to how much is needed */
3884     xAlloc = COLLXFRM_HDR_LEN
3885            + PL_collxfrm_base
3886            + (PL_collxfrm_mult * length_in_chars);
3887     Newx(xbuf, xAlloc, char);
3888     if (UNLIKELY(! xbuf)) {
3889         DEBUG_L(PerlIO_printf(Perl_debug_log,
3890                       "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
3891         goto bad;
3892     }
3893
3894     /* Store the collation id */
3895     *(U32*)xbuf = PL_collation_ix;
3896
3897     /* Then the transformation of the input.  We loop until successful, or we
3898      * give up */
3899     for (;;) {
3900
3901         *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
3902
3903         /* If the transformed string occupies less space than we told strxfrm()
3904          * was available, it means it successfully transformed the whole
3905          * string. */
3906         if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
3907
3908             /* Some systems include a trailing NUL in the returned length.
3909              * Ignore it, using a loop in case multiple trailing NULs are
3910              * returned. */
3911             while (   (*xlen) > 0
3912                    && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
3913             {
3914                 (*xlen)--;
3915             }
3916
3917             /* If the first try didn't get it, it means our prediction was low.
3918              * Modify the coefficients so that we predict a larger value in any
3919              * future transformations */
3920             if (! first_time) {
3921                 STRLEN needed = *xlen + 1;   /* +1 For trailing NUL */
3922                 STRLEN computed_guess = PL_collxfrm_base
3923                                       + (PL_collxfrm_mult * length_in_chars);
3924
3925                 /* On zero-length input, just keep current slope instead of
3926                  * dividing by 0 */
3927                 const STRLEN new_m = (length_in_chars != 0)
3928                                      ? needed / length_in_chars
3929                                      : PL_collxfrm_mult;
3930
3931                 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3932                     "%s: %d: initial size of %zu bytes for a length "
3933                     "%zu string was insufficient, %zu needed\n",
3934                     __FILE__, __LINE__,
3935                     computed_guess, length_in_chars, needed));
3936
3937                 /* If slope increased, use it, but discard this result for
3938                  * length 1 strings, as we can't be sure that it's a real slope
3939                  * change */
3940                 if (length_in_chars > 1 && new_m  > PL_collxfrm_mult) {
3941
3942 #  ifdef DEBUGGING
3943
3944                     STRLEN old_m = PL_collxfrm_mult;
3945                     STRLEN old_b = PL_collxfrm_base;
3946
3947 #  endif
3948
3949                     PL_collxfrm_mult = new_m;
3950                     PL_collxfrm_base = 1;   /* +1 For trailing NUL */
3951                     computed_guess = PL_collxfrm_base
3952                                     + (PL_collxfrm_mult * length_in_chars);
3953                     if (computed_guess < needed) {
3954                         PL_collxfrm_base += needed - computed_guess;
3955                     }
3956
3957                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3958                         "%s: %d: slope is now %zu; was %zu, base "
3959                         "is now %zu; was %zu\n",
3960                         __FILE__, __LINE__,
3961                         PL_collxfrm_mult, old_m,
3962                         PL_collxfrm_base, old_b));
3963                 }
3964                 else {  /* Slope didn't change, but 'b' did */
3965                     const STRLEN new_b = needed
3966                                         - computed_guess
3967                                         + PL_collxfrm_base;
3968                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3969                         "%s: %d: base is now %zu; was %zu\n",
3970                         __FILE__, __LINE__,
3971                         new_b, PL_collxfrm_base));
3972                     PL_collxfrm_base = new_b;
3973                 }
3974             }
3975
3976             break;
3977         }
3978
3979         if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
3980             DEBUG_L(PerlIO_printf(Perl_debug_log,
3981                   "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
3982                   *xlen, PERL_INT_MAX));
3983             goto bad;
3984         }
3985
3986         /* A well-behaved strxfrm() returns exactly how much space it needs
3987          * (usually not including the trailing NUL) when it fails due to not
3988          * enough space being provided.  Assume that this is the case unless
3989          * it's been proven otherwise */
3990         if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
3991             xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
3992         }
3993         else { /* Here, either:
3994                 *  1)  The strxfrm() has previously shown bad behavior; or
3995                 *  2)  It isn't the first time through the loop, which means
3996                 *      that the strxfrm() is now showing bad behavior, because
3997                 *      we gave it what it said was needed in the previous
3998                 *      iteration, and it came back saying it needed still more.
3999                 *      (Many versions of cygwin fit this.  When the buffer size
4000                 *      isn't sufficient, they return the input size instead of
4001                 *      how much is needed.)
4002                 * Increase the buffer size by a fixed percentage and try again.
4003                 * */
4004             xAlloc += (xAlloc / 4) + 1;
4005             PL_strxfrm_is_behaved = FALSE;
4006
4007 #  ifdef DEBUGGING
4008
4009             if (DEBUG_Lv_TEST || debug_initialization) {
4010                 PerlIO_printf(Perl_debug_log,
4011                 "_mem_collxfrm required more space than previously calculated"
4012                 " for locale %s, trying again with new guess=%d+%zu\n",
4013                 PL_collation_name, (int) COLLXFRM_HDR_LEN,
4014                 xAlloc - COLLXFRM_HDR_LEN);
4015             }
4016
4017 #  endif
4018
4019         }
4020
4021         Renew(xbuf, xAlloc, char);
4022         if (UNLIKELY(! xbuf)) {
4023             DEBUG_L(PerlIO_printf(Perl_debug_log,
4024                       "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
4025             goto bad;
4026         }
4027
4028         first_time = FALSE;
4029     }
4030
4031
4032 #  ifdef DEBUGGING
4033
4034     if (DEBUG_Lv_TEST || debug_initialization) {
4035
4036         print_collxfrm_input_and_return(s, s + len, xlen, utf8);
4037         PerlIO_printf(Perl_debug_log, "Its xfrm is:");
4038         PerlIO_printf(Perl_debug_log, "%s\n",
4039                       _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
4040                        *xlen, 1));
4041     }
4042
4043 #  endif
4044
4045     /* Free up unneeded space; retain ehough for trailing NUL */
4046     Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
4047
4048     if (s != input_string) {
4049         Safefree(s);
4050     }
4051
4052     return xbuf;
4053
4054   bad:
4055     Safefree(xbuf);
4056     if (s != input_string) {
4057         Safefree(s);
4058     }
4059     *xlen = 0;
4060
4061 #  ifdef DEBUGGING
4062
4063     if (DEBUG_Lv_TEST || debug_initialization) {
4064         print_collxfrm_input_and_return(s, s + len, NULL, utf8);
4065     }
4066
4067 #  endif
4068
4069     return NULL;
4070 }
4071
4072 #  ifdef DEBUGGING
4073
4074 STATIC void
4075 S_print_collxfrm_input_and_return(pTHX_
4076                                   const char * const s,
4077                                   const char * const e,
4078                                   const STRLEN * const xlen,
4079                                   const bool is_utf8)
4080 {
4081
4082     PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
4083
4084     PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ",
4085                                                         (UV)PL_collation_ix);
4086     if (xlen) {
4087         PerlIO_printf(Perl_debug_log, "%zu", *xlen);
4088     }
4089     else {
4090         PerlIO_printf(Perl_debug_log, "NULL");
4091     }
4092     PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
4093                                                             PL_collation_name);
4094     print_bytes_for_locale(s, e, is_utf8);
4095
4096     PerlIO_printf(Perl_debug_log, "'\n");
4097 }
4098
4099 STATIC void
4100 S_print_bytes_for_locale(pTHX_
4101                     const char * const s,
4102                     const char * const e,
4103                     const bool is_utf8)
4104 {
4105     const char * t = s;
4106     bool prev_was_printable = TRUE;
4107     bool first_time = TRUE;
4108
4109     PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE;
4110
4111     while (t < e) {
4112         UV cp = (is_utf8)
4113                 ?  utf8_to_uvchr_buf((U8 *) t, e, NULL)
4114                 : * (U8 *) t;
4115         if (isPRINT(cp)) {
4116             if (! prev_was_printable) {
4117                 PerlIO_printf(Perl_debug_log, " ");
4118             }
4119             PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
4120             prev_was_printable = TRUE;
4121         }
4122         else {
4123             if (! first_time) {
4124                 PerlIO_printf(Perl_debug_log, " ");
4125             }
4126             PerlIO_printf(Perl_debug_log, "%02" UVXf, cp);
4127             prev_was_printable = FALSE;
4128         }
4129         t += (is_utf8) ? UTF8SKIP(t) : 1;
4130         first_time = FALSE;
4131     }
4132 }
4133
4134 #  endif   /* #ifdef DEBUGGING */
4135 #endif /* USE_LOCALE_COLLATE */
4136
4137 #ifdef USE_LOCALE
4138
4139 STATIC const char *
4140 S_switch_category_locale_to_template(pTHX_ const int switch_category, const int template_category, const char * template_locale)
4141 {
4142     /* Changes the locale for LC_'switch_category" to that of
4143      * LC_'template_category', if they aren't already the same.  If not NULL,
4144      * 'template_locale' is the locale that 'template_category' is in.
4145      *
4146      * Returns a copy of the name of the original locale for 'switch_category'
4147      * so can be switched back to with the companion function
4148      * restore_switched_locale(),  (NULL if no restoral is necessary.) */
4149
4150     char * restore_to_locale = NULL;
4151
4152     if (switch_category == template_category) { /* No changes needed */
4153         return NULL;
4154     }
4155
4156     /* Find the original locale of the category we may need to change, so that
4157      * it can be restored to later */
4158     restore_to_locale = stdize_locale(savepv(do_setlocale_r(switch_category,
4159                                                             NULL)));
4160     if (! restore_to_locale) {
4161         Perl_croak(aTHX_
4162              "panic: %s: %d: Could not find current %s locale, errno=%d\n",
4163                 __FILE__, __LINE__, category_name(switch_category), errno);
4164     }
4165
4166     /* If the locale of the template category wasn't passed in, find it now */
4167     if (template_locale == NULL) {
4168         template_locale = do_setlocale_r(template_category, NULL);
4169         if (! template_locale) {
4170             Perl_croak(aTHX_
4171              "panic: %s: %d: Could not find current %s locale, errno=%d\n",
4172                    __FILE__, __LINE__, category_name(template_category), errno);
4173         }
4174     }
4175
4176     /* It the locales are the same, there's nothing to do */
4177     if (strEQ(restore_to_locale, template_locale)) {
4178         Safefree(restore_to_locale);
4179
4180         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale unchanged as %s\n",
4181                             category_name(switch_category), restore_to_locale));
4182
4183         return NULL;
4184     }
4185
4186     /* Finally, change the locale to the template one */
4187     if (! do_setlocale_r(switch_category, template_locale)) {
4188         Perl_croak(aTHX_
4189          "panic: %s: %d: Could not change %s locale to %s, errno=%d\n",
4190                             __FILE__, __LINE__, category_name(switch_category),
4191                                                        template_locale, errno);
4192     }
4193
4194     DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s locale switched to %s\n",
4195                             category_name(switch_category), template_locale));
4196
4197     return restore_to_locale;
4198 }
4199
4200 STATIC void
4201 S_restore_switched_locale(pTHX_ const int category, const char * const original_locale)
4202 {
4203     /* Restores the locale for LC_'category' to 'original_locale' (which is a
4204      * copy that will be freed by this function), or do nothing if the latter
4205      * parameter is NULL */
4206
4207     if (original_locale == NULL) {
4208         return;
4209     }
4210
4211     if (! do_setlocale_r(category, original_locale)) {
4212         Perl_croak(aTHX_
4213              "panic: %s: %d: setlocale %s restore to %s failed, errno=%d\n",
4214                  __FILE__, __LINE__,
4215                              category_name(category), original_locale, errno);
4216     }
4217
4218     Safefree(original_locale);
4219 }
4220
4221 bool
4222 Perl__is_cur_LC_category_utf8(pTHX_ int category)
4223 {
4224     /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE
4225      * otherwise. 'category' may not be LC_ALL.  If the platform doesn't have
4226      * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence
4227      * could give the wrong result.  The result will very likely be correct for
4228      * languages that have commonly used non-ASCII characters, but for notably
4229      * English, it comes down to if the locale's name ends in something like
4230      * "UTF-8".  It errs on the side of not being a UTF-8 locale.
4231      *
4232      * If the platform is early C89, not containing mbtowc(), or we are
4233      * compiled to not pay attention to LC_CTYPE, this employs heuristics.
4234      * These work very well for non-Latin locales or those whose currency
4235      * symbol isn't a '$' nor plain ASCII text.  But without LC_CTYPE and at
4236      * least MB_CUR_MAX, English locales with an ASCII currency symbol depend
4237      * on the name containing UTF-8 or not. */
4238
4239     /* Name of current locale corresponding to the input category */
4240     const char *save_input_locale = NULL;
4241
4242     bool is_utf8 = FALSE;                /* The return value */
4243
4244     /* The variables below are for the cache of previous lookups using this
4245      * function.  The cache is a C string, described at the definition for
4246      * 'C_and_POSIX_utf8ness'.
4247      *
4248      * The first part of the cache is fixed, for the C and POSIX locales.  The
4249      * varying part starts just after them. */
4250     char * utf8ness_cache = PL_locale_utf8ness + STRLENs(C_and_POSIX_utf8ness);
4251
4252     Size_t utf8ness_cache_size; /* Size of the varying portion */
4253     Size_t input_name_len;      /* Length in bytes of save_input_locale */
4254     Size_t input_name_len_with_overhead;    /* plus extra chars used to store
4255                                                the name in the cache */
4256     char * delimited;           /* The name plus the delimiters used to store
4257                                    it in the cache */
4258     char * name_pos;            /* position of 'delimited' in the cache, or 0
4259                                    if not there */
4260
4261
4262 #  ifdef LC_ALL
4263
4264     assert(category != LC_ALL);
4265
4266 #  endif
4267
4268     /* Get the desired category's locale */
4269     save_input_locale = stdize_locale(savepv(do_setlocale_r(category, NULL)));
4270     if (! save_input_locale) {
4271         Perl_croak(aTHX_
4272              "panic: %s: %d: Could not find current %s locale, errno=%d\n",
4273                      __FILE__, __LINE__, category_name(category), errno);
4274     }
4275
4276     DEBUG_L(PerlIO_printf(Perl_debug_log,
4277                           "Current locale for %s is %s\n",
4278                           category_name(category), save_input_locale));
4279
4280     input_name_len = strlen(save_input_locale);
4281
4282     /* In our cache, each name is accompanied by two delimiters and a single
4283      * utf8ness digit */
4284     input_name_len_with_overhead = input_name_len + 3;
4285
4286     /* Allocate and populate space for a copy of the name surrounded by the
4287      * delimiters */
4288     Newx(delimited, input_name_len_with_overhead, char);
4289     delimited[0] = UTF8NESS_SEP[0];
4290     Copy(save_input_locale, delimited + 1, input_name_len, char);
4291     delimited[input_name_len+1] = UTF8NESS_PREFIX[0];
4292     delimited[input_name_len+2] = '\0';
4293
4294     /* And see if that is in the cache */
4295     name_pos = instr(PL_locale_utf8ness, delimited);
4296     if (name_pos) {
4297         is_utf8 = *(name_pos + input_name_len_with_overhead - 1) - '0';
4298
4299 #  ifdef DEBUGGING
4300
4301         if (DEBUG_Lv_TEST || debug_initialization) {
4302             PerlIO_printf(Perl_debug_log, "UTF8ness for locale %s=%d, \n",
4303                                           save_input_locale, is_utf8);
4304         }
4305
4306 #  endif
4307
4308         /* And, if not already in that position, move it to the beginning of
4309          * the non-constant portion of the list, since it is the most recently
4310          * used.  (We don't have to worry about overflow, since just moving
4311          * existing names around) */
4312         if (name_pos > utf8ness_cache) {
4313             Move(utf8ness_cache,
4314                  utf8ness_cache + input_name_len_with_overhead,
4315                  name_pos - utf8ness_cache, char);
4316             Copy(delimited,
4317                  utf8ness_cache,
4318                  input_name_len_with_overhead - 1, char);
4319             utf8ness_cache[input_name_len_with_overhead - 1] = is_utf8 + '0';
4320         }
4321
4322         Safefree(delimited);