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  * There is more than the typical amount of variation between platforms with
  37  * regard to locale handling.  At the end of these introductory comments, are
  38  * listed various relevent Configuration options, including some that can be
  39  * used to pretend to some extent that this is being developed on a different
  40  * platform than it actually is.  This allows you to make changes and catch
  41  * some errors without having access to those other platforms.
  42  *
  43  * This code now has multi-thread-safe locale handling on systems that support
  44  * that.  This is completely transparent to most XS code.  On earlier systems,
  45  * it would be possible to emulate thread-safe locales, but this likely would
  46  * involve a lot of locale switching, and would require XS code changes.
  47  * Macros could be written so that the code wouldn't have to know which type of
  48  * system is being used.
  49  *
  50  * Table-driven code is used for simplicity and clarity, as many operations
  51  * differ only in which category is being worked on.  However the system
  52  * categories need not be small contiguous integers, so do not lend themselves
  53  * to table lookup.  Instead we have created our own equivalent values which
  54  * are all small contiguous non-negative integers, and translation functions
  55  * between the two sets.  For category 'LC_foo', the name of our index is
  56  * LC_foo_INDEX_.  Various parallel tables, indexed by these, are used for the
  57  * translation.  The tables are generated at compile-time based on platform
  58  * characteristics and Configure options.  They hide from the code many of the
  59  * vagaries of the different locale implementations out there.
  60  *
  61  * On unthreaded perls, most operations expand out to just the basic
  62  * setlocale() calls.  That sort of is true on threaded perls on modern Windows
  63  * systems where the same API, after set up, is used for thread-safe locale
  64  * handling.  (But there are complications on Windows due to internal character
  65  * set issues.)  On other systems, there is a completely different API,
  66  * specified in POSIX 2008, to do thread-safe locales.  On these systems, our
  67  * bool_setlocale_2008_i() function is used to hide the different API from the
  68  * outside.  This makes it completely transparent to most XS code.
  69  *
  70  * A huge complicating factor is that the LC_NUMERIC category is normally held
  71  * in the C locale, except during those relatively rare times when it needs to
  72  * be in the underlying locale.  There is a bunch of code to accomplish this,
  73  * and to allow easy switches from one state to the other.
  74  *
  75  * In addition, the setlocale equivalents have versions for the return context,
  76  * 'void' and 'bool', besides the full return value.  This can present
  77  * opportunities for avoiding work.  We don't have to necessarily create a safe
  78  * copy to return if no return is desired.
  79  *
  80  * There are 3.5 major implementations here; which one chosen depends on what
  81  * the platform has available, and Configuration options.
  82  *
  83  * 1) Raw posix_setlocale().  This implementation is basically the libc
  84  *    setlocale(), with possibly minor tweaks.  This is used for startup, and
  85  *    always for unthreaded perls, and when the API for safe locale threading
  86  *    is identical to the unsafe API (Windows, currently).
  87  *
  88  *    This implementation is composed of two layers:
  89  *      a)  posix_setlocale() implements the libc setlocale().  In most cases,
  90  *          it is just an alias for the libc version.  But Windows doesn't
  91  *          fully conform to the POSIX standard, and this is a layer on top of
  92  *          libc to bring it more into conformance.  And in Configurations
  93  *          where perl is to ignore some locale categories that the libc
  94  *          setlocale() knows about, there is a layer to cope with that.
  95  *      b)  stdized_setlocale() is a layer above a) that fixes some vagaries in
  96  *          the return value of the libc setlocale().  On most platforms this
  97  *          layer is empty; it requires perl to be Configured with a parameter
  98  *          indicating the platform's defect, in order to be activated.  The
  99  *          current ones are listed at the definition of the macro.
 100  *
 101  * 2) An implementation that adds a minimal layer above implementation 1),
 102  *    making that implementation uninterruptible and returning a
 103  *    per-thread/per-category value.
 104  *
 105  * 3a and 3b) An implementation of POSIX 2008 thread-safe locale handling,
 106  *    hiding from the programmer the completely different API for this.
 107  *    This automatically makes almost all code thread-safe without need for
 108  *    changes.  This implementation is chosen on threaded perls when the
 109  *    platform properly supports the POSIX 2008 functions, and when there is no
 110  *    manual override to the contrary passed to Configure.
 111  *
 112  *    3a) is when the platform has a documented reliable querylocale() function
 113  *        or equivalent that is selected to be used.
 114  *    3b) is when we have to emulate that functionality.
 115  *
 116  *    Unfortunately, it seems that some platforms that claim to support these
 117  *    are buggy, in one way or another.  There are workarounds encoded here,
 118  *    where feasible, for platforms where the bugs are amenable to that
 119  *    (glibc, for example).  But other platforms instead don't use this
 120  *    implementation.
 121  *
 122  * z/OS (os390) is an outlier.  Locales really don't work under threads when
 123  * either the radix character isn't a dot, or attempts are made to change
 124  * locales after the first thread is created.  The reason is that IBM has made
 125  * it thread-safe by refusing to change locales (returning failure if
 126  * attempted) any time after an application has called pthread_create() to
 127  * create another thread.  The expectation is that an application will set up
 128  * its locale information before the first fork, and be stable thereafter.  But
 129  * perl toggles LC_NUMERIC if the locale's radix character isn't a dot, as do
 130  * the other toggles, which are less common.
 131  *
 132  * Associated with each implementation are three sets of macros that translate
 133  * a consistent API into what that implementation needs.  Each set consists of
 134  * three macros with the suffixes:
 135  *  _c  Means the argument is a locale category number known at compile time.
 136  *          An example would be LC_TIME.  This token is a compile-time constant
 137  *          and can be passed to a '_c' macro.
 138  *  _r  Means the argument is a locale category number whose value might not be
 139  *      known until runtime
 140  *  _i  Means the argument is our internal index of a locale category
 141  *
 142  * The three sets are:    ('_X'  means one of '_c', '_r', '_i')
 143  * 1) bool_setlocale_X()
 144  *      This calls the appropriate setlocale()-equivalent for the
 145  *      implementation, with the category and new locale.  The input locale is
 146  *      not necessarily valid, so the return is true or false depending on
 147  *      whether or not the setlocale() succeeded.  This is not used for
 148  *      querying the locale, so the input locale must not be NULL.
 149  *
 150  *      This macro is suitable for toggling the locale back and forth during an
 151  *      operation.  For example, the names of days and months under LC_TIME are
 152  *      strings that are also subject to LC_CTYPE.  If the locales of these two
 153  *      categories differ, mojibake can result on many platforms.  The code
 154  *      here will toggle LC_CTYPE into the locale of LC_TIME temporarily to
 155  *      avoid this.
 156  *
 157  *      Several categories require extra work when their locale is changed.
 158  *      LC_CTYPE, for example, requires the calculation of the table of which
 159  *      characters fold to which others under /i pattern matching or fc(), as
 160  *      folding is not a concept in POSIX.  This table isn't needed when the
 161  *      LC_CTYPE locale gets toggled during an operation, and will be toggled
 162  *      back before return to the caller.  To save work that would be
 163  *      discarded, the bool_setlocale_X() implementations don't do this extra
 164  *      work.  Instead, there is a separate function for just this purpose to
 165  *      be done before control is transferred back to the external caller.  All
 166  *      categories that have such requirements have such a function.  The
 167  *      update_functions[] array contains pointers to them (or NULL for
 168  *      categories which don't need a function).
 169  *
 170  *      Care must be taken to remember to call the separate function before
 171  *      returning to an external caller, and to not use things it updates
 172  *      before its call.  An alternative approach would be to have
 173  *      bool_setlocale_X() always call the update, which would return
 174  *      immediately if a flag wasn't set indicating it was time to actually
 175  *      perform it.
 176  *
 177  * 2) void_setlocale_X()
 178  *      This is like bool_setlocale_X(), but it is used only when it is
 179  *      expected that the call must succeed, or something is seriously wrong.
 180  *      A panic is issued if it fails.  The caller uses this form when it just
 181  *      wants to assume things worked.
 182  *
 183  * 3) querylocale_X()
 184  *      This returns a string that specifies the current locale for the given
 185  *      category given by the input argument.  The string is safe from other
 186  *      threads zapping it, and the caller need not worry about freeing it, but
 187  *      it may be mortalized, so must be copied if you need to preserve it
 188  *      across calls, or long term.  This returns the actual current locale,
 189  *      not the nominal.  These differ, for example, when LC_NUMERIC is
 190  *      supposed to be a locale whose decimal radix character is a comma.  As
 191  *      mentioned above, Perl actually keeps this category set to C in such
 192  *      circumstances so that XS code can just assume a dot radix character.
 193  *      querylocale_X() returns the locale that libc has stored at this moment,
 194  *      so most of the time will return a locale whose radix character is a
 195  *      dot.  The macro query_nominal_locale_i() can be used to get the nominal
 196  *      locale that an external caller would expect, for all categories except
 197  *      LC_ALL.  For that, you can use the function
 198  *      S_calculate_LC_ALL_string().  Or S_native_querylocale_i() will operate
 199  *      on any category.
 200  *
 201  * The underlying C API that this implements uses category numbers, hence the
 202  * code is structured to use '_r' at the API level to convert to indexes, which
 203  * are then used internally with the '_i' forms.
 204  *
 205  * The splitting apart into setting vs querying means that the return value of
 206  * the bool macros is not subject to potential clashes with other threads,
 207  * eliminating any need for the calling code to worry about that and get it
 208  * wrong.  Whereas, you do have to think about thread interactions when using a
 209  * query.
 210  *
 211  * Additionally, for the implementations where there aren't any complications,
 212  * a setlocale_i() is defined that is like plain setlocale(), returning the new
 213  * locale.  Thus it combines a bool_setlocale_X() with a querylocale_X().  It
 214  * is used only for performance on implementations that allow it, such as
 215  * non-threaded perls.
 216  *
 217  * There are also a few other macros herein that use this naming convention to
 218  * describe their category parameter.
 219  *
 220  * Relevant Configure options
 221  *
 222  *      -Accflags=-DNO_LOCALE
 223  *          This compiles perl to always use the C locale, ignoring any
 224  *          attempts to change it.  This could be useful on platforms with a
 225  *          crippled locale implementation.
 226  *
 227  *      -Accflags=-DNO_THREAD_SAFE_LOCALE
 228  *          Even if thread-safe operations are available on this platform and
 229  *          would otherwise be used (because this is a perl with multiplicity),
 230  *          perl is compiled to not use them.  This could be useful on
 231  *          platforms where the libc is buggy.
 232  *
 233  *      -Accflags=-DNO_POSIX_2008_LOCALE
 234  *          Even if the libc locale operations specified by the Posix 2008
 235  *          Standard are available on this platform and would otherwise be used
 236  *          (because this is a perl with multiplicity), perl is compiled to not
 237  *          use them.  This could be useful on platforms where the libc is
 238  *          buggy.  This is like NO_THREAD_SAFE_LOCALE, but has no effect on
 239  *          platforms that don't have these functions.
 240  *
 241  *      -Accflags=-DUSE_POSIX_2008_LOCALE
 242  *          Normally, setlocale() is used for locale operations on perls
 243  *          compiled without multiplicity.  This option causes the locale
 244  *          operations defined by the Posix 2008 Standard to always be used
 245  *          instead.  This could be useful on platforms where the libc
 246  *          setlocale() is buggy.
 247  *
 248  *      -Accflags=-DNO_THREAD_SAFE_QUERYLOCALE
 249  *          This applies only to platforms that have a querylocale() libc
 250  *          function.  perl assumes that that function is thread-safe, unless
 251  *          overridden by this, typically in a hints file.  When overridden,
 252  *          querylocale() is called only while the locale mutex is locked, and
 253  *          the result is copied to a per-thread place before unlocking.
 254  *
 255  *      -Accflags=-DUSE_NL_LOCALE_NAME
 256  *          glibc has an undocumented equivalent function to querylocale().  It
 257  *          currently isn't used by default because it is undocumented.  But
 258  *          testing hasn't found any problems with it.  Using this Configure
 259  *          option enables it on systems that have it (with no effect on
 260  *          systems lacking it).  Enabling this removes the need for perl
 261  *          to keep its own records, hence is more efficient and guaranteed to
 262  *          be accurate.
 263  *
 264  *      -Accflags=-DNO_LOCALE_CTYPE
 265  *      -Accflags=-DNO_LOCALE_NUMERIC
 266  *          etc.
 267  *
 268  *          If the named category(ies) does(do) not exist on this platform,
 269  *          these have no effect.  Otherwise they cause perl to be compiled to
 270  *          always keep the named category(ies) in the C locale.
 271  *
 272  *      -Accflags=-DHAS_BROKEN_SETLOCALE_QUERY_LC_ALL
 273  *          This would be set in a hints file to tell perl that doing a libc
 274  *              setlocale(LC_ALL, NULL)
 275  *          can give erroneous results, and perl will compensate to get the
 276  *          correct results.  This is known to be a problem in earlier AIX
 277  *          versions
 278  *
 279  *      -Accflags=-DHAS_LF_IN_SETLOCALE_RETURN
 280  *          This would be set in a hints file to tell perl that a libc
 281  *          setlocale() can return results containing \n characters that need
 282  *          to be stripped off.  khw believes there aren't any such platforms
 283  *          still in existence.
 284  *
 285  *      -Accflags=USE_FAKE_LC_ALL_POSITIONAL_NOTATION
 286  *          This is used when developing Perl on a platform that uses
 287  *          'name=value;' notation to represent LC_ALL when not all categories
 288  *          are the same.  When so compiled, much of the code gets compiled
 289  *          and exercised that applies to platforms that instead use positional
 290  *          notation.  This allows for finding many bugs in that portion of the
 291  *          implementation, without having to access such a platform.
 292  *
 293  *      -Accflags=-DWIN32_USE_FAKE_OLD_MINGW_LOCALES
 294  *          This is used when developing Perl on a non-Windows platform to
 295  *          compile and exercise much of the locale-related code that instead
 296  *          applies to MingW platforms that don't use the more modern UCRT
 297  *          library.  This allows for finding many bugs in that portion of the
 298  *          implementation, without having to access such a platform.
 299  */
 300
 301 /* If the environment says to, we can output debugging information during
 302  * initialization.  This is done before option parsing, and before any thread
 303  * creation, so can be a file-level static.  (Must come before #including
 304  * perl.h) */
 305 #include "config.h"
 306
 307 /* Returns the Unix errno portion; ignoring any others.  This is a macro here
 308  * instead of putting it into perl.h, because unclear to khw what should be
 309  * done generally. */
 310 #define GET_ERRNO   saved_errno
 311
 312 #ifdef DEBUGGING
 313 static int debug_initialization = 0;
 314 #  define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
 315 #  define DEBUG_LOCALE_INITIALIZATION_  debug_initialization
 316
 317 #  ifdef HAS_EXTENDED_OS_ERRNO
 318      /* Output the non-zero errno and/or the non-zero extended errno */
 319 #    define DEBUG_ERRNO                                                     \
 320         dSAVE_ERRNO; dTHX;                                                  \
 321         int extended = get_extended_os_errno();                             \
 322         const char * errno_string;                                          \
 323         if (GET_ERRNO == 0) { /* Skip output if both errno types are 0 */   \
 324             if (LIKELY(extended == 0)) errno_string = "";                   \
 325             else errno_string = Perl_form(aTHX_ "; $^E=%d", extended);      \
 326         }                                                                   \
 327         else if (LIKELY(extended == GET_ERRNO))                             \
 328             errno_string = Perl_form(aTHX_ "; $!=%d", GET_ERRNO);           \
 329         else errno_string = Perl_form(aTHX_ "; $!=%d, $^E=%d",              \
 330                                                     GET_ERRNO, extended);
 331 #  else
 332      /* Output the errno, if non-zero */
 333 #    define DEBUG_ERRNO                                                     \
 334         dSAVE_ERRNO;                                                        \
 335         const char * errno_string = "";                                     \
 336         if (GET_ERRNO != 0) {                                               \
 337             dTHX;                                                           \
 338             errno_string = Perl_form(aTHX_ "; $!=%d", GET_ERRNO);           \
 339         }
 340 #  endif
 341
 342 /* Automatically include the caller's file, and line number in debugging output;
 343  * and the errno (and/or extended errno) if non-zero.  On threaded perls add
 344  * the aTHX too. */
 345 #  if defined(USE_ITHREADS) && ! defined(NO_LOCALE_THREADS)
 346 #    define DEBUG_PRE_STMTS                                                 \
 347         DEBUG_ERRNO;                                                        \
 348         PerlIO_printf(Perl_debug_log, "\n%s: %" LINE_Tf ": 0x%p%s: ",       \
 349                                       __FILE__, (line_t)__LINE__, aTHX_     \
 350                                       errno_string);
 351 #  else
 352 #    define DEBUG_PRE_STMTS                                                 \
 353         DEBUG_ERRNO;                                                        \
 354         PerlIO_printf(Perl_debug_log, "\n%s: %" LINE_Tf "%s: ",             \
 355                                       __FILE__, (line_t)__LINE__,           \
 356                                       errno_string);
 357 #  endif
 358 #  define DEBUG_POST_STMTS  RESTORE_ERRNO;
 359 #else
 360 #  define debug_initialization 0
 361 #  define DEBUG_INITIALIZATION_set(v)
 362 #  define DEBUG_PRE_STMTS
 363 #  define DEBUG_POST_STMTS
 364 #endif
 365
 366 #include "EXTERN.h"
 367 #define PERL_IN_LOCALE_C
 368 #include "perl.h"
 369
 370 #ifdef WIN32_USE_FAKE_OLD_MINGW_LOCALES
 371
 372    /* Use -Accflags=-DWIN32_USE_FAKE_OLD_MINGW_LOCALES on a POSIX or *nix box
 373     * to get a semblance of pretending the locale handling is that of a MingW
 374     * that doesn't use UCRT (hence 'OLD' in the name).  This exercizes code
 375     * paths that are not compiled on non-Windows boxes, and allows for ASAN
 376     * and PERL_MEMLOG.  This is thus a way to see if locale.c on Windows is
 377     * likely going to compile, without having to use a real Win32 box.  And
 378     * running the test suite will verify to a large extent our logic and memory
 379     * allocation handling for such boxes.  Of course the underlying calls are
 380     * to the POSIX libc, so any differences in implementation between those and
 381     * the Windows versions will not be caught by this. */
 382
 383 #  define WIN32
 384 #  undef P_CS_PRECEDES
 385 #  undef CURRENCY_SYMBOL
 386 #  define CP_UTF8 -1
 387 #  undef _configthreadlocale
 388 #  define _configthreadlocale(arg) NOOP
 389
 390 #  define MultiByteToWideChar(cp, flags, byte_string, m1, wstring, req_size) \
 391                     (mbsrtowcs(wstring, &(byte_string), req_size, NULL) + 1)
 392 #  define WideCharToMultiByte(cp, flags, wstring, m1, byte_string,          \
 393                               req_size, default_char, found_default_char)   \
 394                     (wcsrtombs(byte_string, &(wstring), req_size, NULL) + 1)
 395
 396 #  ifdef USE_LOCALE
 397
 398 static const wchar_t * wsetlocale_buf = NULL;
 399 static Size_t wsetlocale_buf_size = 0;
 400 static PerlInterpreter * wsetlocale_buf_aTHX = NULL;
 401
 402 STATIC
 403 const wchar_t *
 404 S_wsetlocale(const int category, const wchar_t * wlocale)
 405 {
 406     /* Windows uses a setlocale that takes a wchar_t* locale.  Other boxes
 407      * don't have this, so this Windows replacement converts the wchar_t input
 408      * to plain 'char*', calls plain setlocale(), and converts the result back
 409      * to 'wchar_t*' */
 410
 411     const char * byte_locale = NULL;
 412     if (wlocale) {
 413         byte_locale = Win_wstring_to_byte_string(CP_UTF8, wlocale);
 414     }
 415
 416     const char * byte_result = setlocale(category, byte_locale);
 417     Safefree(byte_locale);
 418     if (byte_result == NULL) {
 419         return NULL;
 420     }
 421
 422     const wchar_t * wresult = Win_byte_string_to_wstring(CP_UTF8, byte_result);
 423
 424     if (! wresult) {
 425         return NULL;
 426     }
 427
 428     /* Emulate a global static memory return from wsetlocale().  This currently
 429      * leaks at process end; would require changing LOCALE_TERM to fix that */
 430     Size_t string_size = wcslen(wresult) + 1;
 431
 432     if (wsetlocale_buf_size == 0) {
 433         Newx(wsetlocale_buf, string_size, wchar_t);
 434         wsetlocale_buf_size = string_size;
 435
 436 #  ifdef MULTIPLICITY
 437
 438         dTHX;
 439         wsetlocale_buf_aTHX = aTHX;
 440
 441 #  endif
 442
 443     }
 444     else if (string_size > wsetlocale_buf_size) {
 445         Renew(wsetlocale_buf, string_size, wchar_t);
 446         wsetlocale_buf_size = string_size;
 447     }
 448
 449     Copy(wresult, wsetlocale_buf, string_size, wchar_t);
 450     Safefree(wresult);
 451
 452     return wsetlocale_buf;
 453 }
 454
 455 #  define _wsetlocale(category, wlocale)  S_wsetlocale(category, wlocale)
 456 #  endif
 457 #endif  /* WIN32_USE_FAKE_OLD_MINGW_LOCALES */
 458
 459 /* 'for' loop headers to hide the necessary casts */
 460 #define for_all_individual_category_indexes(i)                              \
 461     for (locale_category_index i = (locale_category_index) 0;               \
 462          i < LC_ALL_INDEX_;                                                 \
 463          i = (locale_category_index) ((int) i + 1))
 464
 465 #define for_all_but_0th_individual_category_indexes(i)                      \
 466     for (locale_category_index i = (locale_category_index) 1;               \
 467          i < LC_ALL_INDEX_;                                                 \
 468          i = (locale_category_index) ((int) i + 1))
 469
 470 #define for_all_category_indexes(i)                                         \
 471     for (locale_category_index i = (locale_category_index) 0;               \
 472          i <= LC_ALL_INDEX_;                                                \
 473          i = (locale_category_index) ((int) i + 1))
 474
 475 #ifdef USE_LOCALE
 476 #  if defined(USE_FAKE_LC_ALL_POSITIONAL_NOTATION) && defined(LC_ALL)
 477
 478 /* This simulates an underlying positional notation for LC_ALL when compiled on
 479  * a system that uses name=value notation.  Use this to develop on Linux and
 480  * make a quick check that things have some chance of working on a positional
 481  * box.  Enable by adding to the Congfigure parameters:
 482  *      -Accflags=USE_FAKE_LC_ALL_POSITIONAL_NOTATION
 483  *
 484  * NOTE it redefines setlocale() and usequerylocale()
 485  * */
 486
 487 STATIC const char *
 488 S_positional_name_value_xlation(const char * locale, bool direction)
 489 {   /* direction == 1 is from name=value to positional
 490        direction == 0 is from positional to name=value */
 491     assert(locale);
 492
 493     dTHX;
 494     const char * individ_locales[LC_ALL_INDEX_] = { NULL };
 495
 496     /* This parses either notation */
 497     switch (parse_LC_ALL_string(locale,
 498                                 (const char **) &individ_locales,
 499                                 no_override,  /* Handled by other code */
 500                                 false,      /* Return only [0] if suffices */
 501                                 false,      /* Don't panic on error */
 502                                 __LINE__))
 503     {
 504       default:      /* Some compilers don't realize that below is the complete
 505                        list of the available enum values */
 506       case invalid:
 507         return NULL;
 508
 509       case no_array:
 510         return locale;
 511       case only_element_0:
 512         SAVEFREEPV(individ_locales[0]);
 513         return individ_locales[0];
 514       case full_array:
 515        {
 516         calc_LC_ALL_format  format = (direction)
 517                                      ? EXTERNAL_FORMAT_FOR_SET
 518                                      : INTERNAL_FORMAT;
 519         const char * retval = calculate_LC_ALL_string(individ_locales,
 520                                                       format,
 521                                                       WANT_TEMP_PV,
 522                                                       __LINE__);
 523
 524         for_all_individual_category_indexes(i) {
 525             Safefree(individ_locales[i]);
 526         }
 527
 528         return retval;
 529        }
 530     }
 531 }
 532
 533 STATIC const char *
 534 S_positional_setlocale(int cat, const char * locale)
 535 {
 536     if (cat != LC_ALL) return setlocale(cat, locale);
 537
 538     if (locale && strNE(locale, "")) {
 539         locale = S_positional_name_value_xlation(locale, 0);
 540         if (! locale) return NULL;
 541     }
 542
 543     locale = setlocale(cat, locale);
 544     if (locale == NULL) return NULL;
 545     return S_positional_name_value_xlation(locale, 1);
 546 }
 547
 548 #    undef setlocale
 549 #    define setlocale(a,b)  S_positional_setlocale(a,b)
 550 #    ifdef USE_POSIX_2008_LOCALE
 551
 552 STATIC locale_t
 553 S_positional_newlocale(int mask, const char * locale, locale_t base)
 554 {
 555     assert(locale);
 556
 557     if (mask != LC_ALL_MASK) return newlocale(mask, locale, base);
 558
 559     if (strNE(locale, "")) locale = S_positional_name_value_xlation(locale, 0);
 560     if (locale == NULL) return NULL;
 561     return newlocale(LC_ALL_MASK, locale, base);
 562 }
 563
 564 #    undef newlocale
 565 #    define newlocale(a,b,c)  S_positional_newlocale(a,b,c)
 566 #    endif
 567 #  endif
 568 #endif  /* End of fake positional notation */
 569
 570 #include "reentr.h"
 571
 572 #ifdef I_WCHAR
 573 #  include <wchar.h>
 574 #endif
 575 #ifdef I_WCTYPE
 576 #  include <wctype.h>
 577 #endif
 578
 579  /* The main errno that gets used is this one, on platforms that support it */
 580 #ifdef EINVAL
 581 #  define SET_EINVAL  SETERRNO(EINVAL, LIB_INVARG)
 582 #else
 583 #  define SET_EINVAL
 584 #endif
 585
 586 /* If we have any of these library functions, we can reliably determine is a
 587  * locale is a UTF-8 one or not.  And if we aren't using locales at all, we act
 588  * as if everything is the C locale, so the answer there is always "No, it
 589  * isn't UTF-8"; this too is reliably accurate */
 590 #if   defined(HAS_SOME_LANGINFO) || defined(HAS_MBTOWC)                 \
 591    || defined(HAS_MBRTOWC) || ! defined(USE_LOCALE)
 592 #  define HAS_RELIABLE_UTF8NESS_DETERMINATION
 593 #endif
 594
 595 /* This is a starting guess as to when this is true.  It definititely isn't
 596  * true on *BSD where positional LC_ALL notation is used.  Likely this will end
 597  * up being defined in hints files. */
 598 #ifdef PERL_LC_ALL_USES_NAME_VALUE_PAIRS
 599 #  define NEWLOCALE_HANDLES_DISPARATE_LC_ALL
 600 #endif
 601
 602 /* But regardless, we have to look at individual categories if some are
 603  * ignored.  */
 604 #ifdef HAS_IGNORED_LOCALE_CATEGORIES_
 605 #  undef NEWLOCALE_HANDLES_DISPARATE_LC_ALL
 606 #endif
 607 #ifdef USE_LOCALE
 608
 609 /* Not all categories need be set to the same locale.  This macro determines if
 610  * 'name' which represents LC_ALL is uniform or disparate.  There are two
 611  * situations: 1) the platform uses unordered name=value pairs; 2) the platform
 612  * uses ordered positional values, with a separator string between them */
 613 #  ifdef PERL_LC_ALL_SEPARATOR   /* positional */
 614 #    define is_disparate_LC_ALL(name)  cBOOL(instr(name, PERL_LC_ALL_SEPARATOR))
 615 #  else     /* name=value */
 616
 617     /* In the, hopefully never occurring, event that the platform doesn't use
 618      * either mechanism for disparate LC_ALL's, assume the name=value pairs
 619      * form, rather than taking the extreme step of refusing to compile.  Many
 620      * programs won't have disparate locales, so will generally work */
 621 #    define PERL_LC_ALL_SEPARATOR  ";"
 622 #    define is_disparate_LC_ALL(name)  cBOOL(   strchr(name, ';')   \
 623                                              && strchr(name, '='))
 624 #  endif
 625
 626 /* It is possible to compile perl to always keep any individual category in the
 627  * C locale.  This would be done where the implementation on a platform is
 628  * flawed or incomplete.  At the time of this writing, for example, OpenBSD has
 629  * not implemented LC_COLLATE beyond the C locale.  The 'category_available[]'
 630  * table is a bool that says whether a category is changeable, or must be kept
 631  * in C.  This macro substitutes C for the locale appropriately, expanding to
 632  * nothing on the more typical case where all possible categories present on
 633  * the platform are handled. */
 634 #  ifdef HAS_IGNORED_LOCALE_CATEGORIES_
 635 #    define need_to_override_category(i)  (! category_available[i])
 636 #    define override_ignored_category(i, new_locale)                        \
 637                     ((need_to_override_category(i)) ? "C" : (new_locale))
 638 #  else
 639 #    define need_to_override_category(i)  0
 640 #    define override_ignored_category(i, new_locale)  (new_locale)
 641 #  endif
 642
 643 PERL_STATIC_INLINE const char *
 644 S_mortalized_pv_copy(pTHX_ const char * const pv)
 645 {
 646     PERL_ARGS_ASSERT_MORTALIZED_PV_COPY;
 647
 648     /* Copies the input pv, and arranges for it to be freed at an unspecified
 649      * later time. */
 650
 651     if (pv == NULL) {
 652         return NULL;
 653     }
 654
 655     const char * copy = savepv(pv);
 656     SAVEFREEPV(copy);
 657     return copy;
 658 }
 659
 660 #endif
 661
 662 /* Default values come from the C locale */
 663 #define C_codeset "ANSI_X3.4-1968" /* Only in some Configurations, and usually
 664                                       a single instance, so is a #define */
 665 static const char C_decimal_point[] = ".";
 666
 667 #if (defined(USE_LOCALE_NUMERIC) && ! defined(TS_W32_BROKEN_LOCALECONV))    \
 668  || ! (   defined(USE_LOCALE_NUMERIC)                                       \
 669        && (defined(HAS_SOME_LANGINFO) || defined(HAS_LOCALECONV)))
 670 static const char C_thousands_sep[] = "";
 671 #endif
 672
 673 /* Is the C string input 'name' "C" or "POSIX"?  If so, and 'name' is the
 674  * return of setlocale(), then this is extremely likely to be the C or POSIX
 675  * locale.  However, the output of setlocale() is documented to be opaque, but
 676  * the odds are extremely small that it would return these two strings for some
 677  * other locale.  Note that VMS includes many non-ASCII characters in these two
 678  * locales as controls and punctuation (below are hex bytes):
 679  *   cntrl:  84-97 9B-9F
 680  *   punct:  A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
 681  * Oddly, none there are listed as alphas, though some represent alphabetics
 682  * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
 683 #define isNAME_C_OR_POSIX(name)                                              \
 684                              (   (name) != NULL                              \
 685                               && (( *(name) == 'C' && (*(name + 1)) == '\0') \
 686                                    || strEQ((name), "POSIX")))
 687
 688 #if defined(HAS_NL_LANGINFO_L) || defined(HAS_NL_LANGINFO)
 689 #  define HAS_SOME_LANGINFO
 690 #endif
 691
 692 #define my_langinfo_c(item, category, locale, retbufp, retbuf_sizep, utf8ness) \
 693             my_langinfo_i(item, category##_INDEX_, locale, retbufp,            \
 694                                                       retbuf_sizep,  utf8ness)
 695 #ifdef USE_LOCALE
 696 #  ifdef DEBUGGING
 697 #    define setlocale_debug_string_i(index, locale, result)                 \
 698             my_setlocale_debug_string_i(index, locale, result, __LINE__)
 699 #    define setlocale_debug_string_c(category, locale, result)              \
 700                 setlocale_debug_string_i(category##_INDEX_, locale, result)
 701 #    define setlocale_debug_string_r(category, locale, result)              \
 702              setlocale_debug_string_i(get_category_index(category),         \
 703                                       locale, result)
 704 #  endif
 705
 706 #  define toggle_locale_i(index, locale)                                    \
 707                  S_toggle_locale_i(aTHX_ index, locale, __LINE__)
 708 #  define toggle_locale_c(cat, locale)  toggle_locale_i(cat##_INDEX_, locale)
 709 #  define restore_toggled_locale_i(index, locale)                           \
 710                  S_restore_toggled_locale_i(aTHX_ index, locale, __LINE__)
 711 #  define restore_toggled_locale_c(cat, locale)                             \
 712                              restore_toggled_locale_i(cat##_INDEX_, locale)
 713
 714 /* On systems without LC_ALL, pretending it exists anyway simplifies things.
 715  * Choose a value for it that is very unlikely to clash with any actual
 716  * category */
 717 #  define FAKE_LC_ALL  PERL_INT_MIN
 718
 719 /* Below are parallel arrays for locale information indexed by our mapping of
 720  * category numbers into small non-negative indexes.  locale_table.h contains
 721  * an entry like this for each individual category used on this system:
 722  *      PERL_LOCALE_TABLE_ENTRY(CTYPE, S_new_ctype)
 723  *
 724  * Each array redefines PERL_LOCALE_TABLE_ENTRY to generate the information
 725  * needed for that array, and #includes locale_table.h to get the valid
 726  * categories.
 727  *
 728  * An entry for the conglomerate category LC_ALL is added here, immediately
 729  * following the individual categories.  (The treatment for it varies, so can't
 730  * be in locale_table.h.)
 731  *
 732  * Following this, each array ends with an entry for illegal categories.  All
 733  * category numbers unknown to perl get mapped to this entry.  This is likely
 734  * to be a parameter error from the calling program; but it could be that this
 735  * platform has a category we don't know about, in which case it needs to be
 736  * added, using the paradigm of one of the existing categories. */
 737
 738 /* The first array is the locale categories perl uses on this system, used to
 739  * map our index back to the system's category number. */
 740 STATIC const int categories[] = {
 741
 742 #  undef PERL_LOCALE_TABLE_ENTRY
 743 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)  LC_ ## name,
 744 #  include "locale_table.h"
 745
 746 #  ifdef LC_ALL
 747     LC_ALL,
 748 #  else
 749     FAKE_LC_ALL,
 750 #  endif
 751
 752    (FAKE_LC_ALL + 1)    /* Entry for unknown category; this number is unlikely
 753                            to clash with a real category */
 754 };
 755
 756 # define GET_NAME_AS_STRING(token)  # token
 757 # define GET_LC_NAME_AS_STRING(token) GET_NAME_AS_STRING(LC_ ## token)
 758
 759 /* The second array is the category names. */
 760 STATIC const char * const category_names[] = {
 761
 762 #  undef PERL_LOCALE_TABLE_ENTRY
 763 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)  GET_LC_NAME_AS_STRING(name),
 764 #  include "locale_table.h"
 765
 766 #  ifdef LC_ALL
 767 #    define LC_ALL_STRING  "LC_ALL"
 768 #  else
 769 #    define LC_ALL_STRING  "If you see this, it is a bug in perl;"      \
 770                            " please report it via perlbug"
 771 #  endif
 772
 773     LC_ALL_STRING,
 774
 775 #  define LC_UNKNOWN_STRING  "Locale category unknown to Perl; if you see"  \
 776                              " this, it is a bug in perl; please report it" \
 777                              " via perlbug"
 778     LC_UNKNOWN_STRING
 779 };
 780
 781 STATIC const Size_t category_name_lengths[] = {
 782
 783 #  undef PERL_LOCALE_TABLE_ENTRY
 784 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)                          \
 785                                     STRLENs(GET_LC_NAME_AS_STRING(name)),
 786 #  include "locale_table.h"
 787
 788     STRLENs(LC_ALL_STRING),
 789     STRLENs(LC_UNKNOWN_STRING)
 790 };
 791
 792 /* Each entry includes space for the '=' and ';' */
 793 #  undef PERL_LOCALE_TABLE_ENTRY
 794 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)                          \
 795                                 + STRLENs(GET_LC_NAME_AS_STRING(name)) + 2
 796
 797 STATIC const Size_t lc_all_boiler_plate_length = 1  /* space for trailing NUL */
 798 #  include "locale_table.h"
 799 ;
 800
 801 /* A few categories require additional setup when they are changed.  This table
 802  * points to the functions that do that setup */
 803 STATIC void (*update_functions[]) (pTHX_ const char *, bool force) = {
 804
 805 #  undef PERL_LOCALE_TABLE_ENTRY
 806 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)  call_back,
 807 #  include "locale_table.h"
 808
 809     S_new_LC_ALL,
 810     NULL,   /* No update for unknown category */
 811 };
 812
 813 #  if defined(HAS_IGNORED_LOCALE_CATEGORIES_)
 814
 815 /* Indicates if each category on this platform is available to use not in
 816  * the C locale */
 817 STATIC const bool category_available[] = {
 818
 819 #  undef PERL_LOCALE_TABLE_ENTRY
 820 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)  LC_ ## name ## _AVAIL_,
 821 #  include "locale_table.h"
 822
 823 #  ifdef LC_ALL
 824     true,
 825 #  else
 826     false,
 827 #  endif
 828
 829     false   /* LC_UNKNOWN_AVAIL_ */
 830 };
 831
 832 #  endif
 833 #  if defined(USE_POSIX_2008_LOCALE)
 834
 835 STATIC const int category_masks[] = {
 836
 837 #    undef PERL_LOCALE_TABLE_ENTRY
 838 #    define PERL_LOCALE_TABLE_ENTRY(name, call_back)  LC_ ## name ## _MASK,
 839 #    include "locale_table.h"
 840
 841     LC_ALL_MASK,    /* Will rightly refuse to compile unless this is defined */
 842     0               /* Empty mask for unknown category */
 843 };
 844
 845 #  endif
 846 #  if ! defined(PERL_LC_ALL_USES_NAME_VALUE_PAIRS)
 847
 848 /* On platforms that use positional notation for expressing LC_ALL, this maps
 849  * the position of each category to our corresponding internal index for it.
 850  * This is initialized at run time if needed.  LC_ALL_INDEX_ is not legal for
 851  * an individual locale, hence marks the elements here as not actually
 852  * initialized. */
 853 STATIC
 854 unsigned int
 855 map_LC_ALL_position_to_index[LC_ALL_INDEX_] = { LC_ALL_INDEX_ };
 856
 857 #  endif
 858 #endif
 859 #if defined(USE_LOCALE) || defined(DEBUGGING)
 860
 861 STATIC const char *
 862 S_get_displayable_string(pTHX_
 863                          const char * const s,
 864                          const char * const e,
 865                          const bool is_utf8)
 866 {
 867     PERL_ARGS_ASSERT_GET_DISPLAYABLE_STRING;
 868
 869     if (e <= s) {
 870         return "";
 871     }
 872
 873     const char * t = s;
 874     bool prev_was_printable = TRUE;
 875     bool first_time = TRUE;
 876     char * ret;
 877
 878     /* Worst case scenario: All are non-printable so have a blank between each.
 879      * If UTF-8, all are the largest possible code point; otherwise all are a
 880      * single byte.  '(2 + 1)'  is from each byte takes 2 characters to
 881      * display, and a blank (or NUL for the final one) after it */
 882     const Size_t size = (e - s) * (2 + 1) * ((is_utf8) ? UVSIZE : 1);
 883     Newxz(ret, size, char);
 884     SAVEFREEPV(ret);
 885
 886     while (t < e) {
 887         UV cp = (is_utf8)
 888                 ?  utf8_to_uvchr_buf((U8 *) t, e, NULL)
 889                 : * (U8 *) t;
 890         if (isPRINT(cp)) {
 891             if (! prev_was_printable) {
 892                 my_strlcat(ret, " ", size);
 893             }
 894
 895             /* Escape these to avoid any ambiguity */
 896             if (cp == ' ' || cp == '\\') {
 897                 my_strlcat(ret, "\\", size);
 898             }
 899             my_strlcat(ret, Perl_form(aTHX_ "%c", (U8) cp), size);
 900             prev_was_printable = TRUE;
 901         }
 902         else {
 903             if (! first_time) {
 904                 my_strlcat(ret, " ", size);
 905             }
 906             my_strlcat(ret, Perl_form(aTHX_ "%02" UVXf, cp), size);
 907             prev_was_printable = FALSE;
 908         }
 909         t += (is_utf8) ? UTF8SKIP(t) : 1;
 910         first_time = FALSE;
 911     }
 912
 913     return ret;
 914 }
 915
 916 #endif
 917 #ifdef USE_LOCALE
 918
 919 # define get_category_index(cat) get_category_index_helper(cat, NULL, __LINE__)
 920
 921 STATIC locale_category_index
 922 S_get_category_index_helper(pTHX_ const int category, bool * succeeded,
 923                                   const line_t caller_line)
 924 {
 925     PERL_ARGS_ASSERT_GET_CATEGORY_INDEX_HELPER;
 926
 927     /* Given a category, return the equivalent internal index we generally use
 928      * instead, warn or panic if not found. */
 929
 930     locale_category_index i;
 931
 932 #  undef PERL_LOCALE_TABLE_ENTRY
 933 #  define PERL_LOCALE_TABLE_ENTRY(name, call_back)                          \
 934                     case LC_ ## name: i =  LC_ ## name ## _INDEX_; break;
 935
 936     switch (category) {
 937
 938 #  include "locale_table.h"
 939 #  ifdef LC_ALL
 940       case LC_ALL: i =  LC_ALL_INDEX_; break;
 941 #  endif
 942
 943       default: goto unknown_locale;
 944     }
 945
 946     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
 947                            "index of category %d (%s) is %d;"
 948                            " called from %" LINE_Tf "\n",
 949                            category, category_names[i], i, caller_line));
 950
 951     if (succeeded) {
 952         *succeeded = true;
 953     }
 954
 955     return i;
 956
 957   unknown_locale:
 958
 959     if (succeeded) {
 960         *succeeded = false;
 961         return LC_ALL_INDEX_;   /* Arbitrary */
 962     }
 963
 964     locale_panic_via_(Perl_form(aTHX_ "Unknown locale category %d", category),
 965                       __FILE__, caller_line);
 966     NOT_REACHED; /* NOTREACHED */
 967 }
 968
 969 #endif /* ifdef USE_LOCALE */
 970
 971 void
 972 Perl_force_locale_unlock(pTHX)
 973 {
 974     /* Remove any locale mutex, in preperation for an inglorious termination,
 975      * typically a  panic */
 976
 977 #if defined(USE_LOCALE_THREADS)
 978
 979     /* If recursively locked, clear all at once */
 980     if (PL_locale_mutex_depth > 1) {
 981         PL_locale_mutex_depth = 1;
 982     }
 983
 984     if (PL_locale_mutex_depth > 0) {
 985         LOCALE_UNLOCK_;
 986     }
 987
 988 #endif
 989
 990 }
 991
 992 #ifdef USE_POSIX_2008_LOCALE
 993
 994 STATIC locale_t
 995 S_use_curlocale_scratch(pTHX)
 996 {
 997     /* This function is used to hide from the caller the case where the current
 998      * locale_t object in POSIX 2008 is the global one, which is illegal in
 999      * many of the P2008 API calls.  This checks for that and, if necessary
1000      * creates a proper P2008 object.  Any prior object is deleted, as is any
1001      * remaining object during global destruction. */
1002
1003     locale_t cur = uselocale((locale_t) 0);
1004
1005     if (cur != LC_GLOBAL_LOCALE) {
1006         return cur;
1007     }
1008
1009     if (PL_scratch_locale_obj) {
1010         freelocale(PL_scratch_locale_obj);
1011     }
1012
1013     PL_scratch_locale_obj = duplocale(LC_GLOBAL_LOCALE);
1014     return PL_scratch_locale_obj;
1015 }
1016
1017 #endif
1018
1019 void
1020 Perl_locale_panic(const char * msg,
1021                   const line_t immediate_caller_line,
1022                   const char * const higher_caller_file,
1023                   const line_t higher_caller_line)
1024 {
1025     PERL_ARGS_ASSERT_LOCALE_PANIC;
1026     dTHX;
1027     dSAVE_ERRNO;
1028
1029     force_locale_unlock();
1030
1031 #ifdef USE_C_BACKTRACE
1032     dump_c_backtrace(Perl_debug_log, 20, 1);
1033 #endif
1034
1035     const char * called_by = "";
1036     if (   strNE(__FILE__, higher_caller_file)
1037         || immediate_caller_line != higher_caller_line)
1038     {
1039         called_by = Perl_form(aTHX_ "\nCalled by %s: %" LINE_Tf "\n",
1040                                     higher_caller_file, higher_caller_line);
1041     }
1042
1043     RESTORE_ERRNO;
1044
1045     const char * errno_text;
1046
1047 #ifdef HAS_EXTENDED_OS_ERRNO
1048
1049     const int extended_errnum = get_extended_os_errno();
1050     if (errno != extended_errnum) {
1051         errno_text = Perl_form(aTHX_ "; errno=%d, $^E=%d",
1052                                      errno, extended_errnum);
1053     }
1054     else
1055
1056 #endif
1057
1058     {
1059         errno_text = Perl_form(aTHX_ "; errno=%d", errno);
1060     }
1061
1062     /* diag_listed_as: panic: %s */
1063     Perl_croak(aTHX_ "%s: %" LINE_Tf ": panic: %s%s%s\n",
1064                      __FILE__, immediate_caller_line,
1065                      msg, errno_text, called_by);
1066 }
1067
1068 /* Macros to report and croak on an unexpected failure to set the locale.  The
1069  * via version has more stack trace information */
1070 #define setlocale_failure_panic_i(i, cur, fail, line, higher_line)          \
1071     setlocale_failure_panic_via_i(i, cur, fail, __LINE__, line,             \
1072                                   __FILE__, higher_line)
1073
1074 #define setlocale_failure_panic_c(cat, cur, fail, line, higher_line)        \
1075    setlocale_failure_panic_i(cat##_INDEX_, cur, fail, line, higher_line)
1076
1077 #if defined(USE_LOCALE)
1078
1079 /* Expands to the code to
1080  *      result = savepvn(s, len)
1081  * if the category whose internal index is 'i' doesn't need to be kept in the C
1082  * locale on this system, or if 'action is 'no_override'.  Otherwise it expands
1083  * to
1084  *      result = savepv("C")
1085  * unless 'action' isn't 'check_that_overridden', in which case if the string
1086  * 's' isn't already "C" it panics */
1087 #  ifndef HAS_IGNORED_LOCALE_CATEGORIES_
1088 #    define OVERRIDE_AND_SAVEPV(s, len, result, i, action)                  \
1089                                                   result = savepvn(s, len)
1090 #  else
1091 #    define OVERRIDE_AND_SAVEPV(s, len, result, i, action)                  \
1092         STMT_START {                                                        \
1093             if (LIKELY(   ! need_to_override_category(i)                    \
1094                        || action == no_override)) {                         \
1095                 result = savepvn(s, len);                                   \
1096             }                                                               \
1097             else {                                                          \
1098                 const char * temp = savepvn(s, len);                        \
1099                 result = savepv(override_ignored_category(i, temp));        \
1100                 if (action == check_that_overridden && strNE(result, temp)) { \
1101                     locale_panic_(Perl_form(aTHX_                           \
1102                                 "%s expected to be '%s', instead is '%s'",  \
1103                                 category_names[i], result, temp));          \
1104                 }                                                           \
1105                 Safefree(temp);                                             \
1106             }                                                               \
1107         } STMT_END
1108 #  endif
1109
1110 STATIC parse_LC_ALL_string_return
1111 S_parse_LC_ALL_string(pTHX_ const char * string,
1112                             const char ** output,
1113                             const parse_LC_ALL_STRING_action  override,
1114                             bool always_use_full_array,
1115                             const bool panic_on_error,
1116                             const line_t caller_line)
1117 {
1118     /* This function parses the value of the input 'string' which is expected
1119      * to be the representation of an LC_ALL locale, and splits the result into
1120      * the values for the individual component categories, returning those in
1121      * the 'output' array.  Each array value will be a savepv() copy that is
1122      * the responsibility of the caller to make sure gets freed
1123      *
1124      * The locale for each category is independent of the other categories.
1125      * Often, they are all the same, but certainly not always.  Perl, in fact,
1126      * usually keeps LC_NUMERIC in the C locale, regardless of the underlying
1127      * locale.  LC_ALL has to be able to represent the case of when not all
1128      * categories have the same locale.  Platforms have differing ways of
1129      * representing this.  Internally, this file uses the 'name=value;'
1130      * representation found on some platforms, so this function always looks
1131      * for and parses that.  Other platforms use a positional notation.  On
1132      * those platforms, this function also parses that form.  It examines the
1133      * input to see which form is being parsed.
1134      *
1135      * Often, all categories will have the same locale.  This is special cased
1136      * if 'always_use_full_array' is false on input:
1137      *      1) If the input 'string' is a single value, this function doesn't
1138      *         store anything into 'output', and returns 'no_array'
1139      *      2) Some platforms will return multiple occurrences of the same
1140      *         value rather than coalescing them down to a single one.  HP-UX
1141      *         is such a one.  This function will do that collapsing for you,
1142      *         returning 'only_element_0' and saving the single value in
1143      *         output[0], which the caller will need to arrange to be freed.
1144      *         The rest of output[] is undefined, and does not need to be
1145      *         freed.
1146      *
1147      * Otherwise, the input 'string' may not be valid.  This function looks
1148      * mainly for syntactic errors, and if found, returns 'invalid'.  'output'
1149      * will not be filled in in that case, but the input state of it isn't
1150      * necessarily preserved.  Turning on -DL debugging will give details as to
1151      * the error.  If 'panic_on_error' is 'true', the function panics instead
1152      * of returning on error, with a message giving the details.
1153      *
1154      * Otherwise, output[] will be filled with the individual locale names for
1155      * all categories on the system, 'full_array' will be returned, and the
1156      * caller needs to arrange for each to be freed.  This means that either at
1157      * least one category differed from the others, or 'always_use_full_array' was
1158      * true on input.
1159      *
1160      * perl may be configured to ignore changes to a category's locale to
1161      * non-C.  The parameter 'override' tells this function what to do when
1162      * encountering such an illegal combination:
1163      *
1164      *      no_override             indicates to take no special action
1165      *      override_if_ignored,    indicates to return 'C' instead of what the
1166      *                              input string actually says.
1167      *      check_that_overridden   indicates to panic if the string says the
1168      *                              category is not 'C'.  This is used when
1169      *                              non-C is very unexpected behavior.
1170      * */
1171
1172     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1173                            "Entering parse_LC_ALL_string; called from %"    \
1174                            LINE_Tf "\nnew='%s'\n", caller_line, string));
1175
1176 #  ifdef PERL_LC_ALL_USES_NAME_VALUE_PAIRS
1177
1178     const char separator[] = ";";
1179     const Size_t separator_len = 1;
1180     const bool single_component = (strchr(string, ';') == NULL);
1181
1182 #  else
1183
1184     /* It's possible (but quite unlikely) that the separator string is an '='
1185      * or a ';'.  Requiring both to be present for using the 'name=value;' form
1186      * properly handles those possibilities */
1187     const bool name_value = strchr(string, '=') && strchr(string, ';');
1188     const char * separator;
1189     Size_t separator_len;
1190     bool single_component;
1191     if (name_value) {
1192         separator = ";";
1193         separator_len = 1;
1194         single_component = false;   /* Since has both [;=], must be multi */
1195     }
1196     else {
1197         separator = PERL_LC_ALL_SEPARATOR;
1198         separator_len = STRLENs(PERL_LC_ALL_SEPARATOR);
1199         single_component = instr(string, separator) == NULL;
1200     }
1201
1202     Size_t component_number = 0;    /* Position in the parsing loop below */
1203
1204 #  endif
1205 #  ifndef HAS_IGNORED_LOCALE_CATEGORIES_
1206     PERL_UNUSED_ARG(override);
1207 #  else
1208
1209     /* Any ignored categories are to be set to "C", so if this single-component
1210      * LC_ALL isn't to C, it has both "C" and non-C, so isn't really a single
1211      * component.  All the non-ignored categories are set to the input
1212      * component, but the ignored ones are overridden to be C.
1213      *
1214      * This incidentally handles the case where the string is "".  The return
1215      * will be C for each ignored category and "" for the others.  Then the
1216      * caller can individually set each category, and get the right answer. */
1217     if (single_component && ! isNAME_C_OR_POSIX(string)) {
1218         for_all_individual_category_indexes(i) {
1219            OVERRIDE_AND_SAVEPV(string, strlen(string), output[i], i, override);
1220         }
1221
1222         return full_array;
1223     }
1224
1225 #  endif
1226
1227     if (single_component) {
1228         if (! always_use_full_array) {
1229             return no_array;
1230         }
1231
1232         for_all_individual_category_indexes(i) {
1233             output[i] = savepv(string);
1234         }
1235
1236         return full_array;
1237     }
1238
1239     /* Here the input is multiple components.  Parse through them.  (It is
1240      * possible that these components are all the same, so we check, and if so,
1241      * return just the 0th component (unless 'always_use_full_array' is true)
1242      *
1243      * This enum notes the possible errors findable in parsing */
1244     enum {
1245             incomplete,
1246             no_equals,
1247             unknown_category,
1248             contains_LC_ALL_element
1249     } error;
1250
1251     /* Keep track of the categories we have encountered so far */
1252     bool seen[LC_ALL_INDEX_] = { false };
1253
1254     Size_t index;           /* Our internal index for the current category */
1255     const char * s = string;
1256     const char * e = s + strlen(string);
1257     const char * category_end = NULL;
1258     const char * saved_first = NULL;
1259
1260     /* Parse the input locale string */
1261     while (s < e) {
1262
1263         /* 'separator' has been set up to delimit the components */
1264         const char * next_sep = instr(s, separator);
1265         if (! next_sep) {   /* At the end of the input */
1266             next_sep = e;
1267         }
1268
1269 #  ifndef PERL_LC_ALL_USES_NAME_VALUE_PAIRS
1270
1271         if (! name_value) {
1272             /* Get the index of the category in this position */
1273             index = map_LC_ALL_position_to_index[component_number++];
1274         }
1275         else
1276
1277 #  endif
1278
1279         {   /* Get the category part when each component is the
1280              * 'category=locale' form */
1281
1282             category_end = strchr(s, '=');
1283
1284             /* The '=' terminates the category name.  If no '=', is improper
1285              * form */
1286             if (! category_end) {
1287                 error = no_equals;
1288                 goto failure;
1289             }
1290
1291             /* Find our internal index of the category name; uses a linear
1292              * search.  (XXX This could be avoided by various means, but the
1293              * maximum likely search is 6 items, and khw doesn't think the
1294              * added complexity would save very much at all.) */
1295             const unsigned int name_len = (unsigned int) (category_end - s);
1296             for (index = 0; index < C_ARRAY_LENGTH(category_names); index++) {
1297                 if (   name_len == category_name_lengths[index]
1298                     && memEQ(s, category_names[index], name_len))
1299                 {
1300                     goto found_category;
1301                 }
1302             }
1303
1304             /* Here, the category is not in our list. */
1305             error = unknown_category;
1306             goto failure;
1307
1308           found_category:   /* The system knows about this category. */
1309
1310             if (index == LC_ALL_INDEX_) {
1311                 error = contains_LC_ALL_element;
1312                 goto failure;
1313             }
1314
1315             /* The locale name starts just beyond the '=' */
1316             s = category_end + 1;
1317
1318             /* Linux (and maybe others) doesn't treat a duplicate category in
1319              * the string as an error.  Instead it uses the final occurrence as
1320              * the intended value.  So if this is a duplicate, free the former
1321              * value before setting the new one */
1322             if (seen[index]) {
1323                 Safefree(output[index]);
1324             }
1325             else {
1326                 seen[index] = true;
1327             }
1328         }
1329
1330         /* Here, 'index' contains our internal index number for the current
1331          * category, and 's' points to the beginning of the locale name for
1332          * that category. */
1333         OVERRIDE_AND_SAVEPV(s, next_sep - s, output[index], index, override);
1334
1335         if (! always_use_full_array) {
1336             if (! saved_first) {
1337                 saved_first = output[index];
1338             }
1339             else {
1340                 if (strNE(saved_first, output[index])) {
1341                     always_use_full_array = true;
1342                 }
1343             }
1344         }
1345
1346         /* Next time start from the new position */
1347         s = next_sep + separator_len;
1348     }
1349
1350     /* Finished looping through all the categories
1351      *
1352      * Check if the input was incomplete. */
1353
1354 #  ifndef PERL_LC_ALL_USES_NAME_VALUE_PAIRS
1355
1356     if (! name_value) {     /* Positional notation */
1357         if (component_number != LC_ALL_INDEX_) {
1358             error = incomplete;
1359             goto failure;
1360         }
1361     }
1362     else
1363
1364 #  endif
1365
1366     {   /* Here is the name=value notation */
1367         for_all_individual_category_indexes(i) {
1368             if (! seen[i]) {
1369                 error = incomplete;
1370                 goto failure;
1371             }
1372         }
1373     }
1374
1375     /* In the loop above, we changed 'always_use_full_array' to true iff not all
1376      * categories have the same locale.  Hence, if it is still 'false', all of
1377      * them are the same. */
1378     if (always_use_full_array) {
1379         return full_array;
1380     }
1381
1382     /* Free the dangling ones */
1383     for_all_but_0th_individual_category_indexes(i) {
1384         Safefree(output[i]);
1385         output[i] = NULL;
1386     }
1387
1388     return only_element_0;
1389
1390   failure:
1391
1392     /* Don't leave memory dangling that we allocated before the failure */
1393     for_all_individual_category_indexes(i) {
1394         if (seen[i]) {
1395             Safefree(output[i]);
1396             output[i] = NULL;
1397         }
1398     }
1399
1400     const char * msg;
1401     const char * display_start = s;
1402     const char * display_end = e;
1403
1404     switch (error) {
1405         case incomplete:
1406             msg = "doesn't list every locale category";
1407             display_start = string;
1408             break;
1409         case no_equals:
1410             msg = "needs an '=' to split name=value";
1411             break;
1412         case unknown_category:
1413             msg = "is an unknown category";
1414             display_end = (category_end && category_end > display_start)
1415                           ? category_end
1416                           : e;
1417             break;
1418         case contains_LC_ALL_element:
1419             msg = "has LC_ALL, which is illegal here";
1420             break;
1421     }
1422
1423     msg = Perl_form(aTHX_ "'%.*s' %s\n",
1424                           (int) (display_end - display_start),
1425                           display_start, msg);
1426
1427     DEBUG_L(PerlIO_printf(Perl_debug_log, "%s", msg));
1428
1429     if (panic_on_error) {
1430         locale_panic_via_(msg, __FILE__, caller_line);
1431     }
1432
1433     return invalid;
1434 }
1435
1436 #  undef OVERRIDE_AND_SAVEPV
1437 #endif
1438
1439 /*==========================================================================
1440  * Here starts the code that gives a uniform interface to its callers, hiding
1441  * the differences between platforms.
1442  *
1443  * base_posix_setlocale_() presents a consistent POSIX-compliant interface to
1444  * setlocale().   Windows requres a customized base-level setlocale().  This
1445  * layer should only be used by the next level up: the plain posix_setlocale
1446  * layer.  Any necessary mutex locking needs to be done at a higher level.  The
1447  * return may be overwritten by the next call to this function */
1448 #ifdef WIN32
1449 #  define base_posix_setlocale_(cat, locale) win32_setlocale(cat, locale)
1450 #else
1451 #  define base_posix_setlocale_(cat, locale)                                \
1452                                     ((const char *) setlocale(cat, locale))
1453 #endif
1454
1455 /*==========================================================================
1456  * Here is the main posix layer.  It is the same as the base one unless the
1457  * system is lacking LC_ALL, or there are categories that we ignore, but that
1458  * the system libc knows about */
1459
1460 #if ! defined(USE_LOCALE)                                                   \
1461  ||  (defined(LC_ALL) && ! defined(HAS_IGNORED_LOCALE_CATEGORIES_))
1462 #  define posix_setlocale(cat, locale) base_posix_setlocale_(cat, locale)
1463 #else
1464 #  define posix_setlocale(cat, locale)                                      \
1465         S_posix_setlocale_with_complications(aTHX_ cat, locale, __LINE__)
1466
1467 STATIC const char *
1468 S_posix_setlocale_with_complications(pTHX_ const int cat,
1469                                            const char * new_locale,
1470                                            const line_t caller_line)
1471 {
1472     /* This implements the posix layer above the base posix layer.
1473      * It is needed to reconcile our internal records that reflect only a
1474      * proper subset of the categories known by the system. */
1475
1476     /* Querying the current locale returns the real value */
1477     if (new_locale == NULL) {
1478         new_locale = base_posix_setlocale_(cat, NULL);
1479         assert(new_locale);
1480         return new_locale;
1481     }
1482
1483     const char * locale_on_entry = NULL;
1484
1485     /* If setting from the environment, actually do the set to get the system's
1486      * idea of what that means; we may have to override later. */
1487     if (strEQ(new_locale, "")) {
1488         locale_on_entry = base_posix_setlocale_(cat, NULL);
1489         assert(locale_on_entry);
1490         new_locale = base_posix_setlocale_(cat, "");
1491         if (! new_locale) {
1492             SET_EINVAL;
1493             return NULL;
1494         }
1495     }
1496
1497 #  ifdef LC_ALL
1498
1499     const char * new_locales[LC_ALL_INDEX_] = { NULL };
1500
1501     if (cat == LC_ALL) {
1502         switch (parse_LC_ALL_string(new_locale,
1503                                     (const char **) &new_locales,
1504                                     override_if_ignored,   /* Override any
1505                                                               ignored
1506                                                               categories */
1507                                     false,    /* Return only [0] if suffices */
1508                                     false,    /* Don't panic on error */
1509                                     caller_line))
1510         {
1511           case invalid:
1512             SET_EINVAL;
1513             return NULL;
1514
1515           case no_array:
1516             break;
1517
1518           case only_element_0:
1519             new_locale = new_locales[0];
1520             SAVEFREEPV(new_locale);
1521             break;
1522
1523           case full_array:
1524
1525             /* Turn the array into a string that the libc setlocale() should
1526              * understand.   (Another option would be to loop, setting the
1527              * individual locales, and then return base(cat, NULL) */
1528             new_locale = calculate_LC_ALL_string(new_locales,
1529                                                  EXTERNAL_FORMAT_FOR_SET,
1530                                                  WANT_TEMP_PV,
1531                                                  caller_line);
1532
1533             for_all_individual_category_indexes(i) {
1534                 Safefree(new_locales[i]);
1535             }
1536
1537             /* And call the libc setlocale.  We could avoid this call if
1538              * locale_on_entry is set and eq the new_locale.  But that would be
1539              * only for the relatively rare case of the desired locale being
1540              * "", and the time spent in doing the string compare might be more
1541              * than that of just setting it unconditionally */
1542             new_locale = base_posix_setlocale_(cat, new_locale);
1543             if (! new_locale) {
1544                  goto failure;
1545             }
1546
1547             return new_locale;
1548         }
1549     }
1550
1551 #  endif
1552
1553     /* Here, 'new_locale' is a single value, not an aggregation.  Just set it.
1554      * */
1555     new_locale =
1556         base_posix_setlocale_(cat,
1557                               override_ignored_category(
1558                                           get_category_index(cat), new_locale));
1559     if (! new_locale) {
1560         goto failure;
1561     }
1562
1563     return new_locale;
1564
1565  failure:
1566
1567     /* 'locale_on_entry' being set indicates there has likely been a change in
1568      * locale which needs to be restored */
1569     if (locale_on_entry) {
1570         if (! base_posix_setlocale_(cat, locale_on_entry)) {
1571             setlocale_failure_panic_i(get_category_index(cat),
1572                                       NULL, locale_on_entry,
1573                                       __LINE__, caller_line);
1574         }
1575     }
1576
1577     SET_EINVAL;
1578     return NULL;
1579 }
1580
1581 #endif
1582
1583 /* End of posix layer
1584  *==========================================================================
1585  *
1586  * The next layer up is to catch vagaries and bugs in the libc setlocale return
1587  * value.  The return is not guaranteed to be stable.
1588  *
1589  * Any necessary mutex locking needs to be done at a higher level.
1590  *
1591  * On most platforms this layer is empty, expanding to just the layer
1592  * below.   To enable it, call Configure with either or both:
1593  * -Accflags=-DHAS_LF_IN_SETLOCALE_RETURN
1594  *                  to indicate that extraneous \n characters can be returned
1595  *                  by setlocale()
1596  * -Accflags=-DHAS_BROKEN_SETLOCALE_QUERY_LC_ALL
1597  *                  to indicate that setlocale(LC_ALL, NULL) cannot be relied
1598  *                  on
1599  */
1600
1601 #define STDIZED_SETLOCALE_LOCK    POSIX_SETLOCALE_LOCK
1602 #define STDIZED_SETLOCALE_UNLOCK  POSIX_SETLOCALE_UNLOCK
1603 #if ! defined(USE_LOCALE)                                                   \
1604  || ! (   defined(HAS_LF_IN_SETLOCALE_RETURN)                               \
1605        || defined(HAS_BROKEN_SETLOCALE_QUERY_LC_ALL))
1606 #  define stdized_setlocale(cat, locale)  posix_setlocale(cat, locale)
1607 #  define stdize_locale(cat, locale)  (locale)
1608 #else
1609 #  define stdized_setlocale(cat, locale)                                    \
1610         S_stdize_locale(aTHX_ cat, posix_setlocale(cat, locale), __LINE__)
1611
1612 STATIC const char *
1613 S_stdize_locale(pTHX_ const int category,
1614                       const char *input_locale,
1615                       const line_t caller_line)
1616 {
1617     /* The return value of setlocale() is opaque, but is required to be usable
1618      * as input to a future setlocale() to create the same state.
1619      * Unfortunately not all systems are compliant.  This function brings those
1620      * outliers into conformance.  It is based on what problems have arisen in
1621      * the field.
1622      *
1623      * This has similar constraints as the posix layer.  You need to lock
1624      * around it until its return is safely copied or no longer needed. (The
1625      * return may point to a global static buffer or may be mortalized.)
1626      *
1627      * The current things this corrects are:
1628      * 1) A new-line.  This function chops any \n characters
1629      * 2) A broken 'setlocale(LC_ALL, foo)'  This constructs a proper returned
1630      *                 string from the constituent categories
1631      *
1632      * If no changes were made, the input is returned as-is */
1633
1634     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1635                           "Entering stdize_locale(%d, '%s');"
1636                           " called from %" LINE_Tf "\n",
1637                           category, input_locale, caller_line));
1638
1639     if (input_locale == NULL) {
1640         SET_EINVAL;
1641         return NULL;
1642     }
1643
1644     char * retval = (char *) input_locale;
1645
1646 #  if defined(LC_ALL) && defined(HAS_BROKEN_SETLOCALE_QUERY_LC_ALL)
1647
1648         /* If setlocale(LC_ALL, NULL) is broken, compute what the system
1649          * actually thinks it should be from its individual components */
1650     if (category == LC_ALL) {
1651         retval = (char *) calculate_LC_ALL_string(
1652                                           NULL,  /* query each individ locale */
1653                                           EXTERNAL_FORMAT_FOR_SET,
1654                                           WANT_TEMP_PV,
1655                                           caller_line);
1656     }
1657
1658 #  endif
1659 #  ifdef HAS_NL_IN_SETLOCALE_RETURN
1660
1661     char * first_bad = NULL;
1662
1663 #    ifndef LC_ALL
1664
1665     PERL_UNUSED_ARG(category);
1666     PERL_UNUSED_ARG(caller_line);
1667
1668 #      define INPUT_LOCALE  retval
1669 #      define MARK_CHANGED
1670 #    else
1671
1672     char * individ_locales[LC_ALL_INDEX_] = { NULL };
1673     bool made_changes = false;
1674     Size_t upper;
1675     if (category != LC_ALL) {
1676         individ_locales[0] = retval;
1677         upper = 0;
1678     }
1679     else {
1680
1681         /* And parse the locale string, splitting into its individual
1682          * components. */
1683         switch (parse_LC_ALL_string(retval,
1684                                     (const char **) &individ_locales,
1685                                     check_that_overridden, /* ignored
1686                                                               categories should
1687                                                               already have been
1688                                                               overridden */
1689                                     false,    /* Return only [0] if suffices */
1690                                     false,    /* Don't panic on error */
1691                                     caller_line))
1692         {
1693           case invalid:
1694             SET_EINVAL;
1695             return NULL;
1696
1697           case full_array: /* Loop below through all the component categories.
1698                             */
1699             upper = LC_ALL_INDEX_ - 1;
1700             break;
1701
1702           case no_array:
1703             /* All categories here are set to the same locale, and the parse
1704              * didn't fill in any of 'individ_locales'.  Set the 0th element to
1705              * that locale. */
1706             individ_locales[0] = retval;
1707             /* FALLTHROUGH */
1708
1709           case only_element_0: /* Element 0 is the only element we need to look
1710                                   at */
1711             upper = 0;
1712             break;
1713         }
1714     }
1715
1716     for (unsigned int i = 0; i <= upper; i++)
1717
1718 #      define INPUT_LOCALE  individ_locales[i]
1719 #      define MARK_CHANGED  made_changes = true;
1720 #    endif    /* Has LC_ALL */
1721
1722     {
1723         first_bad = (char *) strchr(INPUT_LOCALE, '\n');
1724
1725         /* Most likely, there isn't a problem with the input */
1726         if (UNLIKELY(first_bad)) {
1727
1728             /* This element will need to be adjusted.  Create a modifiable
1729              * copy. */
1730             MARK_CHANGED
1731             retval = savepv(INPUT_LOCALE);
1732             SAVEFREEPV(retval);
1733
1734             /* Translate the found position into terms of the copy */
1735             first_bad = retval + (first_bad - INPUT_LOCALE);
1736
1737             /* Get rid of the \n and what follows.  (Originally, only a
1738              * trailing \n was stripped.  Unsure what to do if not trailing) */
1739             *((char *) first_bad) = '\0';
1740         }   /* End of needs adjusting */
1741     }   /* End of looking for problems */
1742
1743 #    ifdef LC_ALL
1744
1745     /* If we had multiple elements, extra work is required */
1746     if (upper != 0) {
1747
1748         /* If no changes were made to the input, 'retval' already contains it
1749          * */
1750         if (made_changes) {
1751
1752             /* But if did make changes, need to calculate the new value */
1753             retval = (char *) calculate_LC_ALL_string(
1754                                             (const char **) &individ_locales,
1755                                             EXTERNAL_FORMAT_FOR_SET,
1756                                             WANT_TEMP_PV,
1757                                             caller_line);
1758         }
1759
1760         /* And free the no-longer needed memory */
1761         for (unsigned int i = 0; i <= upper; i++) {
1762             Safefree(individ_locales[i]);
1763         }
1764     }
1765
1766 #    endif
1767 #    undef INPUT_LOCALE
1768 #    undef MARK_CHANGED
1769 #  endif    /* HAS_NL_IN_SETLOCALE_RETURN */
1770
1771     return (const char *) retval;
1772 }
1773
1774 #endif  /* USE_LOCALE */
1775
1776 /* End of stdize_locale layer
1777  *
1778  * ==========================================================================
1779  *
1780  * The next many lines form several implementations of a layer above the
1781  * close-to-the-metal 'posix' and 'stdized' macros.  They are used to present a
1782  * uniform API to the rest of the code in this file in spite of the disparate
1783  * underlying implementations.  Which implementation gets compiled depends on
1784  * the platform capabilities (and some user choice) as determined by Configure.
1785  *
1786  * As more fully described in the introductory comments in this file, the
1787  * API of each implementation consists of three sets of macros.  Each set has
1788  * three variants with suffixes '_c', '_r', and '_i'.  In the list below '_X'
1789  * is to be replaced by any of these suffixes.
1790  *
1791  * 1) bool_setlocale_X  attempts to set the given category's locale to the
1792  *                      given value, returning if it worked or not.
1793  * 2) void_setlocale_X  is like the corresponding bool_setlocale, but used when
1794  *                      success is the only sane outcome, so failure causes it
1795  *                      to panic.
1796  * 3) querylocale_X     to see what the given category's locale is
1797  *
1798  * 4) setlocale_i()     is defined only in those implementations where the bool
1799  *                      and query forms are essentially the same, and can be
1800  *                      combined to save CPU time.
1801  *
1802  * Each implementation below is separated by ==== lines, and includes bool,
1803  * void, and query macros.  The query macros are first, followed by any
1804  * functions needed to implement them.  Then come the bool, again followed by
1805  * any implementing functions  Then are the void macros; next is setlocale_i if
1806  * present on this implementation.  Finally are any helper functions.  The sets
1807  * in each implementation are separated by ---- lines.
1808  *
1809  * The returned strings from all the querylocale...() forms in all
1810  * implementations are thread-safe, and the caller should not free them,
1811  * but each may be a mortalized copy.  If you need something stable across
1812  * calls, you need to savepv() the result yourself.
1813  *
1814  *===========================================================================*/
1815
1816 #if    (! defined(USE_LOCALE_THREADS) && ! defined(USE_POSIX_2008_LOCALE))    \
1817     || (  defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE))
1818
1819 /* For non-threaded perls, the implementation just expands to the base-level
1820  * functions (except if we are Configured to nonetheless use the POSIX 2008
1821  * interface) This implementation is also used on threaded perls where
1822  * threading is invisible to us.  Currently this is only on later Windows
1823  * versions. */
1824
1825 #  define querylocale_r(cat)  mortalized_pv_copy(stdized_setlocale(cat, NULL))
1826 #  define querylocale_c(cat)  querylocale_r(cat)
1827 #  define querylocale_i(i)    querylocale_c(categories[i])
1828
1829 /*---------------------------------------------------------------------------*/
1830
1831 #  define bool_setlocale_r(cat, locale) cBOOL(posix_setlocale(cat, locale))
1832 #  define bool_setlocale_i(i, locale)                                       \
1833                                    bool_setlocale_c(categories[i], locale)
1834 #  define bool_setlocale_c(cat, locale)      bool_setlocale_r(cat, locale)
1835
1836 /*---------------------------------------------------------------------------*/
1837
1838 #  define void_setlocale_r_with_caller(cat, locale, file, line)             \
1839      STMT_START {                                                           \
1840         if (! bool_setlocale_r(cat, locale))                                \
1841             setlocale_failure_panic_via_i(get_category_index(cat),          \
1842                                           NULL, locale, __LINE__, 0,        \
1843                                           file, line);                      \
1844      } STMT_END
1845
1846 #  define void_setlocale_c_with_caller(cat, locale, file, line)             \
1847                     void_setlocale_r_with_caller(cat, locale, file, line)
1848
1849 #  define void_setlocale_i_with_caller(i, locale, file, line)               \
1850           void_setlocale_r_with_caller(categories[i], locale, file, line)
1851
1852 #  define void_setlocale_r(cat, locale)                                     \
1853             void_setlocale_r_with_caller(cat, locale, __FILE__, __LINE__)
1854 #  define void_setlocale_c(cat, locale) void_setlocale_r(cat, locale)
1855 #  define void_setlocale_i(i, locale)   void_setlocale_r(categories[i], locale)
1856
1857 /*---------------------------------------------------------------------------*/
1858
1859 /* setlocale_i is only defined for Configurations where the libc setlocale()
1860  * doesn't need any tweaking.  It allows for some shortcuts */
1861 #  ifndef USE_LOCALE_THREADS
1862 #    define setlocale_i(i, locale)   stdized_setlocale(categories[i], locale)
1863
1864 #  elif defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE)
1865
1866 /* On Windows, we don't know at compile time if we are in thread-safe mode or
1867  * not.  If we are, we can just return the result of the layer below us.  If we
1868  * are in unsafe mode, we need to first copy that result to a safe place while
1869  * in a critical section */
1870
1871 #    define setlocale_i(i, locale)   S_setlocale_i(aTHX_ categories[i], locale)
1872
1873 STATIC const char *
1874 S_setlocale_i(pTHX_ const int category, const char * locale)
1875 {
1876     if (LIKELY(_configthreadlocale(0) == _ENABLE_PER_THREAD_LOCALE)) {
1877         return stdized_setlocale(category, locale);
1878     }
1879
1880     gwLOCALE_LOCK;
1881     const char * retval = save_to_buffer(stdized_setlocale(category, locale),
1882                                          &PL_setlocale_buf,
1883                                          &PL_setlocale_bufsize);
1884     gwLOCALE_UNLOCK;
1885
1886     return retval;
1887 }
1888
1889 #  endif
1890
1891 /*===========================================================================*/
1892 #elif   defined(USE_LOCALE_THREADS)                 \
1893    && ! defined(USE_THREAD_SAFE_LOCALE)
1894
1895    /* Here, there are threads, and there is no support for thread-safe
1896     * operation.  This is a dangerous situation, which perl is documented as
1897     * not supporting, but it arises in practice.  We can do a modicum of
1898     * automatic mitigation by making sure there is a per-thread return from
1899     * setlocale(), and that a mutex protects it from races */
1900
1901 #  define querylocale_r(cat)                                                \
1902                       mortalized_pv_copy(less_dicey_setlocale_r(cat, NULL))
1903 #  define querylocale_c(cat)  querylocale_r(cat)
1904 #  define querylocale_i(i)    querylocale_r(categories[i])
1905
1906 STATIC const char *
1907 S_less_dicey_setlocale_r(pTHX_ const int category, const char * locale)
1908 {
1909     const char * retval;
1910
1911     PERL_ARGS_ASSERT_LESS_DICEY_SETLOCALE_R;
1912
1913     STDIZED_SETLOCALE_LOCK;
1914
1915     retval = save_to_buffer(stdized_setlocale(category, locale),
1916                             &PL_less_dicey_locale_buf,
1917                             &PL_less_dicey_locale_bufsize);
1918
1919     STDIZED_SETLOCALE_UNLOCK;
1920
1921     return retval;
1922 }
1923
1924 /*---------------------------------------------------------------------------*/
1925
1926 #  define bool_setlocale_r(cat, locale)                                     \
1927                                less_dicey_bool_setlocale_r(cat, locale)
1928 #  define bool_setlocale_i(i, locale)                                       \
1929                                 bool_setlocale_r(categories[i], locale)
1930 #  define bool_setlocale_c(cat, locale) bool_setlocale_r(cat, locale)
1931
1932 STATIC bool
1933 S_less_dicey_bool_setlocale_r(pTHX_ const int cat, const char * locale)
1934 {
1935     bool retval;
1936
1937     PERL_ARGS_ASSERT_LESS_DICEY_BOOL_SETLOCALE_R;
1938
1939     /* Unlikely, but potentially possible that another thread could zap the
1940      * buffer from true to false or vice-versa, so need to lock here */
1941     POSIX_SETLOCALE_LOCK;
1942     retval = cBOOL(posix_setlocale(cat, locale));
1943     POSIX_SETLOCALE_UNLOCK;
1944
1945     return retval;
1946 }
1947
1948 /*---------------------------------------------------------------------------*/
1949
1950 #  define void_setlocale_r_with_caller(cat, locale, file, line)             \
1951      STMT_START {                                                           \
1952         if (! bool_setlocale_r(cat, locale))                                \
1953             setlocale_failure_panic_via_i(get_category_index(cat),          \
1954                                           NULL, locale, __LINE__, 0,        \
1955                                           file, line);                      \
1956      } STMT_END
1957
1958 #  define void_setlocale_c_with_caller(cat, locale, file, line)             \
1959                     void_setlocale_r_with_caller(cat, locale, file, line)
1960
1961 #  define void_setlocale_i_with_caller(i, locale, file, line)               \
1962           void_setlocale_r_with_caller(categories[i], locale, file, line)
1963
1964 #  define void_setlocale_r(cat, locale)                                     \
1965             void_setlocale_r_with_caller(cat, locale, __FILE__, __LINE__)
1966 #  define void_setlocale_c(cat, locale) void_setlocale_r(cat, locale)
1967 #  define void_setlocale_i(i, locale)   void_setlocale_r(categories[i], locale)
1968
1969 /*===========================================================================*/
1970
1971 #elif defined(USE_POSIX_2008_LOCALE)
1972 #  ifndef LC_ALL
1973 #    error This code assumes that LC_ALL is available on a system modern enough to have POSIX 2008
1974 #  endif
1975
1976 /* Here, there is a completely different API to get thread-safe locales.  We
1977  * emulate the setlocale() API with our own function(s).  setlocale categories,
1978  * like LC_NUMERIC, are not valid here for the POSIX 2008 API.  Instead, there
1979  * are equivalents, like LC_NUMERIC_MASK, which we use instead, which we find
1980  * by table lookup. */
1981
1982 #  if defined(__GLIBC__) && defined(USE_LOCALE_MESSAGES)
1983             /* https://sourceware.org/bugzilla/show_bug.cgi?id=24936 */
1984 #    define HAS_GLIBC_LC_MESSAGES_BUG
1985 #    include <libintl.h>
1986 #  endif
1987
1988 #  define querylocale_i(i)    querylocale_2008_i(i, __LINE__)
1989 #  define querylocale_c(cat)  querylocale_i(cat##_INDEX_)
1990 #  define querylocale_r(cat)  querylocale_i(get_category_index(cat))
1991
1992 STATIC const char *
1993 S_querylocale_2008_i(pTHX_ const locale_category_index index,
1994                            const line_t caller_line)
1995 {
1996     PERL_ARGS_ASSERT_QUERYLOCALE_2008_I;
1997     assert(index <= LC_ALL_INDEX_);
1998
1999     /* This function returns the name of the locale category given by the input
2000      * 'index' into our parallel tables of them.
2001      *
2002      * POSIX 2008, for some sick reason, chose not to provide a method to find
2003      * the category name of a locale, disregarding a basic linguistic tenet
2004      * that for any object, people will create a name for it.  (The next
2005      * version of the POSIX standard is proposed to fix this.)  Some vendors
2006      * have created a querylocale() function to do this in the meantime.  On
2007      * systems without querylocale(), we have to keep track of what the locale
2008      * has been set to, so that we can return its name so as to emulate
2009      * setlocale().  There are potential problems with this:
2010      *
2011      *  1)  We don't know what calling newlocale() with the locale argument ""
2012      *      actually does.  It gets its values from the program's environment.
2013      *      find_locale_from_environment() is used to work around this.  But it
2014      *      isn't fool-proof.  See the comments for that function for details.
2015      *  2)  It's possible for C code in some library to change the locale
2016      *      without us knowing it, and thus our records become wrong;
2017      *      querylocale() would catch this.  But as of September 2017, there
2018      *      are no occurrences in CPAN of uselocale().  Some libraries do use
2019      *      setlocale(), but that changes the global locale, and threads using
2020      *      per-thread locales will just ignore those changes.
2021      *  3)  Many systems have multiple names for the same locale.  Generally,
2022      *      there is an underlying base name, with aliases that evaluate to it.
2023      *      On some systems, if you set the locale to an alias, and then
2024      *      retrieve the name, you get the alias as expected; but on others you
2025      *      get the base name, not the alias you used.  And sometimes the
2026      *      charade is incomplete.  See
2027      *      https://bugs.freebsd.org/bugzilla/show_bug.cgi?id=269375.
2028      *
2029      *      The code is structured so that the returned locale name when the
2030      *      locale is changed is whatever the result of querylocale() on the
2031      *      new locale is.  This effectively gives the result the system
2032      *      expects.  Without querylocale, the name returned is always the
2033      *      input name.  Theoretically this could cause problems, but khw knows
2034      *      of none so far, but mentions it here in case you are trying to
2035      *      debug something.  (This could be worked around by messing with the
2036      *      global locale temporarily, using setlocale() to get the base name;
2037      *      but that could cause a race.  The comments for
2038      *      find_locale_from_environment() give details on the potential race.)
2039      */
2040
2041     const locale_t cur_obj = uselocale((locale_t) 0);
2042     const char * retval;
2043
2044     DEBUG_Lv(PerlIO_printf(Perl_debug_log, "querylocale_2008_i(%s) on %p;"
2045                                            " called from %" LINE_Tf "\n",
2046                                            category_names[index], cur_obj,
2047                                            caller_line));
2048
2049     if (UNLIKELY(cur_obj == LC_GLOBAL_LOCALE)) {
2050
2051         /* Even on platforms that have querylocale(), it is unclear if they
2052          * work in the global locale, and we have the means to get the correct
2053          * answer anyway.  khw is unsure this situation even comes up these
2054          * days, hence the branch prediction */
2055         POSIX_SETLOCALE_LOCK;
2056         retval = mortalized_pv_copy(posix_setlocale(categories[index], NULL));
2057         POSIX_SETLOCALE_UNLOCK;
2058     }
2059
2060     /* Here we have handled the case of the the current locale being the global
2061      * one.  Below is the 'else' case of that.  There are two different
2062      * implementations, depending on USE_PL_CURLOCALES */
2063
2064 #  ifdef USE_PL_CURLOCALES
2065
2066     else {
2067
2068         /* PL_curlocales[] is kept up-to-date for all categories except LC_ALL,
2069          * which may have been invalidated by setting it to NULL, and if so,
2070          * should now be calculated.  (The called function updates that
2071          * element.) */
2072         if (index == LC_ALL_INDEX_ && PL_curlocales[LC_ALL_INDEX_] == NULL) {
2073             calculate_LC_ALL_string((const char **) &PL_curlocales,
2074                                     INTERNAL_FORMAT,
2075                                     WANT_VOID,
2076                                     caller_line);
2077         }
2078
2079         if (cur_obj == PL_C_locale_obj) {
2080
2081             /* If the current locale object is the C object, then the answer is
2082              * "C" or POSIX, regardless of the category.  Handling this
2083              * reasonably likely case specially shortcuts extra effort, and
2084              * hides some bugs from us in OS's that alias other locales to C,
2085              * but do so incompletely.  If our records say it is POSIX, use
2086              * that; otherwise use C.  See
2087              * https://bugs.freebsd.org/bugzilla/show_bug.cgi?id=269375 */
2088             retval = mortalized_pv_copy((strEQ(PL_curlocales[index], "POSIX"))
2089                                         ? "POSIX"
2090                                         : "C");
2091         }
2092         else {
2093             retval = mortalized_pv_copy(PL_curlocales[index]);
2094         }
2095     }
2096
2097 #  else
2098
2099     /* Below is the implementation of the 'else' clause which handles the case
2100      * of the current locale not being the global one on platforms where
2101      * USE_PL_CURLOCALES is NOT in effect.  That means the system must have
2102      * some form of querylocale.  But these have varying characteristics, so
2103      * first create some #defines to make the actual 'else' clause uniform.
2104      *
2105      * First, glibc has a function that implements querylocale(), but is called
2106      * something else, and takes the category number; the others take the mask.
2107      * */
2108 #    if defined(USE_QUERYLOCALE) && (   defined(_NL_LOCALE_NAME)            \
2109                                      && defined(HAS_NL_LANGINFO_L))
2110 #      define my_querylocale(index, cur_obj)                                \
2111                 nl_langinfo_l(_NL_LOCALE_NAME(categories[index]), cur_obj)
2112
2113        /* Experience so far shows it is thread-safe, as well as glibc's
2114         * nl_langinfo_l(), so unless overridden, mark it so */
2115 #      ifdef NO_THREAD_SAFE_QUERYLOCALE
2116 #        undef HAS_THREAD_SAFE_QUERYLOCALE
2117 #      else
2118 #        define HAS_THREAD_SAFE_QUERYLOCALE
2119 #      endif
2120 #    else   /* below, ! glibc */
2121
2122        /* Otherwise, use the system's querylocale(). */
2123 #      define my_querylocale(index, cur_obj)                                \
2124                                querylocale(category_masks[index], cur_obj)
2125
2126        /* There is no standard for this function, and khw has never seen
2127         * anything beyond minimal vendor documentation, lacking important
2128         * details.  Experience has shown that some implementations have race
2129         * condiions, and their returns may not be thread safe.  It would be
2130         * unreliable to test for complete thread safety in Configure.  What we
2131         * do instead is to assume that it is thread-safe, unless overriden by,
2132         * say, a hints file specifying
2133         * -Accflags='-DNO_THREAD_SAFE_QUERYLOCALE */
2134 #      ifdef NO_THREAD_SAFE_QUERYLOCALE
2135 #        undef HAS_THREAD_SAFE_QUERYLOCALE
2136 #      else
2137 #        define HAS_THREAD_SAFE_QUERYLOCALE
2138 #      endif
2139 #    endif
2140
2141      /* Here, we have set up enough information to know if this querylocale()
2142       * is thread-safe, or needs to use a mutex */
2143 #    ifdef HAS_THREAD_SAFE_QUERYLOCALE
2144 #      define QUERYLOCALE_LOCK
2145 #      define QUERYLOCALE_UNLOCK
2146 #    else
2147 #      define QUERYLOCALE_LOCK    gwLOCALE_LOCK
2148 #      define QUERYLOCALE_UNLOCK  gwLOCALE_UNLOCK
2149 #    endif
2150
2151     /* Finally, everything is ready, so here is the 'else' clause to implement
2152      * the case of the current locale not being the global one on systems that
2153      * have some form of querylocale().  (POSIX will presumably eventually
2154      * publish their next version in their pipeline, which will define a
2155      * precisely specified querylocale equivalent, and there can be a new
2156      * #ifdef to use it without having to guess at its characteristics) */
2157
2158     else {
2159         /* We don't keep records when there is querylocale(), so as to avoid the
2160          * pitfalls mentioned at the beginning of this function.
2161          *
2162          * That means LC_ALL has to be calculated from all its constituent
2163          * categories each time, since the querylocale() forms on many (if not
2164          * all) platforms only work on individual categories */
2165         if (index == LC_ALL_INDEX_) {
2166             retval = calculate_LC_ALL_string(NULL, INTERNAL_FORMAT,
2167                                              WANT_TEMP_PV,
2168                                              caller_line);
2169         }
2170         else {
2171
2172             QUERYLOCALE_LOCK;
2173             retval = savepv(my_querylocale(index, cur_obj));
2174             QUERYLOCALE_UNLOCK;
2175
2176             /* querylocale() may conflate the C locale with something that
2177              * isn't exactly the same.  See for example
2178              * https://bugs.freebsd.org/bugzilla/show_bug.cgi?id=269375
2179              * We know that if the locale object is the C one, we
2180              * are in the C locale, which may go by the name POSIX, as both, by
2181              * definition, are equivalent.  But we consider any other name
2182              * spurious, so override with "C".  As in the PL_CURLOCALES case
2183              * above, this hides those glitches, for the most part, from the
2184              * rest of our code.  (The code is ordered this way so that if the
2185              * system distinugishes "C" from "POSIX", we do too.) */
2186             if (cur_obj == PL_C_locale_obj && ! isNAME_C_OR_POSIX(retval)) {
2187                 Safefree(retval);
2188                 retval = savepv("C");
2189             }
2190
2191             SAVEFREEPV(retval);
2192         }
2193     }
2194
2195 #    undef QUERYLOCALE_LOCK
2196 #    undef QUERYLOCALE_UNLOCK
2197 #  endif
2198
2199     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2200                            "querylocale_2008_i(%s) returning '%s'\n",
2201                            category_names[index], retval));
2202     assert(strNE(retval, ""));
2203     return retval;
2204 }
2205
2206 /*---------------------------------------------------------------------------*/
2207
2208 #  define bool_setlocale_i(i, locale)                                       \
2209                               bool_setlocale_2008_i(i, locale, __LINE__)
2210 #  define bool_setlocale_c(cat, locale)                                     \
2211                                   bool_setlocale_i(cat##_INDEX_, locale)
2212 #  define bool_setlocale_r(cat, locale)                                     \
2213                        bool_setlocale_i(get_category_index(cat), locale)
2214
2215 /* If this doesn't exist on this platform, make it a no-op (to save #ifdefs) */
2216 #  ifndef update_PL_curlocales_i
2217 #    define update_PL_curlocales_i(index, new_locale, caller_line)
2218 #  endif
2219
2220 STATIC bool
2221 S_bool_setlocale_2008_i(pTHX_
2222
2223         /* Our internal index of the 'category' setlocale is called with */
2224         const locale_category_index  index,
2225         const char * new_locale,    /* The locale to set the category to */
2226         const line_t caller_line    /* Called from this line number */
2227        )
2228 {
2229     PERL_ARGS_ASSERT_BOOL_SETLOCALE_2008_I;
2230     assert(index <= LC_ALL_INDEX_);
2231
2232     /* This function effectively performs a setlocale() on just the current
2233      * thread; thus it is thread-safe.  It does this by using the POSIX 2008
2234      * locale functions to emulate the behavior of setlocale().  Similar to
2235      * regular setlocale(), the return from this function points to memory that
2236      * can be overwritten by other system calls, so needs to be copied
2237      * immediately if you need to retain it.  The difference here is that
2238      * system calls besides another setlocale() can overwrite it.
2239      *
2240      * By doing this, most locale-sensitive functions become thread-safe.  The
2241      * exceptions are mostly those that return a pointer to static memory.
2242      */
2243
2244     int mask = category_masks[index];
2245     const locale_t entry_obj = uselocale((locale_t) 0);
2246     const char * locale_on_entry = querylocale_i(index);
2247
2248     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2249                            "bool_setlocale_2008_i: input=%d (%s), mask=0x%x,"
2250                            " new locale=\"%s\", current locale=\"%s\","
2251                            " index=%d, entry object=%p;"
2252                            " called from %" LINE_Tf "\n",
2253                            categories[index], category_names[index], mask,
2254                            ((new_locale == NULL) ? "(nil)" : new_locale),
2255                            locale_on_entry, index, entry_obj, caller_line));
2256
2257     /* Here, trying to change the locale, but it is a no-op if the new boss is
2258      * the same as the old boss.  Except this routine is called when converting
2259      * from the global locale, so in that case we will create a per-thread
2260      * locale below (with the current values).  It also seemed that newlocale()
2261      * could free up the basis locale memory if we called it with the new and
2262      * old being the same, but khw now thinks that this was due to some other
2263      * bug, since fixed, as there are other places where newlocale() gets
2264      * similarly called without problems. */
2265     if (   entry_obj != LC_GLOBAL_LOCALE
2266         && locale_on_entry
2267         && strEQ(new_locale, locale_on_entry))
2268     {
2269         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2270                                "bool_setlocale_2008_i: no-op to change to"
2271                                " what it already was\n"));
2272         return true;
2273     }
2274
2275 #  ifndef USE_QUERYLOCALE
2276
2277     /* Without a querylocale() mechanism, we have to figure out ourselves what
2278      * happens with setting a locale to "" */
2279
2280     if (strEQ(new_locale, "")) {
2281         new_locale = find_locale_from_environment(index);
2282         if (! new_locale) {
2283             SET_EINVAL;
2284             return false;
2285         }
2286     }
2287
2288 #  endif
2289 #  ifdef NEWLOCALE_HANDLES_DISPARATE_LC_ALL
2290
2291     const bool need_loop = false;
2292
2293 #  else
2294
2295     bool need_loop = false;
2296     const char * new_locales[LC_ALL_INDEX_] = { NULL };
2297
2298     /* If we're going to have to parse the LC_ALL string, might as well do it
2299      * now before we have made changes that we would have to back out of if the
2300      * parse fails */
2301     if (index == LC_ALL_INDEX_) {
2302         switch (parse_LC_ALL_string(new_locale,
2303                                     (const char **) &new_locales,
2304                                     override_if_ignored,
2305                                     false,    /* Return only [0] if suffices */
2306                                     false,    /* Don't panic on error */
2307                                     caller_line))
2308         {
2309           case invalid:
2310             SET_EINVAL;
2311             return false;
2312
2313           case no_array:
2314             need_loop = false;
2315             break;
2316
2317           case only_element_0:
2318             SAVEFREEPV(new_locales[0]);
2319             new_locale = new_locales[0];
2320             need_loop = false;
2321             break;
2322
2323           case full_array:
2324             need_loop = true;
2325             break;
2326         }
2327     }
2328
2329 #  endif
2330 #  ifdef HAS_GLIBC_LC_MESSAGES_BUG
2331
2332     /* For this bug, if the LC_MESSAGES locale changes, we have to do an
2333      * expensive workaround.  Save the current value so we can later determine
2334      * if it changed. */
2335     const char * old_messages_locale = NULL;
2336     if (   (index == LC_MESSAGES_INDEX_ || index == LC_ALL_INDEX_)
2337         &&  LIKELY(PL_phase != PERL_PHASE_CONSTRUCT))
2338     {
2339         old_messages_locale = querylocale_c(LC_MESSAGES);
2340     }
2341
2342 #  endif
2343
2344     assert(PL_C_locale_obj);
2345
2346     /* Now ready to switch to the input 'new_locale' */
2347
2348     /* Switching locales generally entails freeing the current one's space (at
2349      * the C library's discretion), hence we can't be using that locale at the
2350      * time of the switch (this wasn't obvious to khw from the man pages).  So
2351      * switch to a known locale object that we don't otherwise mess with. */
2352     if (! uselocale(PL_C_locale_obj)) {
2353
2354         /* Not being able to change to the C locale is severe; don't keep
2355          * going.  */
2356         setlocale_failure_panic_i(index, locale_on_entry, "C",
2357                                   __LINE__, caller_line);
2358         NOT_REACHED; /* NOTREACHED */
2359     }
2360
2361     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2362                            "bool_setlocale_2008_i: now using C"
2363                            " object=%p\n", PL_C_locale_obj));
2364
2365     /* These two objects are special:
2366      *  LC_GLOBAL_LOCALE    because it is undefined behavior to call
2367      *                      newlocale() with it as a parameter.
2368      *  PL_C_locale_obj     because newlocale() generally destroys its locale
2369      *                      object parameter when it succeeds; and we don't
2370      *                      want that happening to this immutable object.
2371      * Copies will be made for them to use instead if we get so far as to call
2372      * newlocale(). */
2373     bool entry_obj_is_special = (   entry_obj == LC_GLOBAL_LOCALE
2374                                  || entry_obj == PL_C_locale_obj);
2375     locale_t new_obj;
2376
2377     /* PL_C_locale_obj is LC_ALL set to the C locale.  If this call is to
2378      * switch to LC_ALL => C, simply use that object.  But in fact, we already
2379      * have switched to it just above, in preparation for the general case.
2380      * Since we're already there, no need to do further switching. */
2381     if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(new_locale)) {
2382         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2383                                "bool_setlocale_2008_i: will stay in C"
2384                                " object\n"));
2385         new_obj = PL_C_locale_obj;
2386
2387         /* 'entry_obj' is now dangling, of no further use to anyone (unless it
2388          * is one of the special ones).  Free it to avoid a leak */
2389         if (! entry_obj_is_special) {
2390             freelocale(entry_obj);
2391         }
2392
2393         update_PL_curlocales_i(index, new_locale, caller_line);
2394     }
2395     else {  /* Here is the general case, not to LC_ALL => C */
2396
2397         /* The newlocale() call(s) below take a basis object to build upon to
2398          * create the changed locale, trashing it iff successful.
2399          *
2400          * For the objects that are not to be modified by this function, we
2401          * create a duplicate that gets trashed instead.
2402          *
2403          * Also if we will have to loop doing multiple newlocale()s, there is a
2404          * chance we will succeed for the first few, and then fail, having to
2405          * back out.  We need to duplicate 'entry_obj' in this case as well, so
2406          * it remains valid as something to back out to. */
2407         locale_t basis_obj = entry_obj;
2408
2409         if (entry_obj_is_special || need_loop) {
2410             basis_obj = duplocale(basis_obj);
2411             if (! basis_obj) {
2412                 locale_panic_via_("duplocale failed", __FILE__, caller_line);
2413                 NOT_REACHED; /* NOTREACHED */
2414             }
2415
2416             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2417                                    "bool_setlocale_2008_i created %p by"
2418                                    " duping the input\n", basis_obj));
2419         }
2420
2421 #  define DEBUG_NEW_OBJECT_CREATED(category, locale, new, old, caller_line) \
2422       DEBUG_Lv(PerlIO_printf(Perl_debug_log,                                \
2423                              "bool_setlocale_2008_i(%s, %s): created %p"    \
2424                              " while freeing %p; called from %" LINE_Tf     \
2425                              " via %" LINE_Tf "\n",                         \
2426                              category, locale, new, old,                    \
2427                              caller_line, __LINE__))
2428 #  define DEBUG_NEW_OBJECT_FAILED(category, locale, basis_obj)              \
2429       DEBUG_L(PerlIO_printf(Perl_debug_log,                                 \
2430                             "bool_setlocale_2008_i: creating new object"    \
2431                             " for (%s '%s') from %p failed; called from %"  \
2432                             LINE_Tf " via %" LINE_Tf "\n",                  \
2433                             category, locale, basis_obj,                    \
2434                             caller_line, __LINE__));
2435
2436         /* Ready to create a new locale by modification of the existing one.
2437          *
2438          * NOTE: This code may incorrectly show up as a leak under the address
2439          * sanitizer. We do not free this object under normal teardown, however
2440          * you can set PERL_DESTRUCT_LEVEL=2 to cause it to be freed.
2441          */
2442
2443 #  ifdef NEWLOCALE_HANDLES_DISPARATE_LC_ALL
2444
2445         /* Some platforms have a newlocale() that can handle disparate LC_ALL
2446          * input, so on these a single call to newlocale() always works */
2447 #  else
2448
2449         /* If a single call to newlocale() will do */
2450         if (! need_loop)
2451
2452 #  endif
2453
2454         {
2455             new_obj = newlocale(mask,
2456                                 override_ignored_category(index, new_locale),
2457                                 basis_obj);
2458             if (! new_obj) {
2459                 DEBUG_NEW_OBJECT_FAILED(category_names[index], new_locale,
2460                                         basis_obj);
2461
2462                 /* Since the call failed, it didn't trash 'basis_obj', which is
2463                  * a dup for these objects, and hence would leak if we don't
2464                  * free it.  XXX However, something is seriously wrong if we
2465                  * can't switch to C or the global locale, so maybe should
2466                  * panic instead */
2467                 if (entry_obj_is_special) {
2468                     freelocale(basis_obj);
2469                 }
2470
2471                 goto must_restore_state;
2472             }
2473
2474             DEBUG_NEW_OBJECT_CREATED(category_names[index], new_locale,
2475                                      new_obj, basis_obj, caller_line);
2476
2477             update_PL_curlocales_i(index, new_locale, caller_line);
2478         }
2479
2480 #  ifndef NEWLOCALE_HANDLES_DISPARATE_LC_ALL
2481
2482         else {  /* Need multiple newlocale() calls */
2483
2484             /* Loop through the individual categories, setting the locale of
2485              * each to the corresponding name previously populated into
2486              * newlocales[].  Each iteration builds on the previous one, adding
2487              * its category to what's already been calculated, and taking as a
2488              * basis for what's been calculated 'basis_obj', which is updated
2489              * each iteration to be the result of the previous one.  Upon
2490              * success, newlocale() trashes the 'basis_obj' parameter to it.
2491              * If any iteration fails, we immediately give up, restore the
2492              * locale to what it was at the time this function was called
2493              * (saved in 'entry_obj'), and return failure. */
2494
2495             /* Loop, using the previous iteration's result as the basis for the
2496              * next one.  (The first time we effectively use the locale in
2497              * force upon entry to this function.) */
2498             for_all_individual_category_indexes(i) {
2499                 new_obj = newlocale(category_masks[i],
2500                                     new_locales[i],
2501                                     basis_obj);
2502                 if (new_obj) {
2503                     DEBUG_NEW_OBJECT_CREATED(category_names[i],
2504                                              new_locales[i],
2505                                              new_obj, basis_obj,
2506                                              caller_line);
2507                     basis_obj = new_obj;
2508                     continue;
2509                 }
2510
2511                 /* Failed.  Likely this is because the proposed new locale
2512                  * isn't valid on this system. */
2513
2514                 DEBUG_NEW_OBJECT_FAILED(category_names[i],
2515                                         new_locales[i],
2516                                         basis_obj);
2517
2518                 /* newlocale() didn't trash this, since the function call
2519                  * failed */
2520                 freelocale(basis_obj);
2521
2522                 for_all_individual_category_indexes(j) {
2523                     Safefree(new_locales[j]);
2524                 }
2525
2526                 goto must_restore_state;
2527             }
2528
2529             /* Success for all categories. */
2530             for_all_individual_category_indexes(i) {
2531                 update_PL_curlocales_i(i, new_locales[i], caller_line);
2532                 Safefree(new_locales[i]);
2533             }
2534
2535             /* We dup'd entry_obj in case we had to fall back to it.  The
2536              * newlocale() above destroyed the dup when it first succeeded, but
2537              * entry_obj itself is left dangling, so free it */
2538             if (! entry_obj_is_special) {
2539                 freelocale(entry_obj);
2540             }
2541         }
2542
2543 #  endif    /* End of newlocale can't handle disparate LC_ALL input */
2544
2545     }
2546
2547 #  undef DEBUG_NEW_OBJECT_CREATED
2548 #  undef DEBUG_NEW_OBJECT_FAILED
2549
2550     /* Here, successfully created an object representing the desired locale;
2551      * now switch into it */
2552     if (! uselocale(new_obj)) {
2553         freelocale(new_obj);
2554         locale_panic_(Perl_form(aTHX_ "(called from %" LINE_Tf "):"
2555                                       " bool_setlocale_2008_i: switching"
2556                                       " into new locale failed",
2557                                       caller_line));
2558     }
2559
2560     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2561                            "bool_setlocale_2008_i: now using %p\n", new_obj));
2562
2563 #  ifdef MULTIPLICITY   /* Unlikely, but POSIX 2008 functions could be
2564                            Configured to be used on unthreaded perls, in which
2565                            case this object doesn't exist */
2566
2567     if (DEBUG_Lv_TEST) {
2568         if (PL_cur_locale_obj != new_obj) {
2569             PerlIO_printf(Perl_debug_log,
2570                           "bool_setlocale_2008_i: PL_cur_locale_obj"
2571                           " was %p, now is %p\n",
2572                           PL_cur_locale_obj, new_obj);
2573         }
2574     }
2575
2576     /* Update the current object */
2577     PL_cur_locale_obj = new_obj;
2578
2579 #  endif
2580 #  ifdef HAS_GLIBC_LC_MESSAGES_BUG
2581
2582     /* Invalidate the glibc cache of loaded translations if the locale has
2583      * changed, see [perl #134264] and
2584      * https://sourceware.org/bugzilla/show_bug.cgi?id=24936 */
2585     if (old_messages_locale) {
2586         if (strNE(old_messages_locale, querylocale_c(LC_MESSAGES))) {
2587             textdomain(textdomain(NULL));
2588         }
2589     }
2590
2591 #  endif
2592
2593     return true;
2594
2595   must_restore_state:
2596
2597     /* We earlier switched to the LC_ALL => C locale in anticipation of it
2598      * succeeding,  Now have to switch back to the state upon entry.  */
2599     if (! uselocale(entry_obj)) {
2600         setlocale_failure_panic_i(index, "switching back to",
2601                                   locale_on_entry, __LINE__, caller_line);
2602     }
2603
2604     return false;
2605 }
2606
2607 /*---------------------------------------------------------------------------*/
2608
2609 #  define void_setlocale_i_with_caller(i, locale, file, line)               \
2610      STMT_START {                                                           \
2611         if (! bool_setlocale_i(i, locale))                                  \
2612             setlocale_failure_panic_via_i(i, NULL, locale, __LINE__, 0,     \
2613                                           file, line);                      \
2614      } STMT_END
2615
2616 #  define void_setlocale_r_with_caller(cat, locale, file, line)             \
2617         void_setlocale_i_with_caller(get_category_index(cat), locale,       \
2618                                      file, line)
2619
2620 #  define void_setlocale_c_with_caller(cat, locale, file, line)             \
2621             void_setlocale_i_with_caller(cat##_INDEX_, locale, file, line)
2622
2623 #  define void_setlocale_i(i, locale)                                       \
2624                 void_setlocale_i_with_caller(i, locale, __FILE__, __LINE__)
2625 #  define void_setlocale_c(cat, locale)                                     \
2626                                   void_setlocale_i(cat##_INDEX_, locale)
2627 #  define void_setlocale_r(cat, locale)                                     \
2628                   void_setlocale_i(get_category_index(cat), locale)
2629
2630 /*===========================================================================*/
2631
2632 #else
2633 #  error Unexpected Configuration
2634 #endif   /* End of the various implementations of the setlocale and
2635             querylocale macros used in the remainder of this program */
2636
2637 /* query_nominal_locale_i() is used when the caller needs the locale that an
2638  * external caller would be expecting, and not what we're secretly using
2639  * behind the scenes.  It deliberately doesn't handle LC_ALL; use
2640  * calculate_LC_ALL_string() for that. */
2641 #ifdef USE_LOCALE_NUMERIC
2642 #  define query_nominal_locale_i(i)                                         \
2643       (__ASSERT_(i != LC_ALL_INDEX_)                                        \
2644        ((i == LC_NUMERIC_INDEX_) ? PL_numeric_name : querylocale_i(i)))
2645 #else
2646 #  define query_nominal_locale_i(i)                                         \
2647       (__ASSERT_(i != LC_ALL_INDEX_) querylocale_i(i))
2648 #endif
2649
2650 #ifdef USE_PL_CURLOCALES
2651
2652 STATIC void
2653 S_update_PL_curlocales_i(pTHX_
2654                          const locale_category_index index,
2655                          const char * new_locale,
2656                          const line_t caller_line)
2657 {
2658     /* Update PL_curlocales[], which is parallel to the other ones indexed by
2659      * our mapping of libc category number to our internal equivalents. */
2660
2661     PERL_ARGS_ASSERT_UPDATE_PL_CURLOCALES_I;
2662     assert(index <= LC_ALL_INDEX_);
2663
2664     if (index == LC_ALL_INDEX_) {
2665
2666         /* For LC_ALL, we change all individual categories to correspond,
2667          * including the LC_ALL element */
2668         for (unsigned int i = 0; i <= LC_ALL_INDEX_; i++) {
2669             Safefree(PL_curlocales[i]);
2670             PL_curlocales[i] = NULL;
2671         }
2672
2673         switch (parse_LC_ALL_string(new_locale,
2674                                     (const char **) &PL_curlocales,
2675                                     check_that_overridden,  /* things should
2676                                                                have already
2677                                                                been overridden
2678                                                                */
2679                                     true,   /* Always fill array */
2680                                     true,   /* Panic if fails, as to get here
2681                                                it earlier had to have succeeded
2682                                                */
2683                                    caller_line))
2684         {
2685           case invalid:
2686           case no_array:
2687           case only_element_0:
2688             locale_panic_via_("Unexpected return from parse_LC_ALL_string",
2689                               __FILE__, caller_line);
2690
2691           case full_array:
2692             /* parse_LC_ALL_string() has already filled PL_curlocales properly,
2693              * except for the LC_ALL element, which should be set to
2694              * 'new_locale'. */
2695             PL_curlocales[LC_ALL_INDEX_] = savepv(new_locale);
2696         }
2697     }
2698     else {  /* Not LC_ALL */
2699
2700         /* Update the single category's record */
2701         Safefree(PL_curlocales[index]);
2702         PL_curlocales[index] = savepv(new_locale);
2703
2704         /* Invalidate LC_ALL */
2705         Safefree(PL_curlocales[LC_ALL_INDEX_]);
2706         PL_curlocales[LC_ALL_INDEX_] = NULL;
2707     }
2708 }
2709
2710 #  endif  /* Need PL_curlocales[] */
2711
2712 /*===========================================================================*/
2713
2714 #if defined(USE_LOCALE)
2715
2716 /* This paradigm is needed in several places in the function below.  We have to
2717  * substitute the nominal locale for LC_NUMERIC when returning a value for
2718  * external consumption */
2719 #  ifndef USE_LOCALE_NUMERIC
2720 #    define ENTRY(i, array, format)  array[i]
2721 #  else
2722 #    define ENTRY(i, array, format)                         \
2723        (UNLIKELY(   format == EXTERNAL_FORMAT_FOR_QUERY     \
2724                  && i == LC_NUMERIC_INDEX_)                 \
2725         ? PL_numeric_name                                   \
2726         : array[i])
2727 #  endif
2728
2729 STATIC
2730 const char *
2731 S_calculate_LC_ALL_string(pTHX_ const char ** category_locales_list,
2732                                 const calc_LC_ALL_format format,
2733                                 const calc_LC_ALL_return returning,
2734                                 const line_t caller_line)
2735 {
2736     PERL_ARGS_ASSERT_CALCULATE_LC_ALL_STRING;
2737
2738     /* NOTE: On Configurations that have PL_curlocales[], this function has the
2739      * side effect of updating the LC_ALL_INDEX_ element with its result.
2740      *
2741      * This function calculates a string that defines the locale(s) LC_ALL is
2742      * set to, in either:
2743      *  1)  Our internal format if 'format' is set to INTERNAL_FORMAT.
2744      *  2)  The external format returned by Perl_setlocale() if 'format' is set
2745      *      to EXTERNAL_FORMAT_FOR_QUERY or EXTERNAL_FORMAT_FOR_SET.
2746      *
2747      *      These two are distinguished by:
2748      *       a) EXTERNAL_FORMAT_FOR_SET returns the actual locale currently in
2749      *          effect.
2750      *       b) EXTERNAL_FORMAT_FOR_QUERY returns the nominal locale.
2751      *          Currently this can differ only from the actual locale in the
2752      *          LC_NUMERIC category when it is set to a locale whose radix is
2753      *          not a dot.  (The actual locale is kept as a dot to accommodate
2754      *          the large corpus of XS code that expects it to be that;
2755      *          switched to a non-dot temporarily during certain operations
2756      *          that require the actual radix.)
2757      *
2758      * In both 1) and 2), LC_ALL's values are passed to this function by
2759      * 'category_locales_list' which is either:
2760      *  1) a pointer to an array of strings with up-to-date values of all the
2761      *     individual categories; or
2762      *  2) NULL, to indicate to use querylocale_i() to get each individual
2763      *     value.
2764      *
2765      * The caller sets 'returning' to
2766      *      WANT_TEMP_PV        the function returns the calculated string
2767      *                              as a mortalized temporary, so the caller
2768      *                              doesn't have to worry about it being
2769      *                              per-thread, nor needs to arrange for its
2770      *                              clean-up.
2771      *      WANT_PL_setlocale_buf  the function stores the calculated string
2772      *                              into the per-thread buffer PL_setlocale_buf
2773      *                              and returns a pointer to that.  The buffer
2774      *                              is cleaned up automatically in process
2775      *                              destruction.  This return method avoids
2776      *                              extra copies in some circumstances.
2777      *      WANT_VOID           NULL is returned.  This is used when the
2778      *                              function is being called only for its side
2779      *                              effect of updating
2780      *                              PL_curlocales[LC_ALL_INDEX_]
2781      *
2782      * querylocale(), on systems that have it, doesn't tend to work for LC_ALL.
2783      * So we have to construct the answer ourselves based on the passed in
2784      * data.
2785      *
2786      * If all individual categories are the same locale, we can just set LC_ALL
2787      * to that locale.  But if not, we have to create an aggregation of all the
2788      * categories on the system.  Platforms differ as to the syntax they use
2789      * for these non-uniform locales for LC_ALL.  Some, like glibc and Windows,
2790      * use an unordered series of name=value pairs, like
2791      *      LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
2792      * to specify LC_ALL; others, like *BSD, use a positional notation with a
2793      * delimitter, typically a single '/' character:
2794      *      C/en_UK.UTF-8/...
2795      *
2796      * When the external format is desired, this function returns whatever the
2797      * system expects.  The internal format is always name=value pairs.
2798      *
2799      * For systems that have categories we don't know about, the algorithm
2800      * below won't know about those missing categories, leading to potential
2801      * bugs for code that looks at them.  If there is an environment variable
2802      * that sets that category, we won't know to look for it, and so our use of
2803      * LANG or "C" improperly overrides it.  On the other hand, if we don't do
2804      * what is done here, and there is no environment variable, the category's
2805      * locale should be set to LANG or "C".  So there is no good solution.  khw
2806      * thinks the best is to make sure we have a complete list of possible
2807      * categories, adding new ones as they show up on obscure platforms.
2808      */
2809
2810     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2811                            "Entering calculate_LC_ALL_string(%s);"
2812                            " called from %" LINE_Tf "\n",
2813                            ((format == EXTERNAL_FORMAT_FOR_QUERY)
2814                             ? "EXTERNAL_FORMAT_FOR_QUERY"
2815                             : ((format == EXTERNAL_FORMAT_FOR_SET)
2816                                ? "EXTERNAL_FORMAT_FOR_SET"
2817                                : "INTERNAL_FORMAT")),
2818                            caller_line));
2819
2820     bool input_list_was_NULL = (category_locales_list == NULL);
2821
2822     /* If there was no input category list, construct a temporary one
2823      * ourselves. */
2824     const char * my_category_locales_list[LC_ALL_INDEX_];
2825     const char ** locales_list = category_locales_list;
2826     if (locales_list == NULL) {
2827         locales_list = my_category_locales_list;
2828
2829         if (format == EXTERNAL_FORMAT_FOR_QUERY) {
2830             for_all_individual_category_indexes(i) {
2831                 locales_list[i] = query_nominal_locale_i(i);
2832             }
2833         }
2834         else {
2835             for_all_individual_category_indexes(i) {
2836                 locales_list[i] = querylocale_i(i);
2837             }
2838         }
2839     }
2840
2841     /* While we are calculating LC_ALL, we see if every category's locale is
2842      * the same as every other's or not. */
2843 #  ifndef HAS_IGNORED_LOCALE_CATEGORIES_
2844
2845     /* When we pay attention to all categories, we assume they are all the same
2846      * until proven different */
2847     bool disparate = false;
2848
2849 #  else
2850
2851     /* But if there are ignored categories, those will be set to "C", so try an
2852      * arbitrary category, and if it isn't C, we know immediately that the
2853      * locales are disparate.  (The #if conditionals are to handle the case
2854      * where LC_NUMERIC_INDEX_ is 0.  We don't want to use LC_NUMERIC to
2855      * compare, as that may be different between external and internal forms.)
2856      * */
2857 #    if ! defined(USE_LOCALE_NUMERIC)
2858
2859     bool disparate = ! isNAME_C_OR_POSIX(locales_list[0]);
2860
2861 #    elif LC_NUMERIC_INDEX_ != 0
2862
2863     bool disparate = ! isNAME_C_OR_POSIX(locales_list[0]);
2864
2865 #    else
2866
2867     /* Would need revision to handle the very unlikely case where only a single
2868      * category, LC_NUMERIC, is defined */
2869     assert(LOCALE_CATEGORIES_COUNT_ > 0);
2870
2871     bool disparate = ! isNAME_C_OR_POSIX(locales_list[1]);
2872
2873 #    endif
2874 #  endif
2875
2876     /* Calculate the needed size for the string listing the individual locales.
2877      * Initialize with values known at compile time. */
2878     Size_t total_len;
2879     const char *separator;
2880
2881 #  ifdef PERL_LC_ALL_USES_NAME_VALUE_PAIRS  /* Positional formatted LC_ALL */
2882     PERL_UNUSED_ARG(format);
2883 #  else
2884
2885     if (format != INTERNAL_FORMAT) {
2886
2887         /* Here, we will be using positional notation.  it includes n-1
2888          * separators */
2889         total_len = (  LOCALE_CATEGORIES_COUNT_ - 1)
2890                      * STRLENs(PERL_LC_ALL_SEPARATOR)
2891                   + 1;   /* And a trailing NUL */
2892         separator = PERL_LC_ALL_SEPARATOR;
2893     }
2894     else
2895
2896 #  endif
2897
2898     {
2899         /* name=value output is always used in internal format, and when
2900          * positional isn't available on the platform. */
2901         total_len = lc_all_boiler_plate_length;
2902         separator = ";";
2903     }
2904
2905     /* The total length then is just the sum of the above boiler-plate plus the
2906      * total strlen()s of the locale name of each individual category. */
2907     for_all_individual_category_indexes(i) {
2908         const char * entry = ENTRY(i, locales_list, format);
2909
2910         total_len += strlen(entry);
2911         if (! disparate && strNE(entry, locales_list[0])) {
2912             disparate = true;
2913         }
2914     }
2915
2916     bool free_if_void_return = false;
2917     const char * retval;
2918
2919     /* If all categories have the same locale, we already know the answer */
2920     if (! disparate) {
2921         if (returning == WANT_PL_setlocale_buf) {
2922             save_to_buffer(locales_list[0],
2923                            &PL_setlocale_buf,
2924                            &PL_setlocale_bufsize);
2925             retval = PL_setlocale_buf;
2926         }
2927         else {
2928
2929             retval = locales_list[0];
2930
2931             /* If a temporary is wanted for the return, and we had to create
2932              * the input list ourselves, we created it into such a temporary,
2933              * so no further work is needed; but otherwise, make a mortal copy
2934              * of this passed-in list element */
2935             if (returning == WANT_TEMP_PV && ! input_list_was_NULL) {
2936                 retval = savepv(retval);
2937                 SAVEFREEPV(retval);
2938             }
2939
2940             /* In all cases here, there's nothing we create that needs to be
2941              * freed, so leave 'free_if_void_return' set to the default
2942              * 'false'. */
2943         }
2944     }
2945     else {  /* Here, not all categories have the same locale */
2946
2947         char * constructed;
2948
2949         /* If returning to PL_setlocale_buf, set up to write directly to it,
2950          * being sure it is resized to be large enough */
2951         if (returning == WANT_PL_setlocale_buf) {
2952             set_save_buffer_min_size(total_len,
2953                                      &PL_setlocale_buf,
2954                                      &PL_setlocale_bufsize);
2955             constructed = PL_setlocale_buf;
2956         }
2957         else {  /* Otherwise we need new memory to hold the calculated value. */
2958
2959             Newx(constructed, total_len, char);
2960
2961             /* If returning the new memory, it must be set up to be freed
2962              * later; otherwise at the end of this function */
2963             if (returning == WANT_TEMP_PV) {
2964                 SAVEFREEPV(constructed);
2965             }
2966             else {
2967                 free_if_void_return = true;
2968             }
2969         }
2970
2971         constructed[0] = '\0';
2972
2973         /* Loop through all the categories */
2974         for_all_individual_category_indexes(j) {
2975
2976             /* Add a separator, except before the first one */
2977             if (j != 0) {
2978                 my_strlcat(constructed, separator, total_len);
2979             }
2980
2981             const char * entry;
2982             Size_t needed_len;
2983             unsigned int i = j;
2984
2985 #  ifndef PERL_LC_ALL_USES_NAME_VALUE_PAIRS
2986
2987             if (UNLIKELY(format != INTERNAL_FORMAT)) {
2988
2989                 /* In positional notation 'j' means the position, and we have
2990                  * to convert to the index 'i' */
2991                 i = map_LC_ALL_position_to_index[j];
2992
2993                 entry = ENTRY(i, locales_list, format);
2994                 needed_len = my_strlcat(constructed, entry, total_len);
2995             }
2996             else
2997
2998 #  endif
2999             {
3000                 /* Below, we are to use name=value notation, either because
3001                  * that's what the platform uses, or because this is the
3002                  * internal format, which uses that notation regardless of the
3003                  * external form */
3004
3005                 entry = ENTRY(i, locales_list, format);
3006
3007                 /* "name=locale;" */
3008                 my_strlcat(constructed, category_names[i], total_len);
3009                 my_strlcat(constructed, "=", total_len);
3010                 needed_len = my_strlcat(constructed, entry, total_len);
3011             }
3012
3013             if (LIKELY(needed_len <= total_len)) {
3014                 continue;
3015             }
3016
3017             /* If would have overflowed, panic */
3018             locale_panic_via_(Perl_form(aTHX_
3019                                         "Internal length calculation wrong.\n"
3020                                         "\"%s\" was not entirely added to"
3021                                         " \"%.*s\"; needed=%zu, had=%zu",
3022                                         entry, (int) total_len,
3023                                         constructed,
3024                                         needed_len, total_len),
3025                                 __FILE__,
3026                                 caller_line);
3027         } /* End of loop through the categories */
3028
3029         retval = constructed;
3030     } /* End of the categories' locales are displarate */
3031
3032 #  if defined(USE_PL_CURLOCALES) && defined(LC_ALL)
3033
3034     if (format == INTERNAL_FORMAT) {
3035
3036         /* PL_curlocales[LC_ALL_INDEX_] is updated as a side-effect of this
3037          * function for internal format. */
3038         Safefree(PL_curlocales[LC_ALL_INDEX_]);
3039         PL_curlocales[LC_ALL_INDEX_] = savepv(retval);
3040     }
3041
3042 #  endif
3043
3044     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3045                            "calculate_LC_ALL_string calculated '%s'\n",
3046                            retval));
3047
3048     if (returning == WANT_VOID) {
3049         if (free_if_void_return) {
3050             Safefree(retval);
3051         }
3052
3053         return NULL;
3054     }
3055
3056     return retval;
3057 }
3058
3059 #  if defined(WIN32) || (     defined(USE_POSIX_2008_LOCALE)        \
3060                          && ! defined(USE_QUERYLOCALE))
3061
3062 STATIC const char *
3063 S_find_locale_from_environment(pTHX_ const locale_category_index index)
3064 {
3065     /* NB: This function may actually change the locale on Windows.  It
3066      * currently is designed to be called only from setting the locale on
3067      * Windows, and POSIX 2008
3068      *
3069      * This function returns the locale specified by the program's environment
3070      * for the category specified by our internal index number 'index'.  It
3071      * therefore simulates:
3072      *      setlocale(cat, "")
3073      * but, except for some cases in Windows, doesn't actually change the
3074      * locale; merely returns it.
3075      *
3076      * The return need not be freed by the caller.  This
3077      * promise relies on PerlEnv_getenv() returning a mortalized copy to us.
3078      *
3079      * The simulation is needed only on certain platforms; otherwise, libc is
3080      * called with "" to get the actual value(s).  The simulation is needed
3081      * for:
3082      *
3083      *  1)  On Windows systems, the concept of the POSIX ordering of
3084      *      environment variables is missing.  To increase portability of
3085      *      programs across platforms, the POSIX ordering is emulated on
3086      *      Windows.
3087      *
3088      *  2)  On POSIX 2008 systems without querylocale(), it is problematic
3089      *      getting the results of the POSIX 2008 equivalent of
3090      *
3091      *          setlocale(category, "")
3092      *
3093      *      To ensure that we know exactly what those values are, we do the
3094      *      setting ourselves, using the documented algorithm specified by the
3095      *      POSIX standard (assuming the platform follows the Standard) rather
3096      *      than use "" as the locale.  This will lead to results that differ
3097      *      from native behavior if the native behavior differs from the
3098      *      Standard's documented value, but khw believes it is better to know
3099      *      what's going on, even if different from native, than to just guess.
3100      *
3101      *      glibc systems differ from this standard in having a LANGUAGE
3102      *      environment variable used for just LC_MESSAGES.  This function does
3103      *      NOT handle that.
3104      *
3105      *      Another option for the POSIX 2008 case would be, in a critical
3106      *      section, to save the global locale's current value, and do a
3107      *      straight setlocale(LC_ALL, "").  That would return our desired
3108      *      values, destroying the global locale's, which we would then
3109      *      restore.  But that could cause races with any other thread that is
3110      *      using the global locale and isn't using the mutex.  And, the only
3111      *      reason someone would have done that is because they are calling a
3112      *      library function, like in gtk, that calls setlocale(), and which
3113      *      can't be changed to use the mutex.  That wouldn't be a problem if
3114      *      this were to be done before any threads had switched, say during
3115      *      perl construction time.  But this code would still be needed for
3116      *      the general case.
3117      *
3118      * The Windows and POSIX 2008 differ in that the ultimate fallback is "C"
3119      * in POSIX, and is the system default locale in Windows.  To get that
3120      * system default value, we actually have to call setlocale() on Windows.
3121      */
3122
3123     const char * const lc_all = PerlEnv_getenv("LC_ALL");
3124     const char * locale_names[LC_ALL_INDEX_] = { NULL };
3125
3126     /* Use any "LC_ALL" environment variable, as it overrides everything else.
3127      * */
3128     if (lc_all && strNE(lc_all, "")) {
3129         return lc_all;
3130     }
3131
3132     /* Here, no usable LC_ALL environment variable.  We have to handle each
3133      * category separately.  If all categories are desired, we loop through
3134      * them all.  If only an individual category is desired, to avoid
3135      * duplicating logic, we use the same loop, but set up the limits so it is
3136      * only executed once, for that particular category. */
3137     locale_category_index lower, upper, offset;
3138     if (index == LC_ALL_INDEX_) {
3139         lower = (locale_category_index) 0;
3140         upper = (locale_category_index) ((int) LC_ALL_INDEX_ - 1);
3141         offset = (locale_category_index) 0;
3142     }
3143     else {
3144         lower = index;
3145         upper = index;
3146
3147         /* 'offset' is used so that the result of the single loop iteration is
3148          * stored into output[0] */
3149         offset = lower;
3150     }
3151
3152     /* When no LC_ALL environment variable, LANG is used as a default, but
3153      * overridden for individual categories that have corresponding environment
3154      * variables.  If no LANG exists, the default is "C" on POSIX 2008, or the
3155      * system default for the category on Windows. */
3156     const char * env_lang = NULL;
3157
3158     /* For each desired category, use any corresponding environment variable;
3159      * or the default if none such exists. */
3160     bool is_disparate = false;  /* Assume is uniform until proven otherwise */
3161     for (unsigned i = lower; i <= upper; i++) {
3162         const char * const env_override = PerlEnv_getenv(category_names[i]);
3163         unsigned int j = i - offset;
3164
3165         if (env_override && strNE(env_override, "")) {
3166             locale_names[j] = env_override;
3167         }
3168         else { /* Here, no corresponding environment variable, see if LANG
3169                   exists and is usable.  Done this way to avoid fetching LANG
3170                   unless it is actually needed */
3171             if (env_lang == NULL) {
3172                 env_lang = PerlEnv_getenv("LANG");
3173
3174                 /* If not usable, set it to a non-NULL illegal value so won't
3175                  * try to use it below */
3176                 if (env_lang == NULL || strEQ(env_lang, "")) {
3177                     env_lang = (const char *) 1;
3178                 }
3179             }
3180
3181             /* If a usable LANG exists, use it. */
3182             if (env_lang != NULL && env_lang != (const char *) 1) {
3183                 locale_names[j] = env_lang;
3184             }
3185             else {
3186
3187 #    ifdef WIN32
3188                 /* If no LANG, use the system default on Windows. */
3189                 locale_names[j] = wrap_wsetlocale(categories[i], ".ACP");
3190                 if (locale_names[j]) {
3191                     SAVEFREEPV(locale_names[j]);
3192                 }
3193                 else
3194 #    endif
3195                 {   /* If nothing was found or worked, use C */
3196                     locale_names[j] = "C";
3197                 }
3198             }
3199         }
3200
3201         if (j > 0 && ! is_disparate && strNE(locale_names[0], locale_names[j]))
3202         {
3203             is_disparate = true;
3204         }
3205
3206         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3207                  "find_locale_from_environment i=%u, j=%u, name=%s,"
3208                  " locale=%s, locale of 0th category=%s, disparate=%d\n",
3209                  i, j, category_names[i],
3210                  locale_names[j], locale_names[0], is_disparate));
3211     }
3212
3213     if (! is_disparate) {
3214         return locale_names[0];
3215     }
3216
3217     return calculate_LC_ALL_string(locale_names, INTERNAL_FORMAT,
3218                                    WANT_TEMP_PV,
3219                                    __LINE__);
3220 }
3221
3222 #  endif
3223 #  if defined(DEBUGGING) || defined(USE_PERL_SWITCH_LOCALE_CONTEXT)
3224
3225 STATIC const char *
3226 S_get_LC_ALL_display(pTHX)
3227 {
3228     return calculate_LC_ALL_string(NULL, INTERNAL_FORMAT,
3229                                    WANT_TEMP_PV,
3230                                    __LINE__);
3231 }
3232
3233 #  endif
3234
3235 STATIC void
3236 S_setlocale_failure_panic_via_i(pTHX_
3237                                 const locale_category_index cat_index,
3238                                 const char * current,
3239                                 const char * failed,
3240                                 const line_t proxy_caller_line,
3241                                 const line_t immediate_caller_line,
3242                                 const char * const higher_caller_file,
3243                                 const line_t higher_caller_line)
3244 {
3245     PERL_ARGS_ASSERT_SETLOCALE_FAILURE_PANIC_VIA_I;
3246
3247     /* Called to panic when a setlocale form unexpectedly failed for the
3248      * category determined by 'cat_index', and the locale that was in effect
3249      * (and likely still is) is 'current'.  'current' may be NULL, which causes
3250      * this function to query what it is.
3251      *
3252      * The extra caller information is used for when a function acts as a
3253      * stand-in for another function, which a typical reader would more likely
3254      * think would be the caller
3255      *
3256      * If a line number is 0, its stack (sort-of) frame is omitted; same if
3257      * it's the same line number as the next higher caller. */
3258
3259     const int cat = categories[cat_index];
3260     const char * name = category_names[cat_index];
3261
3262     dSAVE_ERRNO;
3263
3264     if (current == NULL) {
3265         current = querylocale_i(cat_index);
3266     }
3267
3268     const char * proxy_text = "";
3269     if (proxy_caller_line != 0 && proxy_caller_line != immediate_caller_line)
3270     {
3271         proxy_text = Perl_form(aTHX_ "\nCalled via %s: %" LINE_Tf,
3272                                       __FILE__, proxy_caller_line);
3273     }
3274     if (   strNE(__FILE__, higher_caller_file)
3275         || (   immediate_caller_line != 0
3276             && immediate_caller_line != higher_caller_line))
3277     {
3278         proxy_text = Perl_form(aTHX_ "%s\nCalled via %s: %" LINE_Tf,
3279                                       proxy_text, __FILE__,
3280                                       immediate_caller_line);
3281     }
3282
3283     /* 'false' in the get_displayable_string() calls makes it not think the
3284      * locale is UTF-8, so just dumps bytes.  Actually figuring it out can be
3285      * too complicated for a panic situation. */
3286     const char * msg = Perl_form(aTHX_
3287                             "Can't change locale for %s (%d) from '%s' to '%s'"
3288                             " %s",
3289                             name, cat,
3290                             get_displayable_string(current,
3291                                                    current + strlen(current),
3292                                                    false),
3293                             get_displayable_string(failed,
3294                                                    failed + strlen(failed),
3295                                                    false),
3296                             proxy_text);
3297     RESTORE_ERRNO;
3298
3299     Perl_locale_panic(msg, __LINE__, higher_caller_file, higher_caller_line);
3300     NOT_REACHED; /* NOTREACHED */
3301 }
3302
3303 /* Any of these will allow us to find the RADIX */
3304 #  if defined(USE_LOCALE_NUMERIC) && (   defined(HAS_SOME_LANGINFO)         \
3305                                       || defined(HAS_LOCALECONV)            \
3306                                       || defined(HAS_SNPRINTF))
3307 #    define CAN_CALCULATE_RADIX
3308 #  endif
3309 #  ifdef USE_LOCALE_NUMERIC
3310
3311 STATIC void
3312 S_new_numeric(pTHX_ const char *newnum, bool force)
3313 {
3314     PERL_ARGS_ASSERT_NEW_NUMERIC;
3315
3316     /* Called after each libc setlocale() or uselocale() call affecting
3317      * LC_NUMERIC, to tell core Perl this and that 'newnum' is the name of the
3318      * new locale, and we are switched into it.  It installs this locale as the
3319      * current underlying default, and then switches to the C locale, if
3320      * necessary, so that the code that has traditionally expected the radix
3321      * character to be a dot may continue to do so.
3322      *
3323      * The default locale and the C locale can be toggled between by use of the
3324      * set_numeric_underlying() and set_numeric_standard() functions, which
3325      * should probably not be called directly, but only via macros like
3326      * SET_NUMERIC_STANDARD() in perl.h.
3327      *
3328      * The toggling is necessary mainly so that a non-dot radix decimal point
3329      * character can be input and output, while allowing internal calculations
3330      * to use a dot.
3331      *
3332      * This sets several interpreter-level variables:
3333      * PL_numeric_name  The underlying locale's name: a copy of 'newnum'
3334      * PL_numeric_underlying   A boolean indicating if the toggled state is
3335      *                  such that the current locale is the program's
3336      *                  underlying locale
3337      * PL_numeric_standard   An int indicating if the toggled state is such
3338      *                  that the current locale is the C locale or
3339      *                  indistinguishable from the C locale.  If non-zero, it
3340      *                  is in C; if > 1, it means it may not be toggled away
3341      *                  from C.
3342      * PL_numeric_underlying_is_standard   A bool kept by this function
3343      *                  indicating that the underlying locale and the standard
3344      *                  C locale are indistinguishable for the purposes of
3345      *                  LC_NUMERIC.  This happens when both of the above two
3346      *                  variables are true at the same time.  (Toggling is a
3347      *                  no-op under these circumstances.)  This variable is
3348      *                  used to avoid having to recalculate.
3349      * PL_numeric_radix_sv   Contains the string that code should use for the
3350      *                  decimal point.  It is set to either a dot or the
3351      *                  program's underlying locale's radix character string,
3352      *                  depending on the situation.
3353      * PL_underlying_radix_sv   Contains the program's underlying locale's
3354      *                  radix character string.  This is copied into
3355      *                  PL_numeric_radix_sv when the situation warrants.  It
3356      *                  exists to avoid having to recalculate it when toggling.
3357      */
3358
3359     DEBUG_L( PerlIO_printf(Perl_debug_log,
3360                            "Called new_numeric with %s, PL_numeric_name=%s\n",
3361                            newnum, PL_numeric_name));
3362
3363     /* If not forcing this procedure, and there isn't actually a change from
3364      * our records, do nothing.  (Our records can be wrong when sync'ing to the
3365      * locale set up by an external library, hence the 'force' parameter) */
3366     if (! force && strEQ(PL_numeric_name, newnum)) {
3367         return;
3368     }
3369
3370     Safefree(PL_numeric_name);
3371     PL_numeric_name = savepv(newnum);
3372
3373     /* Handle the trivial case.  Since this is called at process
3374      * initialization, be aware that this bit can't rely on much being
3375      * available. */
3376     if (isNAME_C_OR_POSIX(PL_numeric_name)) {
3377         PL_numeric_standard = TRUE;
3378         PL_numeric_underlying_is_standard = TRUE;
3379         PL_numeric_underlying = TRUE;
3380         sv_setpv(PL_numeric_radix_sv, C_decimal_point);
3381         SvUTF8_off(PL_numeric_radix_sv);
3382         sv_setpv(PL_underlying_radix_sv, C_decimal_point);
3383         SvUTF8_off(PL_underlying_radix_sv);
3384         return;
3385     }
3386
3387     /* We are in the underlying locale until changed at the end of this
3388      * function */
3389     PL_numeric_underlying = TRUE;
3390
3391     char * radix = NULL;
3392     utf8ness_t utf8ness = UTF8NESS_IMMATERIAL;
3393
3394     /* Find and save this locale's radix character. */
3395     my_langinfo_c(RADIXCHAR, LC_NUMERIC, PL_numeric_name,
3396                   &radix, NULL, &utf8ness);
3397     sv_setpv(PL_underlying_radix_sv, radix);
3398
3399     if (utf8ness == UTF8NESS_YES) {
3400         SvUTF8_on(PL_underlying_radix_sv);
3401     }
3402     else {
3403         SvUTF8_off(PL_underlying_radix_sv);
3404     }
3405
3406     DEBUG_L(PerlIO_printf(Perl_debug_log,
3407                           "Locale radix is '%s', ?UTF-8=%d\n",
3408                           SvPVX(PL_underlying_radix_sv),
3409                           cBOOL(SvUTF8(PL_underlying_radix_sv))));
3410
3411     /* This locale is indistinguishable from C (for numeric purposes) if both
3412      * the radix character and the thousands separator are the same as C's.
3413      * Start with the radix. */
3414     PL_numeric_underlying_is_standard = strEQ(C_decimal_point, radix);
3415     Safefree(radix);
3416
3417 #    ifndef TS_W32_BROKEN_LOCALECONV
3418
3419     /* If the radix isn't the same as C's, we know it is distinguishable from
3420      * C; otherwise check the thousands separator too.  Only if both are the
3421      * same as C's is the locale indistinguishable from C.
3422      *
3423      * But on earlier Windows versions, there is a potential race.  This code
3424      * knows that localeconv() (elsewhere in this file) will be used to extract
3425      * the needed value, and localeconv() was buggy for quite a while, and that
3426      * code in this file hence uses a workaround.  And that workaround may have
3427      * an (unlikely) race.  Gathering the radix uses a different workaround on
3428      * Windows that doesn't involve a race.  It might be possible to do the
3429      * same for this (patches welcome).
3430      *
3431      * Until then khw doesn't think it's worth even the small risk of a race to
3432      * get this value, which doesn't appear to be used in any of the Microsoft
3433      * library routines anyway. */
3434
3435     char * scratch_buffer = NULL;
3436     if (PL_numeric_underlying_is_standard) {
3437         PL_numeric_underlying_is_standard = strEQ(C_thousands_sep,
3438                                              my_langinfo_c(THOUSEP, LC_NUMERIC,
3439                                                            PL_numeric_name,
3440                                                            &scratch_buffer,
3441                                                            NULL, NULL));
3442     }
3443     Safefree(scratch_buffer);
3444
3445 #    endif
3446
3447     PL_numeric_standard = PL_numeric_underlying_is_standard;
3448
3449     /* Keep LC_NUMERIC so that it has the C locale radix and thousands
3450      * separator.  This is for XS modules, so they don't have to worry about
3451      * the radix being a non-dot.  (Core operations that need the underlying
3452      * locale change to it temporarily). */
3453     if (! PL_numeric_standard) {
3454         set_numeric_standard(__FILE__, __LINE__);
3455     }
3456 }
3457
3458 #  endif
3459
3460 void
3461 Perl_set_numeric_standard(pTHX_ const char * const file, const line_t line)
3462 {
3463     PERL_ARGS_ASSERT_SET_NUMERIC_STANDARD;
3464     PERL_UNUSED_ARG(file);      /* Some Configurations ignore these */
3465     PERL_UNUSED_ARG(line);
3466
3467 #  ifdef USE_LOCALE_NUMERIC
3468
3469     /* Unconditionally toggle the LC_NUMERIC locale to the C locale
3470      *
3471      * Most code should use the macro SET_NUMERIC_STANDARD() in perl.h
3472      * instead of calling this directly.  The macro avoids calling this routine
3473      * if toggling isn't necessary according to our records (which could be
3474      * wrong if some XS code has changed the locale behind our back) */
3475
3476     DEBUG_L(PerlIO_printf(Perl_debug_log, "Setting LC_NUMERIC locale to"
3477                                           " standard C; called from %s: %"
3478                                           LINE_Tf "\n", file, line));
3479
3480     void_setlocale_c_with_caller(LC_NUMERIC, "C", file, line);
3481     PL_numeric_standard = TRUE;
3482     sv_setpv(PL_numeric_radix_sv, C_decimal_point);
3483     SvUTF8_off(PL_numeric_radix_sv);
3484
3485     PL_numeric_underlying = PL_numeric_underlying_is_standard;
3486
3487 #  endif /* USE_LOCALE_NUMERIC */
3488
3489 }
3490
3491 void
3492 Perl_set_numeric_underlying(pTHX_ const char * const file, const line_t line)
3493 {
3494     PERL_ARGS_ASSERT_SET_NUMERIC_UNDERLYING;
3495     PERL_UNUSED_ARG(file);      /* Some Configurations ignore these */
3496     PERL_UNUSED_ARG(line);
3497
3498 #  ifdef USE_LOCALE_NUMERIC
3499
3500     /* Unconditionally toggle the LC_NUMERIC locale to the current underlying
3501      * default.
3502      *
3503      * Most code should use the macro SET_NUMERIC_UNDERLYING() in perl.h
3504      * instead of calling this directly.  The macro avoids calling this routine
3505      * if toggling isn't necessary according to our records (which could be
3506      * wrong if some XS code has changed the locale behind our back) */
3507
3508     DEBUG_L(PerlIO_printf(Perl_debug_log, "Setting LC_NUMERIC locale to %s;"
3509                                           " called from %s: %" LINE_Tf "\n",
3510                                           PL_numeric_name, file, line));
3511     /* Maybe not in init? assert(PL_locale_mutex_depth > 0);*/
3512
3513     void_setlocale_c_with_caller(LC_NUMERIC, PL_numeric_name, file, line);
3514     PL_numeric_underlying = TRUE;
3515     sv_setsv_nomg(PL_numeric_radix_sv, PL_underlying_radix_sv);
3516
3517     PL_numeric_standard = PL_numeric_underlying_is_standard;
3518
3519 #  endif /* USE_LOCALE_NUMERIC */
3520
3521 }
3522
3523 #  ifdef USE_LOCALE_CTYPE
3524
3525 STATIC void
3526 S_new_ctype(pTHX_ const char *newctype, bool force)
3527 {
3528     PERL_ARGS_ASSERT_NEW_CTYPE;
3529     PERL_UNUSED_ARG(force);
3530
3531     /* Called after each libc setlocale() call affecting LC_CTYPE, to tell
3532      * core Perl this and that 'newctype' is the name of the new locale.
3533      *
3534      * This function sets up the folding arrays for all 256 bytes, assuming
3535      * that tofold() is tolc() since fold case is not a concept in POSIX,
3536      */
3537
3538     DEBUG_L(PerlIO_printf(Perl_debug_log, "Entering new_ctype(%s)\n",
3539                                           newctype));
3540
3541     /* No change means no-op */
3542     if (strEQ(PL_ctype_name, newctype)) {
3543         return;
3544     }
3545
3546     /* We will replace any bad locale warning with
3547      *  1)  nothing if the new one is ok; or
3548      *  2)  a new warning for the bad new locale */
3549     if (PL_warn_locale) {
3550         SvREFCNT_dec_NN(PL_warn_locale);
3551         PL_warn_locale = NULL;
3552     }
3553
3554     /* Clear cache */
3555     Safefree(PL_ctype_name);
3556     PL_ctype_name = "";
3557
3558     PL_in_utf8_turkic_locale = FALSE;
3559
3560     /* For the C locale, just use the standard folds, and we know there are no
3561      * glitches possible, so return early.  Since this is called at process
3562      * initialization, be aware that this bit can't rely on much being
3563      * available. */
3564     if (isNAME_C_OR_POSIX(newctype)) {
3565         Copy(PL_fold, PL_fold_locale, 256, U8);
3566         PL_ctype_name = savepv(newctype);
3567         PL_in_utf8_CTYPE_locale = FALSE;
3568         return;
3569     }
3570
3571     /* The cache being cleared signals the called function to compute a new
3572      * value */
3573     PL_in_utf8_CTYPE_locale = is_locale_utf8(newctype);
3574
3575     PL_ctype_name = savepv(newctype);
3576     bool maybe_utf8_turkic = FALSE;
3577
3578     /* Don't check for problems if we are suppressing the warnings */
3579     bool check_for_problems = ckWARN_d(WARN_LOCALE) || UNLIKELY(DEBUG_L_TEST);
3580
3581     if (PL_in_utf8_CTYPE_locale) {
3582
3583         /* A UTF-8 locale gets standard rules.  But note that code still has to
3584          * handle this specially because of the three problematic code points
3585          * */
3586         Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
3587
3588         /* UTF-8 locales can have special handling for 'I' and 'i' if they are
3589          * Turkic.  Make sure these two are the only anomalies.  (We don't
3590          * require towupper and towlower because they aren't in C89.) */
3591
3592 #    if defined(HAS_TOWUPPER) && defined (HAS_TOWLOWER)
3593
3594         if (towupper('i') == 0x130 && towlower('I') == 0x131)
3595
3596 #    else
3597
3598         if (toU8_UPPER_LC('i') == 'i' && toU8_LOWER_LC('I') == 'I')
3599
3600 #    endif
3601
3602         {
3603             /* This is how we determine it really is Turkic */
3604             check_for_problems = TRUE;
3605             maybe_utf8_turkic = TRUE;
3606         }
3607     }
3608     else {  /* Not a canned locale we know the values for.  Compute them */
3609
3610 #    ifdef DEBUGGING
3611
3612         bool has_non_ascii_fold = FALSE;
3613         bool found_unexpected = FALSE;
3614
3615         /* Under -DLv, see if there are any folds outside the ASCII range.
3616          * This factoid is used below */
3617         if (DEBUG_Lv_TEST) {
3618             for (unsigned i = 128; i < 256; i++) {
3619                 int j = LATIN1_TO_NATIVE(i);
3620                 if (toU8_LOWER_LC(j) != j || toU8_UPPER_LC(j) != j) {
3621                     has_non_ascii_fold = TRUE;
3622                     break;
3623                 }
3624             }
3625         }
3626
3627 #    endif
3628
3629         for (unsigned i = 0; i < 256; i++) {
3630             if (isU8_UPPER_LC(i))
3631                 PL_fold_locale[i] = (U8) toU8_LOWER_LC(i);
3632             else if (isU8_LOWER_LC(i))
3633                 PL_fold_locale[i] = (U8) toU8_UPPER_LC(i);
3634             else
3635                 PL_fold_locale[i] = (U8) i;
3636
3637 #    ifdef DEBUGGING
3638
3639             /* Most locales these days are supersets of ASCII.  When debugging
3640              * with -DLv, it is helpful to know what the exceptions to that are
3641              * in this locale */
3642             if (DEBUG_Lv_TEST) {
3643                 bool unexpected = FALSE;
3644
3645                 if (isUPPER_L1(i)) {
3646                     if (isUPPER_A(i)) {
3647                         if (PL_fold_locale[i] != toLOWER_A(i)) {
3648                             unexpected = TRUE;
3649                         }
3650                     }
3651                     else if (has_non_ascii_fold) {
3652                         if (PL_fold_locale[i] != toLOWER_L1(i)) {
3653                             unexpected = TRUE;
3654                         }
3655                     }
3656                     else if (PL_fold_locale[i] != i) {
3657                         unexpected = TRUE;
3658                     }
3659                 }
3660                 else if (   isLOWER_L1(i)
3661                          && i != LATIN_SMALL_LETTER_SHARP_S
3662                          && i != MICRO_SIGN)
3663                 {
3664                     if (isLOWER_A(i)) {
3665                         if (PL_fold_locale[i] != toUPPER_A(i)) {
3666                             unexpected = TRUE;
3667                         }
3668                     }
3669                     else if (has_non_ascii_fold) {
3670                         if (PL_fold_locale[i] != toUPPER_LATIN1_MOD(i)) {
3671                             unexpected = TRUE;
3672                         }
3673                     }
3674                     else if (PL_fold_locale[i] != i) {
3675                         unexpected = TRUE;
3676                     }
3677                 }
3678                 else if (PL_fold_locale[i] != i) {
3679                     unexpected = TRUE;
3680                 }
3681
3682                 if (unexpected) {
3683                     found_unexpected = TRUE;
3684                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3685                                            "For %s, fold of %02x is %02x\n",
3686                                            newctype, i, PL_fold_locale[i]));
3687                 }
3688             }
3689         }
3690
3691         if (found_unexpected) {
3692             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3693                                "All bytes not mentioned above either fold to"
3694                                " themselves or are the expected ASCII or"
3695                                " Latin1 ones\n"));
3696         }
3697         else {
3698             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
3699                                    "No nonstandard folds were found\n"));
3700 #    endif
3701
3702         }
3703     }
3704
3705 #    ifdef MB_CUR_MAX
3706
3707     /* We only handle single-byte locales (outside of UTF-8 ones); so if this
3708      * locale requires more than one byte, there are going to be BIG problems.
3709      * */
3710
3711     const int mb_cur_max = MB_CUR_MAX;
3712
3713     if (mb_cur_max > 1 && ! PL_in_utf8_CTYPE_locale
3714
3715             /* Some platforms return MB_CUR_MAX > 1 for even the "C" locale.
3716              * Just assume that the implementation for them (plus for POSIX) is
3717              * correct and the > 1 value is spurious.  (Since these are
3718              * specially handled to never be considered UTF-8 locales, as long
3719              * as this is the only problem, everything should work fine */
3720         && ! isNAME_C_OR_POSIX(newctype))
3721     {
3722         DEBUG_L(PerlIO_printf(Perl_debug_log,
3723                               "Unsupported, MB_CUR_MAX=%d\n", mb_cur_max));
3724
3725         Perl_ck_warner_d(aTHX_ packWARN(WARN_LOCALE),
3726                          "Locale '%s' is unsupported, and may crash the"
3727                          " interpreter",
3728                          newctype);
3729     }
3730
3731 #    endif
3732
3733     DEBUG_Lv(PerlIO_printf(Perl_debug_log, "check_for_problems=%d\n",
3734                                            check_for_problems));
3735
3736     /* We don't populate the other lists if a UTF-8 locale, but do check that
3737      * everything works as expected, unless checking turned off */
3738     if (check_for_problems) {
3739         /* Assume enough space for every character being bad.  4 spaces each
3740          * for the 94 printable characters that are output like "'x' "; and 5
3741          * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
3742          * NUL */
3743         char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ] = { '\0' };
3744         unsigned int bad_count = 0;         /* Count of bad characters */
3745
3746         for (unsigned i = 0; i < 256; i++) {
3747
3748             /* If checking for locale problems, see if the native ASCII-range
3749              * printables plus \n and \t are in their expected categories in
3750              * the new locale.  If not, this could mean big trouble, upending
3751              * Perl's and most programs' assumptions, like having a
3752              * metacharacter with special meaning become a \w.  Fortunately,
3753              * it's very rare to find locales that aren't supersets of ASCII
3754              * nowadays.  It isn't a problem for most controls to be changed
3755              * into something else; we check only \n and \t, though perhaps \r
3756              * could be an issue as well. */
3757             if (isGRAPH_A(i) || isBLANK_A(i) || i == '\n') {
3758                 bool is_bad = FALSE;
3759                 char name[4] = { '\0' };
3760
3761                 /* Convert the name into a string */
3762                 if (isGRAPH_A(i)) {
3763                     name[0] = i;
3764                     name[1] = '\0';
3765                 }
3766                 else if (i == '\n') {
3767                     my_strlcpy(name, "\\n", sizeof(name));
3768                 }
3769                 else if (i == '\t') {
3770                     my_strlcpy(name, "\\t", sizeof(name));
3771                 }
3772                 else {
3773                     assert(i == ' ');
3774                     my_strlcpy(name, "' '", sizeof(name));
3775                 }
3776
3777                 /* Check each possibe class */
3778                 if (UNLIKELY(cBOOL(isU8_ALPHANUMERIC_LC(i)) !=
3779                                                     cBOOL(isALPHANUMERIC_A(i))))
3780                 {
3781                     is_bad = TRUE;
3782                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3783                                         "isalnum('%s') unexpectedly is %x\n",
3784                                         name, cBOOL(isU8_ALPHANUMERIC_LC(i))));
3785                 }
3786                 if (UNLIKELY(cBOOL(isU8_ALPHA_LC(i)) != cBOOL(isALPHA_A(i))))  {
3787                     is_bad = TRUE;
3788                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3789                                           "isalpha('%s') unexpectedly is %x\n",
3790                                           name, cBOOL(isU8_ALPHA_LC(i))));
3791                 }
3792                 if (UNLIKELY(cBOOL(isU8_DIGIT_LC(i)) != cBOOL(isDIGIT_A(i))))  {
3793                     is_bad = TRUE;
3794                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3795                                           "isdigit('%s') unexpectedly is %x\n",
3796                                           name, cBOOL(isU8_DIGIT_LC(i))));
3797                 }
3798                 if (UNLIKELY(cBOOL(isU8_GRAPH_LC(i)) != cBOOL(isGRAPH_A(i))))  {
3799                     is_bad = TRUE;
3800                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3801                                           "isgraph('%s') unexpectedly is %x\n",
3802                                           name, cBOOL(isU8_GRAPH_LC(i))));
3803                 }
3804                 if (UNLIKELY(cBOOL(isU8_LOWER_LC(i)) != cBOOL(isLOWER_A(i))))  {
3805                     is_bad = TRUE;
3806                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3807                                           "islower('%s') unexpectedly is %x\n",
3808                                           name, cBOOL(isU8_LOWER_LC(i))));
3809                 }
3810                 if (UNLIKELY(cBOOL(isU8_PRINT_LC(i)) != cBOOL(isPRINT_A(i))))  {
3811                     is_bad = TRUE;
3812                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3813                                           "isprint('%s') unexpectedly is %x\n",
3814                                           name, cBOOL(isU8_PRINT_LC(i))));
3815                 }
3816                 if (UNLIKELY(cBOOL(isU8_PUNCT_LC(i)) != cBOOL(isPUNCT_A(i))))  {
3817                     is_bad = TRUE;
3818                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3819                                           "ispunct('%s') unexpectedly is %x\n",
3820                                           name, cBOOL(isU8_PUNCT_LC(i))));
3821                 }
3822                 if (UNLIKELY(cBOOL(isU8_SPACE_LC(i)) != cBOOL(isSPACE_A(i))))  {
3823                     is_bad = TRUE;
3824                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3825                                           "isspace('%s') unexpectedly is %x\n",
3826                                           name, cBOOL(isU8_SPACE_LC(i))));
3827                 }
3828                 if (UNLIKELY(cBOOL(isU8_UPPER_LC(i)) != cBOOL(isUPPER_A(i))))  {
3829                     is_bad = TRUE;
3830                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3831                                           "isupper('%s') unexpectedly is %x\n",
3832                                           name, cBOOL(isU8_UPPER_LC(i))));
3833                 }
3834                 if (UNLIKELY(cBOOL(isU8_XDIGIT_LC(i))!= cBOOL(isXDIGIT_A(i)))) {
3835                     is_bad = TRUE;
3836                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3837                                           "isxdigit('%s') unexpectedly is %x\n",
3838                                           name, cBOOL(isU8_XDIGIT_LC(i))));
3839                 }
3840                 if (UNLIKELY(toU8_LOWER_LC(i) != (int) toLOWER_A(i))) {
3841                     is_bad = TRUE;
3842                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3843                             "tolower('%s')=0x%x instead of the expected 0x%x\n",
3844                             name, toU8_LOWER_LC(i), (int) toLOWER_A(i)));
3845                 }
3846                 if (UNLIKELY(toU8_UPPER_LC(i) != (int) toUPPER_A(i))) {
3847                     is_bad = TRUE;
3848                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3849                             "toupper('%s')=0x%x instead of the expected 0x%x\n",
3850                             name, toU8_UPPER_LC(i), (int) toUPPER_A(i)));
3851                 }
3852                 if (UNLIKELY((i == '\n' && ! isCNTRL_LC(i))))  {
3853                     is_bad = TRUE;
3854                     DEBUG_L(PerlIO_printf(Perl_debug_log,
3855                                 "'\\n' (=%02X) is not a control\n", (int) i));
3856                 }
3857
3858                 /* Add to the list;  Separate multiple entries with a blank */
3859                 if (is_bad) {
3860                     if (bad_count) {
3861                         my_strlcat(bad_chars_list, " ", sizeof(bad_chars_list));
3862                     }
3863                     my_strlcat(bad_chars_list, name, sizeof(bad_chars_list));
3864                     bad_count++;
3865                 }
3866             }
3867         }
3868
3869         if (bad_count == 2 && maybe_utf8_turkic) {
3870             bad_count = 0;
3871             *bad_chars_list = '\0';
3872
3873             /* The casts are because otherwise some compilers warn:
3874                 gcc.gnu.org/bugzilla/show_bug.cgi?id=99950
3875                 gcc.gnu.org/bugzilla/show_bug.cgi?id=94182
3876              */
3877             PL_fold_locale[ (U8) 'I' ] = 'I';
3878             PL_fold_locale[ (U8) 'i' ] = 'i';
3879             PL_in_utf8_turkic_locale = TRUE;
3880             DEBUG_L(PerlIO_printf(Perl_debug_log, "%s is turkic\n", newctype));
3881         }
3882
3883         /* If we found problems and we want them output, do so */
3884         if (   (UNLIKELY(bad_count))
3885             && (LIKELY(ckWARN_d(WARN_LOCALE)) || UNLIKELY(DEBUG_L_TEST)))
3886         {
3887             /* WARNING.  If you change the wording of these; be sure to update
3888              * t/loc_tools.pl correspondingly */
3889
3890             if (PL_in_utf8_CTYPE_locale) {
3891                 PL_warn_locale = Perl_newSVpvf(aTHX_
3892                      "Locale '%s' contains (at least) the following characters"
3893                      " which have\nunexpected meanings: %s\nThe Perl program"
3894                      " will use the expected meanings",
3895                       newctype, bad_chars_list);
3896             }
3897             else {
3898                 PL_warn_locale =
3899                     Perl_newSVpvf(aTHX_
3900                                   "\nThe following characters (and maybe"
3901                                   " others) may not have the same meaning as"
3902                                   " the Perl program expects: %s\n",
3903                                   bad_chars_list
3904                             );
3905             }
3906
3907 #    if defined(HAS_SOME_LANGINFO) || defined(WIN32)
3908
3909             char * scratch_buffer = NULL;
3910             Perl_sv_catpvf(aTHX_ PL_warn_locale, "; codeset=%s",
3911                                  my_langinfo_c(CODESET, LC_CTYPE,
3912                                                newctype,
3913                                                &scratch_buffer, NULL,
3914                                                NULL));
3915             Safefree(scratch_buffer);
3916
3917 #    endif
3918
3919             Perl_sv_catpvf(aTHX_ PL_warn_locale, "\n");
3920
3921             /* If we are actually in the scope of the locale or are debugging,
3922              * output the message now.  If not in that scope, we save the
3923              * message to be output at the first operation using this locale,
3924              * if that actually happens.  Most programs don't use locales, so
3925              * they are immune to bad ones.  */
3926             if (IN_LC(LC_CTYPE) || UNLIKELY(DEBUG_L_TEST)) {
3927
3928                 /* The '0' below suppresses a bogus gcc compiler warning */
3929                 Perl_warner(aTHX_ packWARN(WARN_LOCALE), SvPVX(PL_warn_locale),
3930                                                                             0);
3931                 if (IN_LC(LC_CTYPE)) {
3932                     SvREFCNT_dec_NN(PL_warn_locale);
3933                     PL_warn_locale = NULL;
3934                 }
3935             }
3936         }
3937     }
3938 }
3939
3940 void
3941 Perl_warn_problematic_locale()
3942 {
3943     dTHX;
3944
3945     /* Core-only function that outputs the message in PL_warn_locale,
3946      * and then NULLS it.  Should be called only through the macro
3947      * CHECK_AND_WARN_PROBLEMATIC_LOCALE_ */
3948
3949     if (PL_warn_locale) {
3950         Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3951                              SvPVX(PL_warn_locale),
3952                              0 /* dummy to avoid compiler warning */ );
3953         SvREFCNT_dec_NN(PL_warn_locale);
3954         PL_warn_locale = NULL;
3955     }
3956 }
3957
3958 #  endif /* USE_LOCALE_CTYPE */
3959
3960 STATIC void
3961 S_new_LC_ALL(pTHX_ const char *lc_all, bool force)
3962 {
3963     PERL_ARGS_ASSERT_NEW_LC_ALL;
3964
3965     /* new_LC_ALL() updates all the things we care about.  Note that this is
3966      * called just after a change, so uses the actual underlying locale just
3967      * set, and not the nominal one (should they differ, as they may in
3968      * LC_NUMERIC). */
3969
3970     const char * individ_locales[LC_ALL_INDEX_] = { NULL };
3971
3972     switch (parse_LC_ALL_string(lc_all,
3973                                 individ_locales,
3974                                 override_if_ignored,   /* Override any ignored
3975                                                           categories */
3976                                 true,   /* Always fill array */
3977                                 true,   /* Panic if fails, as to get here it
3978                                            earlier had to have succeeded */
3979                                 __LINE__))
3980     {
3981       case invalid:
3982       case no_array:
3983       case only_element_0:
3984         locale_panic_("Unexpected return from parse_LC_ALL_string");
3985
3986       case full_array:
3987         break;
3988     }
3989
3990     for_all_individual_category_indexes(i) {
3991         if (update_functions[i]) {
3992             const char * this_locale = individ_locales[i];
3993             update_functions[i](aTHX_ this_locale, force);
3994         }
3995
3996         Safefree(individ_locales[i]);
3997     }
3998 }
3999
4000 #  ifdef USE_LOCALE_COLLATE
4001
4002 STATIC void
4003 S_new_collate(pTHX_ const char *newcoll, bool force)
4004 {
4005     PERL_ARGS_ASSERT_NEW_COLLATE;
4006     PERL_UNUSED_ARG(force);
4007
4008     /* Called after each libc setlocale() call affecting LC_COLLATE, to tell
4009      * core Perl this and that 'newcoll' is the name of the new locale.
4010      *
4011      * The design of locale collation is that every locale change is given an
4012      * index 'PL_collation_ix'.  The first time a string participates in an
4013      * operation that requires collation while locale collation is active, it
4014      * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()).  That
4015      * magic includes the collation index, and the transformation of the string
4016      * by strxfrm(), q.v.  That transformation is used when doing comparisons,
4017      * instead of the string itself.  If a string changes, the magic is
4018      * cleared.  The next time the locale changes, the index is incremented,
4019      * and so we know during a comparison that the transformation is not
4020      * necessarily still valid, and so is recomputed.  Note that if the locale
4021      * changes enough times, the index could wrap, and it is possible that a
4022      * transformation would improperly be considered valid, leading to an
4023      * unlikely bug.  The value is declared to the widest possible type on this
4024      * platform. */
4025
4026     /* Return if the locale isn't changing */
4027     if (strEQ(PL_collation_name, newcoll)) {
4028         return;
4029     }
4030
4031     Safefree(PL_collation_name);
4032     PL_collation_name = savepv(newcoll);
4033     ++PL_collation_ix;
4034
4035     /* Set the new one up if trivial.  Since this is called at process
4036      * initialization, be aware that this bit can't rely on much being
4037      * available. */
4038     PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
4039     if (PL_collation_standard) {
4040         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
4041                                "Setting PL_collation name='%s'\n",
4042                                PL_collation_name));
4043         PL_collxfrm_base = 0;
4044         PL_collxfrm_mult = 2;
4045         PL_in_utf8_COLLATE_locale = FALSE;
4046         PL_strxfrm_NUL_replacement = '\0';
4047         PL_strxfrm_max_cp = 0;
4048         return;
4049     }
4050
4051     /* Flag that the remainder of the set up is being deferred until first
4052      * need. */
4053     PL_collxfrm_mult = 0;
4054     PL_collxfrm_base = 0;
4055
4056 }
4057
4058 #  endif /* USE_LOCALE_COLLATE */
4059
4060 #  ifdef WIN32
4061
4062 STATIC wchar_t *
4063 S_Win_byte_string_to_wstring(const UINT code_page, const char * byte_string)
4064 {
4065     /* Caller must arrange to free the returned string */
4066
4067     int req_size = MultiByteToWideChar(code_page, 0, byte_string, -1, NULL, 0);
4068     if (! req_size) {
4069         SET_EINVAL;
4070         return NULL;
4071     }
4072
4073     wchar_t *wstring;
4074     Newx(wstring, req_size, wchar_t);
4075
4076     if (! MultiByteToWideChar(code_page, 0, byte_string, -1, wstring, req_size))
4077     {
4078         Safefree(wstring);
4079         SET_EINVAL;
4080         return NULL;
4081     }
4082
4083     return wstring;
4084 }
4085
4086 #    define Win_utf8_string_to_wstring(s)                                   \
4087                                     Win_byte_string_to_wstring(CP_UTF8, (s))
4088
4089 STATIC char *
4090 S_Win_wstring_to_byte_string(const UINT code_page, const wchar_t * wstring)
4091 {
4092     /* Caller must arrange to free the returned string */
4093
4094     int req_size =
4095             WideCharToMultiByte(code_page, 0, wstring, -1, NULL, 0, NULL, NULL);
4096
4097     char *byte_string;
4098     Newx(byte_string, req_size, char);
4099
4100     if (! WideCharToMultiByte(code_page, 0, wstring, -1, byte_string,
4101                                                          req_size, NULL, NULL))
4102     {
4103         Safefree(byte_string);
4104         SET_EINVAL;
4105         return NULL;
4106     }
4107
4108     return byte_string;
4109 }
4110
4111 #    define Win_wstring_to_utf8_string(ws)                                  \
4112                                    Win_wstring_to_byte_string(CP_UTF8, (ws))
4113
4114 STATIC const char *
4115 S_wrap_wsetlocale(pTHX_ const int category, const char *locale)
4116 {
4117     PERL_ARGS_ASSERT_WRAP_WSETLOCALE;
4118
4119     /* Calls _wsetlocale(), converting the parameters/return to/from
4120      * Perl-expected forms as if plain setlocale() were being called instead.
4121      *
4122      * Caller must arrange for the returned PV to be freed.
4123      */
4124
4125     const wchar_t * wlocale = NULL;
4126
4127     if (locale) {
4128         wlocale = Win_utf8_string_to_wstring(locale);
4129         if (! wlocale) {
4130             return NULL;
4131         }
4132     }
4133
4134     WSETLOCALE_LOCK;
4135     const wchar_t * wresult = _wsetlocale(category, wlocale);
4136
4137     if (! wresult) {
4138         WSETLOCALE_UNLOCK;
4139         Safefree(wlocale);
4140         return NULL;
4141     }
4142
4143     const char * result = Win_wstring_to_utf8_string(wresult);
4144     WSETLOCALE_UNLOCK;
4145
4146     Safefree(wlocale);
4147     return result;
4148 }
4149
4150 STATIC const char *
4151 S_win32_setlocale(pTHX_ int category, const char* locale)
4152 {
4153     /* This, for Windows, emulates POSIX setlocale() behavior.  There is no
4154      * difference between the two unless the input locale is "", which normally
4155      * means on Windows to get the machine default, which is set via the
4156      * computer's "Regional and Language Options" (or its current equivalent).
4157      * In POSIX, it instead means to find the locale from the user's
4158      * environment.  This routine changes the Windows behavior to try the POSIX
4159      * behavior first.  Further details are in the called function
4160      * find_locale_from_environment().
4161      */
4162
4163     if (locale != NULL && strEQ(locale, "")) {
4164         /* Note this function may change the locale, but that's ok because we
4165          * are about to change it anyway */
4166         locale = find_locale_from_environment(get_category_index(category));
4167         if (locale == NULL) {
4168             SET_EINVAL;
4169             return NULL;
4170         }
4171     }
4172
4173     const char * result = wrap_wsetlocale(category, locale);
4174     DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",
4175                           setlocale_debug_string_r(category, locale, result)));
4176
4177     if (! result) {
4178         SET_EINVAL;
4179         return NULL;
4180     }
4181
4182     save_to_buffer(result, &PL_setlocale_buf, &PL_setlocale_bufsize);
4183
4184 #    ifndef USE_PL_CUR_LC_ALL
4185
4186     Safefree(result);
4187
4188 #  else
4189
4190     /* Here, we need to keep track of LC_ALL, so store the new value.  but if
4191      * the input locale is NULL, we were just querying, so the original value
4192      * hasn't changed */
4193     if (locale == NULL) {
4194         Safefree(result);
4195     }
4196     else {
4197
4198         /* If we set LC_ALL directly above, we already know its new value; but
4199          * if we changed just an individual category, find the new LC_ALL */
4200         if (category != LC_ALL) {
4201             Safefree(result);
4202             result = wrap_wsetlocale(LC_ALL, NULL);
4203         }
4204
4205         Safefree(PL_cur_LC_ALL);
4206         PL_cur_LC_ALL = result;
4207     }
4208
4209     DEBUG_L(PerlIO_printf(Perl_debug_log, "new PL_cur_LC_ALL=%s\n",
4210                                           PL_cur_LC_ALL));
4211 #    endif
4212
4213     return PL_setlocale_buf;
4214 }
4215
4216 #  endif
4217
4218 STATIC const char *
4219 S_native_querylocale_i(pTHX_ const locale_category_index cat_index)
4220 {
4221     /* Determine the current locale and return it in the form the platform's
4222      * native locale handling understands.  This is different only from our
4223      * internal form for the LC_ALL category, as platforms differ in how they
4224      * represent that.
4225      *
4226      * This is only called from Perl_setlocale().  As such it returns in
4227      * PL_setlocale_buf */
4228
4229 #  ifdef USE_LOCALE_NUMERIC
4230
4231     /* We have the LC_NUMERIC name saved, because we are normally switched into
4232      * the C locale (or equivalent) for it. */
4233     if (cat_index == LC_NUMERIC_INDEX_) {
4234
4235         /* We don't have to copy this return value, as it is a per-thread
4236          * variable, and won't change until a future setlocale */
4237         return PL_numeric_name;
4238     }
4239
4240 #  endif
4241 #  ifdef LC_ALL
4242
4243     if (cat_index != LC_ALL_INDEX_)
4244
4245 #  endif
4246
4247     {
4248         /* Here, not LC_ALL, and not LC_NUMERIC: the actual and native values
4249          * match */
4250
4251 #  ifdef setlocale_i    /* Can shortcut if this is defined */
4252
4253         return setlocale_i(cat_index, NULL);
4254
4255 #  else
4256
4257         return save_to_buffer(querylocale_i(cat_index),
4258                               &PL_setlocale_buf, &PL_setlocale_bufsize);
4259 #  endif
4260
4261     }
4262
4263     /* Below, querying LC_ALL */
4264
4265 #  ifdef LC_ALL
4266 #    ifdef USE_PL_CURLOCALES
4267 #      define LC_ALL_ARG  PL_curlocales
4268 #    else
4269 #      define LC_ALL_ARG  NULL  /* Causes calculate_LC_ALL_string() to find the
4270                                    locale using a querylocale function */
4271 #    endif
4272
4273     return calculate_LC_ALL_string(LC_ALL_ARG, EXTERNAL_FORMAT_FOR_QUERY,
4274                                    WANT_PL_setlocale_buf,
4275                                    __LINE__);
4276 #    undef LC_ALL_ARG
4277 #  endif    /* has LC_ALL */
4278
4279 }
4280
4281 #endif      /* USE_LOCALE */
4282
4283 /*
4284 =for apidoc Perl_setlocale
4285
4286 This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
4287 taking the same parameters, and returning the same information, except that it
4288 returns the correct underlying C<LC_NUMERIC> locale.  Regular C<setlocale> will
4289 instead return C<C> if the underlying locale has a non-dot decimal point
4290 character, or a non-empty thousands separator for displaying floating point
4291 numbers.  This is because perl keeps that locale category such that it has a
4292 dot and empty separator, changing the locale briefly during the operations
4293 where the underlying one is required. C<Perl_setlocale> knows about this, and
4294 compensates; regular C<setlocale> doesn't.
4295
4296 Another reason it isn't completely a drop-in replacement is that it is
4297 declared to return S<C<const char *>>, whereas the system setlocale omits the
4298 C<const> (presumably because its API was specified long ago, and can't be
4299 updated; it is illegal to change the information C<setlocale> returns; doing
4300 so leads to segfaults.)
4301
4302 Finally, C<Perl_setlocale> works under all circumstances, whereas plain
4303 C<setlocale> can be completely ineffective on some platforms under some
4304 configurations.
4305
4306 Changing the locale is not a good idea when more than one thread is running,
4307 except on systems where the predefined variable C<${^SAFE_LOCALES}> is
4308 non-zero.  This is because on such systems the locale is global to the whole
4309 process and not local to just the thread calling the function.  So changing it
4310 in one thread instantaneously changes it in all.  On some such systems, the
4311 system C<setlocale()> is ineffective, returning the wrong information, and
4312 failing to actually change the locale.  z/OS refuses to try to change the
4313 locale once a second thread is created.  C<Perl_setlocale>, should give you
4314 accurate results of what actually happened on these problematic platforms,
4315 returning NULL if the system forbade the locale change.
4316
4317 The return points to a per-thread static buffer, which is overwritten the next
4318 time C<Perl_setlocale> is called from the same thread.
4319
4320 =cut
4321
4322 */
4323
4324 const char *
4325 Perl_setlocale(const int category, const char * locale)
4326 {
4327     /* This wraps POSIX::setlocale() */
4328
4329 #ifndef USE_LOCALE
4330
4331     PERL_UNUSED_ARG(category);
4332     PERL_UNUSED_ARG(locale);
4333
4334     return "C";
4335
4336 #else
4337
4338     dTHX;
4339
4340     DEBUG_L(PerlIO_printf(Perl_debug_log,
4341                           "Entering Perl_setlocale(%d, \"%s\")\n",
4342                           category, locale));
4343
4344     bool valid_category;
4345     locale_category_index cat_index = get_category_index_helper(category,
4346                                                                 &valid_category,
4347                                                                 __LINE__);
4348     if (! valid_category) {
4349         if (ckWARN(WARN_LOCALE)) {
4350             const char * conditional_warn_text;
4351             if (locale == NULL) {
4352                 conditional_warn_text = "";
4353                 locale = "";
4354             }
4355             else {
4356                 conditional_warn_text = "; can't set it to ";
4357             }
4358
4359             /* diag_listed_as: Unknown locale category %d; can't set it to %s */
4360             Perl_warner(aTHX_
4361                            packWARN(WARN_LOCALE),
4362                            "Unknown locale category %d%s%s",
4363                            category, conditional_warn_text, locale);
4364         }
4365
4366         SET_EINVAL;
4367         return NULL;
4368     }
4369
4370 #  ifdef setlocale_i
4371
4372     /* setlocale_i() gets defined only on Configurations that use setlocale()
4373      * in a simple manner that adequately handles all cases.  If this category
4374      * doesn't have any perl complications, just do that. */
4375     if (! update_functions[cat_index]) {
4376         return setlocale_i(cat_index, locale);
4377     }
4378
4379 #  endif
4380
4381     /* Get current locale */
4382     const char * current_locale = native_querylocale_i(cat_index);
4383
4384     /* A NULL locale means only query what the current one is. */
4385     if (locale == NULL) {
4386         return current_locale;
4387     }
4388
4389     if (strEQ(current_locale, locale)) {
4390         DEBUG_L(PerlIO_printf(Perl_debug_log,
4391                              "Already in requested locale: no action taken\n"));
4392         return current_locale;
4393     }
4394
4395     /* Here, an actual change is being requested.  Do it */
4396     if (! bool_setlocale_i(cat_index, locale)) {
4397         DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",
4398                           setlocale_debug_string_i(cat_index, locale, "NULL")));
4399         return NULL;
4400     }
4401
4402     /* At this point, the locale has been changed based on the requested value,
4403      * and the querylocale_i() will return the actual new value that the system
4404      * has for the category.  That may not be the same as the input, as libc
4405      * may have returned a synonymous locale name instead of the input one; or,
4406      * if there are locale categories that we are compiled to ignore, any
4407      * attempt to change them away from "C" is overruled */
4408     current_locale = querylocale_i(cat_index);
4409
4410     /* But certain categories need further work.  For example we may need to
4411      * calculate new folding or collation rules.  And for LC_NUMERIC, we have
4412      * to switch into a locale that has a dot radix. */
4413     if (update_functions[cat_index]) {
4414         update_functions[cat_index](aTHX_ current_locale,
4415                                           /* No need to force recalculation, as
4416                                            * aren't coming from a situation
4417                                            * where Perl hasn't been controlling
4418                                            * the locale, so has accurate
4419                                            * records. */
4420                                           false);
4421     }
4422
4423     /* Make sure the result is in a stable buffer for the caller's use, and is
4424      * in the expected format */
4425     current_locale = native_querylocale_i(cat_index);
4426
4427     DEBUG_L(PerlIO_printf(Perl_debug_log, "returning '%s'\n", current_locale));
4428
4429     return current_locale;
4430
4431 #endif
4432
4433 }
4434
4435 #if defined(USE_LOCALE) || defined(HAS_SOME_LANGINFO) || defined(HAS_LOCALECONV)
4436
4437 STATIC utf8ness_t
4438 S_get_locale_string_utf8ness_i(pTHX_ const char * string,
4439                                      const locale_utf8ness_t known_utf8,
4440                                      const char * locale,
4441                                      const locale_category_index cat_index)
4442 {
4443     PERL_ARGS_ASSERT_GET_LOCALE_STRING_UTF8NESS_I;
4444
4445 #  ifndef USE_LOCALE
4446
4447     return UTF8NESS_NO;
4448     PERL_UNUSED_ARG(string);
4449     PERL_UNUSED_ARG(known_utf8);
4450     PERL_UNUSED_ARG(locale);
4451     PERL_UNUSED_ARG(cat_index);
4452
4453 #  else
4454
4455     assert(cat_index <= LC_ALL_INDEX_);
4456
4457     /* Return to indicate if 'string' in the locale given by the input
4458      * arguments should be considered UTF-8 or not.
4459      *
4460      * If the input 'locale' is not NULL, use that for the locale; otherwise
4461      * use the current locale for the category specified by 'cat_index'.
4462      */
4463
4464     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
4465                            "Entering get_locale_string_utf8ness_i; locale=%s,"
4466                            " index=%u(%s), string=%s, known_utf8=%d\n",
4467                            locale, cat_index, category_names[cat_index],
4468                            ((string)
4469                             ?  _byte_dump_string((U8 *) string,
4470                                                  strlen(string),
4471                                                  0)
4472                             : "nil"),
4473                            known_utf8));
4474     if (string == NULL) {
4475         return UTF8NESS_IMMATERIAL;
4476     }
4477
4478     if (IN_BYTES) { /* respect 'use bytes' */
4479         return UTF8NESS_NO;
4480     }
4481
4482     Size_t len = strlen(string);
4483
4484     /* UTF8ness is immaterial if the representation doesn't vary */
4485     const U8 * first_variant = NULL;
4486     if (is_utf8_invariant_string_loc((U8 *) string, len, &first_variant)) {
4487         return UTF8NESS_IMMATERIAL;
4488     }
4489
4490     /* Can't be UTF-8 if invalid */
4491     if (! is_utf8_string((U8 *) first_variant,
4492                          len - ((char *) first_variant - string)))
4493     {
4494         return UTF8NESS_NO;
4495     }
4496
4497     /* Here and below, we know the string is legal UTF-8, containing at least
4498      * one character requiring a sequence of two or more bytes.  It is quite
4499      * likely to be UTF-8.  But it pays to be paranoid and do further checking.
4500      *
4501      * If we already know the UTF-8ness of the locale, then we immediately know
4502      * what the string is */
4503     if (UNLIKELY(known_utf8 != LOCALE_UTF8NESS_UNKNOWN)) {
4504         if (known_utf8 == LOCALE_IS_UTF8) {
4505             return UTF8NESS_YES;
4506         }
4507         else {
4508             return UTF8NESS_NO;
4509         }
4510     }
4511
4512 #    ifdef HAS_RELIABLE_UTF8NESS_DETERMINATION
4513
4514     /* Here, we have available the libc functions that can be used to
4515      * accurately determine the UTF8ness of the underlying locale.  If it is a
4516      * UTF-8 locale, the string is UTF-8;  otherwise it was coincidental that
4517      * the string is legal UTF-8
4518      *
4519      * However, if the perl is compiled to not pay attention to the category
4520      * being passed in, you might think that that locale is essentially always
4521      * the C locale, so it would make sense to say it isn't UTF-8.  But to get
4522      * here, the string has to contain characters unknown in the C locale.  And
4523      * in fact, Windows boxes are compiled without LC_MESSAGES, as their
4524      * message catalog isn't really a part of the locale system.  But those
4525      * messages really could be UTF-8, and given that the odds are rather small
4526      * of something not being UTF-8 but being syntactically valid UTF-8, khw
4527      * has decided to call such strings as UTF-8. */
4528
4529     if (locale == NULL) {
4530         locale = querylocale_i(cat_index);
4531     }
4532
4533     if (is_locale_utf8(locale)) {
4534         return UTF8NESS_YES;
4535     }
4536
4537     return UTF8NESS_NO;
4538
4539 #    else
4540
4541     /* Here, we have a valid UTF-8 string containing non-ASCII characters, and
4542      * don't have access to functions to check if the locale is UTF-8 or not.
4543      * Assume that it is.  khw tried adding a check that the string is entirely
4544      * in a single Unicode script, but discovered the strftime() timezone is
4545      * user-settable through the environment, which may be in a different
4546      * script than the locale-expected value. */
4547     PERL_UNUSED_ARG(locale);
4548     PERL_UNUSED_ARG(cat_index);
4549
4550     return UTF8NESS_YES;
4551
4552 #    endif
4553 #  endif
4554
4555 }
4556
4557 STATIC bool
4558 S_is_locale_utf8(pTHX_ const char * locale)
4559 {
4560     /* Returns TRUE if the locale 'locale' is UTF-8; FALSE otherwise.  It uses
4561      * my_langinfo(), which employs various methods to get this information
4562      * if nl_langinfo() isn't available, using heuristics as a last resort, in
4563      * which case, the result will very likely be correct for locales for
4564      * languages that have commonly used non-ASCII characters, but for notably
4565      * English, it comes down to if the locale's name ends in something like
4566      * "UTF-8".  It errs on the side of not being a UTF-8 locale.
4567      *
4568      * Systems conforming to C99 should have the needed libc calls to give us a
4569      * completely reliable result. */
4570
4571 #  if ! defined(USE_LOCALE)                                                   \
4572    || ! defined(USE_LOCALE_CTYPE)                                             \
4573    ||   defined(EBCDIC) /* There aren't any real UTF-8 locales at this time */
4574
4575     PERL_UNUSED_ARG(locale);
4576
4577     return FALSE;
4578
4579 #  else
4580
4581     char * scratch_buffer = NULL;
4582     const char * codeset;
4583     bool retval;
4584
4585     PERL_ARGS_ASSERT_IS_LOCALE_UTF8;
4586
4587     if (strEQ(locale, PL_ctype_name)) {
4588         return PL_in_utf8_CTYPE_locale;
4589     }
4590
4591     codeset = my_langinfo_c(CODESET, LC_CTYPE, locale,
4592                             &scratch_buffer, NULL, NULL);
4593     retval = is_codeset_name_UTF8(codeset);
4594
4595     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
4596                            "found codeset=%s, is_utf8=%d\n", codeset, retval));
4597
4598     Safefree(scratch_buffer);
4599
4600     DEBUG_Lv(PerlIO_printf(Perl_debug_log, "is_locale_utf8(%s) returning %d\n",
4601                                                             locale, retval));
4602     return retval;
4603
4604 #  endif
4605
4606 }
4607
4608 #endif
4609 #ifdef USE_LOCALE
4610
4611 STATIC void
4612 S_set_save_buffer_min_size(pTHX_ Size_t min_len,
4613                                  char **buf,
4614                                  Size_t * buf_cursize)
4615 {
4616     /* Make sure the buffer pointed to by *buf is at least as large 'min_len';
4617      * *buf_cursize is the size of 'buf' upon entry; it will be updated to the
4618      * new size on exit.  'buf_cursize' being NULL is to be used when this is a
4619      * single use buffer, which will shortly be freed by the caller. */
4620
4621     if (buf_cursize == NULL) {
4622         Newx(*buf, min_len, char);
4623     }
4624     else if (*buf_cursize == 0) {
4625         Newx(*buf, min_len, char);
4626         *buf_cursize = min_len;
4627     }
4628     else if (min_len > *buf_cursize) {
4629         Renew(*buf, min_len, char);
4630         *buf_cursize = min_len;
4631     }
4632 }
4633
4634 STATIC const char *
4635 S_save_to_buffer(pTHX_ const char * string, char **buf, Size_t *buf_size)
4636 {
4637     PERL_ARGS_ASSERT_SAVE_TO_BUFFER;
4638
4639     /* Copy the NUL-terminated 'string' to a buffer whose address before this
4640      * call began at *buf, and whose available length before this call was
4641      * *buf_size.
4642      *
4643      * If the length of 'string' is greater than the space available, the
4644      * buffer is grown accordingly, which may mean that it gets relocated.
4645      * *buf and *buf_size will be updated to reflect this.
4646      *
4647      * Regardless, the function returns a pointer to where 'string' is now
4648      * stored.
4649      *
4650      * 'string' may be NULL, which means no action gets taken, and NULL is
4651      * returned.
4652      *
4653      * 'buf_size' being NULL is to be used when this is a single use buffer,
4654      * which will shortly be freed by the caller.
4655      *
4656      * If *buf or 'buf_size' are NULL or *buf_size is 0, the buffer is assumed
4657      * empty, and memory is malloc'd.
4658      */
4659
4660     if (! string) {
4661         return NULL;
4662     }
4663
4664     /* No-op to copy over oneself */
4665     if (string == *buf) {
4666         return string;
4667     }
4668
4669     Size_t string_size = strlen(string) + 1;
4670     set_save_buffer_min_size(string_size, buf, buf_size);
4671
4672 #    ifdef DEBUGGING
4673
4674     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
4675                          "Copying '%s' to %p\n",
4676                          ((is_utf8_string((U8 *) string, 0))
4677                           ? string
4678                           :_byte_dump_string((U8 *) string, strlen(string), 0)),
4679                           *buf));
4680
4681     /* Catch glitches.  Usually this is because LC_CTYPE needs to be the same
4682      * locale as whatever is being worked on */
4683     if (UNLIKELY(instr(string, REPLACEMENT_CHARACTER_UTF8))) {
4684         locale_panic_(Perl_form(aTHX_
4685                                 "Unexpected REPLACEMENT_CHARACTER in '%s'\n%s",
4686                                 string, get_LC_ALL_display()));
4687     }
4688
4689 #  endif
4690
4691     Copy(string, *buf, string_size, char);
4692     return *buf;
4693 }
4694
4695 #  ifdef WIN32
4696
4697 bool
4698 Perl_get_win32_message_utf8ness(pTHX_ const char * string)
4699 {
4700     /* This is because Windows doesn't have LC_MESSAGES. */
4701
4702 #    ifdef USE_LOCALE_CTYPE
4703
4704     return get_locale_string_utf8ness_i(string, LOCALE_IS_UTF8,
4705                                         NULL, LC_CTYPE_INDEX_);
4706 #    else
4707
4708     return false;
4709
4710 #    endif
4711
4712 }
4713
4714 #  endif
4715 #endif  /* USE_LOCALE */
4716
4717 int
4718 Perl_mbtowc_(pTHX_ const wchar_t * pwc, const char * s, const Size_t len)
4719 {
4720
4721 #if ! defined(HAS_MBRTOWC) && ! defined(HAS_MBTOWC)
4722
4723     PERL_UNUSED_ARG(pwc);
4724     PERL_UNUSED_ARG(s);
4725     PERL_UNUSED_ARG(len);
4726     return -1;
4727
4728 #else   /* Below we have some form of mbtowc() */
4729 #  if defined(HAS_MBRTOWC)                                      \
4730    && (defined(USE_LOCALE_THREADS) || ! defined(HAS_MBTOWC))
4731 #    define USE_MBRTOWC
4732 #  else
4733 #    undef USE_MBRTOWC
4734 #  endif
4735
4736     int retval = -1;
4737
4738     if (s == NULL) { /* Initialize the shift state to all zeros in
4739                         PL_mbrtowc_ps. */
4740
4741 #  if defined(USE_MBRTOWC)
4742
4743         memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
4744         return 0;
4745
4746 #  else
4747
4748         SETERRNO(0, 0);
4749         MBTOWC_LOCK_;
4750         retval = mbtowc(NULL, NULL, 0);
4751         MBTOWC_UNLOCK_;
4752         return retval;
4753
4754 #  endif
4755
4756     }
4757
4758 #  if defined(USE_MBRTOWC)
4759
4760     SETERRNO(0, 0);
4761     MBRTOWC_LOCK_;
4762     retval = (SSize_t) mbrtowc((wchar_t *) pwc, s, len, &PL_mbrtowc_ps);
4763     MBRTOWC_UNLOCK_;
4764
4765 #  else
4766
4767     /* Locking prevents races, but locales can be switched out without locking,
4768      * so this isn't a cure all */
4769     SETERRNO(0, 0);
4770     MBTOWC_LOCK_;
4771     retval = mbtowc((wchar_t *) pwc, s, len);
4772     MBTOWC_UNLOCK_;
4773
4774 #  endif
4775
4776     return retval;
4777
4778 #endif
4779
4780 }
4781
4782 /*
4783 =for apidoc Perl_localeconv
4784
4785 This is a thread-safe version of the libc L<localeconv(3)>.  It is the same as
4786 L<POSIX::localeconv|POSIX/localeconv> (returning a hash of the C<localeconv()>
4787 fields), but directly callable from XS code.
4788
4789 =cut
4790 */
4791
4792 HV *
4793 Perl_localeconv(pTHX)
4794 {
4795
4796 #if  ! defined(HAS_LOCALECONV)
4797
4798     return newHV();
4799
4800 #else
4801
4802     return my_localeconv(0);
4803
4804 #endif
4805
4806 }
4807
4808 #if  defined(HAS_LOCALECONV)
4809
4810 HV *
4811 S_my_localeconv(pTHX_ const int item)
4812 {
4813     PERL_ARGS_ASSERT_MY_LOCALECONV;
4814
4815     /* This returns a mortalized hash containing all or certain elements
4816      * returned by localeconv().  It is used by Perl_localeconv() and
4817      * POSIX::localeconv() and is thread-safe.
4818      *
4819      * There are two use cases:
4820      * 1) Called from POSIX::locale_conv().  This returns the lconv structure
4821      *    copied to a hash, based on the current underlying locales for
4822      *    LC_NUMERIC and LC_MONETARY. An input item==0 signifies this case, or
4823      *    on many platforms it is the only use case compiled.
4824      * 2) Certain items that nl_langinfo() provides are also derivable from
4825      *    the return of localeconv().  Windows notably doesn't have
4826      *    nl_langinfo(), so on that, and actually any platform lacking it,
4827      *    my_localeconv() is used also to emulate it for those particular
4828      *    items.  The code to do this is compiled only on such platforms.
4829      *    Rather than going to the expense of creating a full hash when only
4830      *    one item is needed, the returned hash has just the desired item in
4831      *    it.
4832      *
4833      * To access all the localeconv() struct lconv fields, there is a data
4834      * structure that contains every commonly documented field in it.  (Maybe
4835      * some minority platforms have extra fields.  Those could be added here
4836      * without harm; they would just be ignored on platforms lacking them.)
4837      *
4838      * Our structure is compiled to make looping through the fields easier by
4839      * pointing each name to its value's offset within lconv, e.g.,
4840         { "thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep) }
4841      */
4842 #  define LCONV_ENTRY(name)                                                 \
4843                        {STRINGIFY(name), STRUCT_OFFSET(struct lconv, name)}
4844
4845     /* These synonyms are just for clarity, and to make it easier in case
4846      * something needs to change in the future */
4847 #  define LCONV_NUMERIC_ENTRY(name)  LCONV_ENTRY(name)
4848 #  define LCONV_MONETARY_ENTRY(name) LCONV_ENTRY(name)
4849
4850     /* There are just a few fields for NUMERIC strings */
4851     const lconv_offset_t lconv_numeric_strings[] = {
4852 #  ifndef NO_LOCALECONV_GROUPING
4853         LCONV_NUMERIC_ENTRY(grouping),
4854 #   endif
4855         LCONV_NUMERIC_ENTRY(thousands_sep),
4856         LCONV_NUMERIC_ENTRY(decimal_point),
4857         {NULL, 0}
4858     };
4859
4860     /* When used to implement nl_langinfo(), we save time by only populating
4861      * the hash with the field(s) needed.  Thus we would need a data structure
4862      * of just:
4863      *  LCONV_NUMERIC_ENTRY(decimal_point),
4864      *  {NULL, 0}
4865      *
4866      * By placing the decimal_point field last in the full structure, we can
4867      * use just the tail for this bit of it, saving space.  This macro yields
4868      * the address of the sub structure. */
4869 #  define DECIMAL_POINT_ADDRESS                                             \
4870         &lconv_numeric_strings[(C_ARRAY_LENGTH(lconv_numeric_strings) - 2)]
4871
4872     /* And the MONETARY string fields */
4873     const lconv_offset_t lconv_monetary_strings[] = {
4874         LCONV_MONETARY_ENTRY(int_curr_symbol),
4875         LCONV_MONETARY_ENTRY(mon_decimal_point),
4876 #  ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
4877         LCONV_MONETARY_ENTRY(mon_thousands_sep),
4878 #  endif
4879 #  ifndef NO_LOCALECONV_MON_GROUPING
4880         LCONV_MONETARY_ENTRY(mon_grouping),
4881 #  endif
4882         LCONV_MONETARY_ENTRY(positive_sign),
4883         LCONV_MONETARY_ENTRY(negative_sign),
4884         LCONV_MONETARY_ENTRY(currency_symbol),
4885         {NULL, 0}
4886     };
4887
4888     /* Like above, this field being last can be used as a sub structure */
4889 #  define CURRENCY_SYMBOL_ADDRESS                                            \
4890       &lconv_monetary_strings[(C_ARRAY_LENGTH(lconv_monetary_strings) - 2)]
4891
4892     /* Finally there are integer fields, all are for monetary purposes */
4893     const lconv_offset_t lconv_integers[] = {
4894         LCONV_ENTRY(int_frac_digits),
4895         LCONV_ENTRY(frac_digits),
4896         LCONV_ENTRY(p_sep_by_space),
4897         LCONV_ENTRY(n_cs_precedes),
4898         LCONV_ENTRY(n_sep_by_space),
4899         LCONV_ENTRY(p_sign_posn),
4900         LCONV_ENTRY(n_sign_posn),
4901 #  ifdef HAS_LC_MONETARY_2008
4902         LCONV_ENTRY(int_p_cs_precedes),
4903         LCONV_ENTRY(int_p_sep_by_space),
4904         LCONV_ENTRY(int_n_cs_precedes),
4905         LCONV_ENTRY(int_n_sep_by_space),
4906         LCONV_ENTRY(int_p_sign_posn),
4907         LCONV_ENTRY(int_n_sign_posn),
4908 #  endif
4909         LCONV_ENTRY(p_cs_precedes),
4910         {NULL, 0}
4911     };
4912
4913     /* Like above, this field being last can be used as a sub structure */
4914 #  define P_CS_PRECEDES_ADDRESS                                       \
4915       &lconv_integers[(C_ARRAY_LENGTH(lconv_integers) - 2)]
4916
4917     /* If we aren't paying attention to a given category, use LC_CTYPE instead;
4918      * If not paying attention to that either, the code below should end up not
4919      * using this.  Make sure that things blow up if that avoidance gets lost,
4920      * by setting the category to an out-of-bounds value */
4921     locale_category_index numeric_index;
4922     locale_category_index monetary_index;
4923
4924 #  ifdef USE_LOCALE_NUMERIC
4925     numeric_index = LC_NUMERIC_INDEX_;
4926 #  elif defined(USE_LOCALE_CTYPE)
4927     numeric_index = LC_CTYPE_INDEX_;
4928 #  else
4929     numeric_index = LC_ALL_INDEX_;      /* Out-of-bounds */
4930 #  endif
4931 #  ifdef USE_LOCALE_MONETARY
4932     monetary_index = LC_MONETARY_INDEX_;
4933 #  elif defined(USE_LOCALE_CTYPE)
4934     monetary_index = LC_CTYPE_INDEX_;
4935 #  else
4936     monetary_index = LC_ALL_INDEX_;     /* Out-of-bounds */
4937 #  endif
4938
4939     /* Some platforms, for correct non-mojibake results, require LC_CTYPE's
4940      * locale to match LC_NUMERIC's for the numeric fields, and LC_MONETARY's
4941      * for the monetary ones.  What happens if LC_NUMERIC and LC_MONETARY
4942      * aren't compatible?  Wrong results.  To avoid that, we call localeconv()
4943      * twice, once for each locale, setting LC_CTYPE to match the category.
4944      * But if the locales of both categories are the same, there is no need for
4945      * a second call.  Assume this is the case unless overridden below */
4946     bool requires_2nd_localeconv = false;
4947
4948     /* The actual hash populating is done by S_populate_hash_from_localeconv().
4949      * It gets passed an array of length two containing the data structure it
4950      * is supposed to use to get the key names to fill the hash with.  One
4951      * element is always for the NUMERIC strings (or NULL if none to use), and
4952      * the other element similarly for the MONETARY ones. */
4953 #  define NUMERIC_STRING_OFFSET   0
4954 #  define MONETARY_STRING_OFFSET  1
4955     const lconv_offset_t * strings[2] = { NULL, NULL };
4956
4957     /* This is a mask, with one bit to tell S_populate_hash_from_localeconv to
4958      * populate the NUMERIC items; another bit for the MONETARY ones.  This way
4959      * it can choose which (or both) to populate from */
4960     U32 index_bits = 0;
4961
4962     /* This converts from a locale index to its bit position in the above mask.
4963      * */
4964 #  define INDEX_TO_BIT(i)  (1 << (i))
4965
4966     /* The two categories can have disparate locales.  Initialize them to C and
4967      * override later whichever one(s) we pay attention to */
4968     const char * numeric_locale = "C";
4969     const char * monetary_locale = "C";
4970
4971     /* This will be either 'numeric_locale' or 'monetary_locale' depending on
4972      * what we are working on at the moment */
4973     const char * locale;
4974
4975     /* The LC_MONETARY category also has some integer-valued fields, whose
4976      * information is kept in a separate list */
4977     const lconv_offset_t * integers;
4978
4979 #  ifdef HAS_SOME_LANGINFO
4980
4981     /* If the only use-case for this is the full localeconv(), the 'item'
4982      * parameter is ignored. */
4983     PERL_UNUSED_ARG(item);
4984
4985 #  else
4986
4987     /* This only gets compiled for the use-case of using localeconv() to
4988      * emulate an nl_langinfo() missing from the platform. */
4989
4990 #    ifdef USE_LOCALE_NUMERIC
4991
4992     /* We need this substructure to only return this field for the THOUSEP
4993      * item.  The other items also need substructures, but they were handled
4994      * above by placing the substructure's item at the end of the full one, so
4995      * the data structure could do double duty.  However, both this and
4996      * RADIXCHAR would need to be in the final position of the same full
4997      * structure; an impossibility.  So make this into a separate structure */
4998     const lconv_offset_t  thousands_sep_string[] = {
4999         LCONV_NUMERIC_ENTRY(thousands_sep),
5000         {NULL, 0}
5001     };
5002
5003 #    endif
5004
5005     /* End of all the initialization of data structures.  Now for actual code.
5006      *
5007      * Without nl_langinfo(), the call to my_localeconv() could be for just one
5008      * of the following 3 items to emulate nl_langinfo().  This is compiled
5009      * only when using perl_langinfo.h, which we control, and it has been
5010      * constructed so that no item is numbered 0.
5011      *
5012      * For each, set up the appropriate parameters for the call below to
5013      * S_populate_hash_from_localeconv() */
5014     if (item != 0) switch (item) {
5015       default:
5016         locale_panic_(Perl_form(aTHX_
5017                     "Unexpected item passed to my_localeconv: %d", item));
5018         break;
5019
5020 #    ifdef USE_LOCALE_NUMERIC
5021
5022       case RADIXCHAR:
5023         locale = numeric_locale = PL_numeric_name;
5024         index_bits = INDEX_TO_BIT(LC_NUMERIC_INDEX_);
5025         strings[NUMERIC_STRING_OFFSET] = DECIMAL_POINT_ADDRESS;
5026         integers = NULL;
5027         break;
5028
5029       case THOUSEP:
5030         index_bits = INDEX_TO_BIT(LC_NUMERIC_INDEX_);
5031         locale = numeric_locale = PL_numeric_name;
5032         strings[NUMERIC_STRING_OFFSET] = thousands_sep_string;
5033         integers = NULL;
5034         break;
5035
5036 #    endif
5037 #    ifdef USE_LOCALE_MONETARY
5038
5039       case CRNCYSTR:
5040         index_bits = INDEX_TO_BIT(LC_MONETARY_INDEX_);
5041         locale = monetary_locale = querylocale_i(LC_MONETARY_INDEX_);
5042
5043         /* This item needs the values for both the currency symbol, and another
5044          * one used to construct the nl_langino()-compatible return */
5045         strings[MONETARY_STRING_OFFSET] = CURRENCY_SYMBOL_ADDRESS;
5046         integers = P_CS_PRECEDES_ADDRESS;
5047         break;
5048
5049 #    endif
5050
5051     } /* End of switch() */
5052
5053     else    /* End of for just one item to emulate nl_langinfo() */
5054
5055 #  endif
5056
5057     {   /* Here, the call is for all of localeconv().  It has a bunch of
5058          * items.  As in the individual item case, set up the parameters for
5059          * S_populate_hash_from_localeconv(); */
5060
5061 #  ifdef USE_LOCALE_NUMERIC
5062         numeric_locale = PL_numeric_name;
5063 #  elif defined(USE_LOCALE_CTYPE)
5064         numeric_locale = querylocale_i(numeric_index);
5065 #  endif
5066 #  if defined(USE_LOCALE_MONETARY) || defined(USE_LOCALE_CTYPE)
5067         monetary_locale = querylocale_i(monetary_index);
5068 #  endif
5069
5070         /* The first call to S_populate_hash_from_localeconv() will be for the
5071          * MONETARY values */
5072         index_bits = INDEX_TO_BIT(monetary_index);
5073         locale = monetary_locale;
5074
5075         /* And if the locales for the two categories are the same, we can also
5076          * do the NUMERIC values in the same call */
5077         if (strEQ(numeric_locale, monetary_locale)) {
5078             index_bits |= INDEX_TO_BIT(numeric_index);
5079         }
5080         else {
5081             requires_2nd_localeconv = true;
5082         }
5083
5084         /* We always pass both sets of strings. 'index_bits' tells
5085          * S_populate_hash_from_localeconv which to actually look at */
5086         strings[NUMERIC_STRING_OFFSET] = lconv_numeric_strings;
5087         strings[MONETARY_STRING_OFFSET] = lconv_monetary_strings;
5088
5089         /* And pass the integer values to populate; again 'index_bits' will
5090          * say to use them or not */
5091         integers = lconv_integers;
5092
5093     }   /* End of call is for localeconv() */
5094
5095     /* The code above has determined the parameters to
5096        S_populate_hash_from_localeconv() for both cases of an individual item
5097        and for the entire structure.  Below is code common to both */
5098
5099     HV * hv = newHV();      /* The returned hash, initially empty */
5100     sv_2mortal((SV*)hv);
5101
5102     /* Call localeconv() and copy its results into the hash.  All the
5103      * parameters have been initialized above */
5104     populate_hash_from_localeconv(hv,
5105                                   locale,
5106                                   index_bits,
5107                                   strings,
5108                                   integers
5109                                  );
5110
5111     /* The above call may have done all the hash fields, but not always, as
5112      * already explained.  If we need a second call it is always for the
5113      * NUMERIC fields */
5114     if (requires_2nd_localeconv) {
5115         populate_hash_from_localeconv(hv,
5116                                       numeric_locale,
5117                                       INDEX_TO_BIT(numeric_index),
5118                                       strings,
5119                                       NULL      /* There are no NUMERIC integer
5120                                                    fields */
5121                                      );
5122     }
5123
5124     /* Here, the hash has been completely populated.
5125      *
5126      * Now go through all the items and:
5127      *  a) For string items, see if they should be marked as UTF-8 or not.
5128      *     This would have been more convenient and faster to do while
5129      *     populating the hash in the first place, but that operation has to be
5130      *     done within a critical section, keeping other threads from
5131      *     executing, so only the minimal amount of work necessary is done at
5132      *     that time.
5133      *  b) For integer items, convert the C CHAR_MAX value into -1.  Again,
5134      *     this could have been done in the critical section, but was deferred
5135      *     to here to keep to the bare minimum amount the time spent owning the
5136      *     processor. CHAR_MAX is a C concept for an 8-bit character type.
5137      *     Perl has no such type; the closest fit is a -1.
5138      *
5139      * XXX On unthreaded perls, this code could be #ifdef'd out, and the
5140      * corrections determined at hash population time, at an extra maintenance
5141      * cost which khw doesn't think is worth it
5142      */
5143     for (unsigned int i = 0; i < 2; i++) {  /* Try both types of strings */
5144         if (! strings[i]) {     /* Skip if no strings of this type */
5145             continue;
5146         }
5147
5148         locale = (i == NUMERIC_STRING_OFFSET)
5149                  ? numeric_locale
5150                  : monetary_locale;
5151
5152         locale_utf8ness_t locale_is_utf8 = LOCALE_UTF8NESS_UNKNOWN;
5153
5154 #  ifdef HAS_RELIABLE_UTF8NESS_DETERMINATION
5155
5156         /* It saves time in the loop below to have predetermined the UTF8ness
5157          * of the locale.  But only do so if the platform reliably has this
5158          * information; otherwise it's better to do it only it should become
5159          * necessary, which happens on a per-element basis in the loop. */
5160
5161         locale_is_utf8 = (is_locale_utf8(locale))
5162                          ? LOCALE_IS_UTF8
5163                          : LOCALE_NOT_UTF8;
5164
5165         if (locale_is_utf8 == LOCALE_NOT_UTF8) {
5166             continue;   /* No string can be UTF-8 if the locale isn't */
5167         }
5168
5169 #  endif
5170
5171         /* Examine each string */
5172         for (const lconv_offset_t *strp = strings[i]; strp->name; strp++) {
5173             const char * name = strp->name;
5174
5175             /* 'value' will contain the string that may need to be marked as
5176              * UTF-8 */
5177             SV ** value = hv_fetch(hv, name, strlen(name), true);
5178             if (! value || ! SvPOK(*value)) {
5179                 continue;
5180             }
5181
5182             /* Determine if the string should be marked as UTF-8. */
5183             if (UTF8NESS_YES == (get_locale_string_utf8ness_i(SvPVX(*value),
5184                                                   locale_is_utf8,
5185                                                   NULL,
5186                                                   (locale_category_index) 0)))
5187             {
5188                 SvUTF8_on(*value);
5189             }
5190         }
5191     }   /* End of fixing up UTF8ness */
5192
5193
5194     /* Examine each integer */
5195     for (; integers; integers++) {
5196         const char * name = integers->name;
5197
5198         if (! name) {   /* Reached the end */
5199             break;
5200         }
5201
5202         SV ** value = hv_fetch(hv, name, strlen(name), true);
5203         if (! value) {
5204             continue;
5205         }
5206
5207         /* Change CHAR_MAX to -1 */
5208         if (SvIV(*value) == CHAR_MAX) {
5209             sv_setiv(*value, -1);
5210         }
5211     }
5212
5213     return hv;
5214 }
5215
5216 STATIC void
5217 S_populate_hash_from_localeconv(pTHX_ HV * hv,
5218
5219                                       /* Switch to this locale to run
5220                                        * localeconv() from */
5221                                       const char * locale,
5222
5223                                       /* bit mask of which categories to
5224                                        * populate */
5225                                       const U32 which_mask,
5226
5227                                       /* strings[0] points to the numeric
5228                                        * string fields; [1] to the monetary */
5229                                       const lconv_offset_t * strings[2],
5230
5231                                       /* And to the monetary integer fields */
5232                                       const lconv_offset_t * integers)
5233 {
5234     PERL_ARGS_ASSERT_POPULATE_HASH_FROM_LOCALECONV;
5235     PERL_UNUSED_ARG(which_mask);    /* Some configurations don't use this;
5236                                        complicated to figure out which */
5237 #  ifndef USE_LOCALE
5238     PERL_UNUSED_ARG(locale);
5239 #  endif
5240
5241     /* Run localeconv() and copy some or all of its results to the input 'hv'
5242      * hash.  Most localeconv() implementations return the values in a global
5243      * static buffer, so the operation must be performed in a critical section,
5244      * ending only after the copy is completed.  There are so many locks
5245      * because localeconv() deals with two categories, and returns in a single
5246      * global static buffer.  Some locks might be no-ops on this platform, but
5247      * not others.  We need to lock if any one isn't a no-op. */
5248
5249 #  ifdef USE_LOCALE_CTYPE
5250
5251     /* Some platforms require LC_CTYPE to be congruent with the category we are
5252      * looking for */
5253     const char * orig_CTYPE_locale = toggle_locale_c(LC_CTYPE, locale);
5254
5255 #  endif
5256 #  ifdef USE_LOCALE_NUMERIC
5257
5258     /* We need to toggle to the underlying NUMERIC locale if we are getting
5259      * NUMERIC strings */
5260     const char * orig_NUMERIC_locale = NULL;
5261     if (which_mask & INDEX_TO_BIT(LC_NUMERIC_INDEX_)) {
5262         LC_NUMERIC_LOCK(0);
5263
5264 #    if defined(WIN32)
5265
5266         /* There is a bug in Windows in which setting LC_CTYPE after the others
5267          * doesn't actually take effect for localeconv().  See commit
5268          * 418efacd1950763f74ed3cc22f8cf9206661b892 for details.  Thus we have
5269          * to make sure that the locale we want is set after LC_CTYPE.  We
5270          * unconditionally toggle away from and back to the current locale
5271          * prior to calling localeconv().
5272          *
5273          * This code will have no effect if we already are in C, but khw
5274          * hasn't seen any cases where this causes problems when we are in the
5275          * C locale. */
5276         orig_NUMERIC_locale = toggle_locale_i(LC_NUMERIC_INDEX_, "C");
5277         toggle_locale_i(LC_NUMERIC_INDEX_, locale);
5278
5279 #    else
5280
5281         /* No need for the extra toggle when not on Windows */
5282         orig_NUMERIC_locale = toggle_locale_i(LC_NUMERIC_INDEX_, locale);
5283
5284 #    endif
5285
5286     }
5287
5288 #  endif
5289 #  if defined(USE_LOCALE_MONETARY) && defined(WIN32)
5290
5291     /* Same Windows bug as described just above for NUMERIC.  Otherwise, no
5292      * need to toggle LC_MONETARY, as it is kept in the underlying locale */
5293     const char * orig_MONETARY_locale = NULL;
5294     if (which_mask & INDEX_TO_BIT(LC_MONETARY_INDEX_)) {
5295         orig_MONETARY_locale = toggle_locale_i(LC_MONETARY_INDEX_, "C");
5296         toggle_locale_i(LC_MONETARY_INDEX_, locale);
5297     }
5298
5299 #  endif
5300
5301     /* Finally ready to do the actual localeconv().  Lock to prevent other
5302      * accesses until we have made a copy of its returned static buffer */
5303     gwLOCALE_LOCK;
5304
5305 #  if defined(TS_W32_BROKEN_LOCALECONV) && defined(USE_THREAD_SAFE_LOCALE)
5306
5307     /* This is a workaround for another bug in Windows.  localeconv() was
5308      * broken with thread-safe locales prior to VS 15.  It looks at the global
5309      * locale instead of the thread one.  As a work-around, we toggle to the
5310      * global locale; populate the return; then toggle back.  We have to use
5311      * LC_ALL instead of the individual categories because of yet another bug
5312      * in Windows.  And this all has to be done in a critical section.
5313      *
5314      * This introduces a potential race with any other thread that has also
5315      * converted to use the global locale, and doesn't protect its locale calls
5316      * with mutexes.  khw can't think of any reason for a thread to do so on
5317      * Windows, as the locale API is the same regardless of thread-safety,
5318      * except if the code is ported from working on another platform where
5319      * there might be some reason to do this.  But this is typically due to
5320      * some alien-to-Perl library that thinks it owns locale setting.  Such a
5321      * library isn't likely to exist on Windows, so such an application is
5322      * unlikely to be run on Windows
5323      */
5324     bool restore_per_thread = FALSE;
5325
5326     /* Save the per-thread locale state */
5327     const char * save_thread = querylocale_c(LC_ALL);
5328
5329     /* Change to the global locale, and note if we already were there */
5330     int config_return = _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
5331     if (config_return != _DISABLE_PER_THREAD_LOCALE) {
5332         if (config_return == -1) {
5333             locale_panic_("_configthreadlocale returned an error");
5334         }
5335
5336         restore_per_thread = TRUE;
5337     }
5338
5339     /* Save the state of the global locale; then convert to our desired
5340      * state.  */
5341     const char * save_global = querylocale_c(LC_ALL);
5342     void_setlocale_c(LC_ALL, save_thread);
5343
5344 #  endif  /* TS_W32_BROKEN_LOCALECONV */
5345
5346     /* Finally, do the actual localeconv */
5347     const char *lcbuf_as_string = (const char *) localeconv();
5348
5349     /* Fill in the string fields of the HV* */
5350     for (unsigned int i = 0; i < 2; i++) {
5351
5352         /* One iteration is only for the numeric string fields.  Skip these
5353          * unless we are compiled to care about those fields and the input
5354          * parameters indicate we want their values */
5355         if (   i == NUMERIC_STRING_OFFSET
5356
5357 #  ifdef USE_LOCALE_NUMERIC
5358
5359             && (which_mask & INDEX_TO_BIT(LC_NUMERIC_INDEX_)) == 0
5360
5361 #  endif
5362
5363         ) {
5364             continue;
5365         }
5366
5367         /* The other iteration is only for the monetary string fields.  Again
5368          * skip it unless we want those values */
5369         if (   i == MONETARY_STRING_OFFSET
5370
5371 #  ifdef USE_LOCALE_MONETARY
5372
5373             && (which_mask & INDEX_TO_BIT(LC_MONETARY_INDEX_)) == 0
5374
5375 #  endif
5376         ) {
5377
5378             continue;
5379         }
5380
5381         /* For each field for the given category ... */
5382         const lconv_offset_t * category_strings = strings[i];
5383         while (1) {
5384             const char * name = category_strings->name;
5385             if (! name) {   /* Quit at the end */
5386                 break;
5387             }
5388
5389             /* we have set things up so that we know where in the returned
5390              * structure, when viewed as a string, the corresponding value is.
5391              * */
5392             const char *value = *((const char **)(  lcbuf_as_string
5393                                                   + category_strings->offset));
5394
5395             /* Set to get next string on next iteration */
5396             category_strings++;
5397
5398             /* Skip if this platform doesn't have this field. */
5399             if (! value) {
5400                 continue;
5401             }
5402
5403             /* Copy to the hash */
5404             (void) hv_store(hv,
5405                             name, strlen(name),
5406                             newSVpv(value, strlen(value)),
5407                             0);
5408         }
5409
5410         /* Add any int fields to the HV* */
5411         if (i == MONETARY_STRING_OFFSET && integers) {
5412             while (integers->name) {
5413                 const char value = *((const char *)(  lcbuf_as_string
5414                                                     + integers->offset));
5415                 (void) hv_store(hv, integers->name,
5416                                 strlen(integers->name), newSViv(value), 0);
5417                 integers++;
5418             }
5419         }
5420     }   /* End of loop through the fields */
5421
5422     /* Done with copying to the hash.  Can unwind the critical section locks */
5423
5424 #  if defined(TS_W32_BROKEN_LOCALECONV) && defined(USE_THREAD_SAFE_LOCALE)
5425
5426     /* Restore the global locale's prior state */
5427     void_setlocale_c(LC_ALL, save_global);
5428
5429     /* And back to per-thread locales */
5430     if (restore_per_thread) {
5431         if (_configthreadlocale(_ENABLE_PER_THREAD_LOCALE) == -1) {
5432             locale_panic_("_configthreadlocale returned an error");
5433         }
5434     }
5435
5436     /* Restore the per-thread locale state */
5437     void_setlocale_c(LC_ALL, save_thread);
5438
5439 #  endif  /* TS_W32_BROKEN_LOCALECONV */
5440
5441     gwLOCALE_UNLOCK;    /* Finished with the critical section of a
5442                            globally-accessible buffer */
5443
5444 #  if defined(USE_LOCALE_MONETARY) && defined(WIN32)
5445
5446     restore_toggled_locale_i(LC_MONETARY_INDEX_, orig_MONETARY_locale);
5447
5448 #  endif
5449 #  ifdef USE_LOCALE_NUMERIC
5450
5451     restore_toggled_locale_i(LC_NUMERIC_INDEX_, orig_NUMERIC_locale);
5452     if (which_mask & INDEX_TO_BIT(LC_NUMERIC_INDEX_)) {
5453         LC_NUMERIC_UNLOCK;
5454     }
5455
5456 #  endif
5457 #  ifdef USE_LOCALE_CTYPE
5458
5459     restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
5460
5461 #  endif
5462
5463 }
5464
5465 #endif /* defined(HAS_LOCALECONV) */
5466 #ifndef HAS_SOME_LANGINFO
5467
5468 typedef int nl_item;    /* Substitute 'int' for emulated nl_langinfo() */
5469
5470 #endif
5471
5472 /*
5473
5474 =for apidoc      Perl_langinfo
5475 =for apidoc_item Perl_langinfo8
5476
5477 C<Perl_langinfo> is an (almost) drop-in replacement for the system
5478 C<L<nl_langinfo(3)>>, taking the same C<item> parameter values, and returning
5479 the same information.  But it is more thread-safe than regular
5480 C<nl_langinfo()>, and hides the quirks of Perl's locale handling from your
5481 code, and can be used on systems that lack a native C<nl_langinfo>.
5482
5483 However, you should instead use the improved version of this:
5484 L</Perl_langinfo8>, which behaves identically except for an additional
5485 parameter, a pointer to a variable declared as L</C<utf8ness_t>>, into which it
5486 returns to you how you should treat the returned string with regards to it
5487 being encoded in UTF-8 or not.
5488
5489 Concerning the differences between these and plain C<nl_langinfo()>:
5490
5491 =over
5492
5493 =item a.
5494
5495 C<Perl_langinfo8> has an extra parameter, described above.  Besides this, the
5496 other reason they aren't quite a drop-in replacement is actually an advantage.
5497 The C<const>ness of the return allows the compiler to catch attempts to write
5498 into the returned buffer, which is illegal and could cause run-time crashes.
5499
5500 =item b.
5501
5502 They deliver the correct results for the C<RADIXCHAR> and C<THOUSEP> items,
5503 without you having to write extra code.  The reason for the extra code would be
5504 because these are from the C<LC_NUMERIC> locale category, which is normally
5505 kept set by Perl so that the radix is a dot, and the separator is the empty
5506 string, no matter what the underlying locale is supposed to be, and so to get
5507 the expected results, you have to temporarily toggle into the underlying
5508 locale, and later toggle back.  (You could use plain C<nl_langinfo> and
5509 C<L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>> for this but then you wouldn't get
5510 the other advantages of C<Perl_langinfo()>; not keeping C<LC_NUMERIC> in the C
5511 (or equivalent) locale would break a lot of CPAN, which is expecting the radix
5512 (decimal point) character to be a dot.)
5513
5514 =item c.
5515
5516 The system function they replace can have its static return buffer trashed,
5517 not only by a subsequent call to that function, but by a C<freelocale>,
5518 C<setlocale>, or other locale change.  The returned buffer of these functions
5519 is not changed until the next call to one or the other, so the buffer is never
5520 in a trashed state.
5521
5522 =item d.
5523
5524 The return buffer is per-thread, so it also is never overwritten by a call to
5525 these functions from another thread;  unlike the function it replaces.
5526
5527 =item e.
5528
5529 But most importantly, they work on systems that don't have C<nl_langinfo>, such
5530 as Windows, hence making your code more portable.  Of the fifty-some possible
5531 items specified by the POSIX 2008 standard,
5532 L<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/langinfo.h.html>,
5533 only one is completely unimplemented, though on non-Windows platforms, another
5534 significant one is not fully implemented).  They use various techniques to
5535 recover the other items, including calling C<L<localeconv(3)>>, and
5536 C<L<strftime(3)>>, both of which are specified in C89, so should be always be
5537 available.  Later C<strftime()> versions have additional capabilities.
5538 If an item is not available on your system, this returns either the value
5539 associated with the C locale, or simply C<"">, whichever is more appropriate.
5540
5541 It is important to note that, when called with an item that is recovered by
5542 using C<localeconv>, the buffer from any previous explicit call to
5543 C<L<localeconv(3)>> will be overwritten.  But you shouldn't be using
5544 C<localeconv> anyway because it is is very much not thread-safe, and suffers
5545 from the same problems outlined in item 'b.' above for the fields it returns
5546 that are controlled by the LC_NUMERIC locale category.  Instead, avoid all of
5547 those problems by calling L</Perl_localeconv>, which is thread-safe; or by
5548 using the methods given in L<perlcall>  to call
5549 L<C<POSIX::localeconv()>|POSIX/localeconv>, which is also thread-safe.
5550
5551 =back
5552
5553 The details for those items which may deviate from what this emulation returns
5554 and what a native C<nl_langinfo()> would return are specified in
5555 L<I18N::Langinfo>.
5556
5557 When using C<Perl_langinfo8> (or plain C<Perl_langinfo>) on systems that don't
5558 have a native C<nl_langinfo()>, you must
5559
5560  #include "perl_langinfo.h"
5561
5562 before the C<perl.h> C<#include>.  You can replace your F<langinfo.h>
5563 C<#include> with this one.  (Doing it this way keeps out the symbols that plain
5564 F<langinfo.h> would try to import into the namespace for code that doesn't need
5565 it.)
5566
5567 =cut
5568
5569 */
5570
5571 const char *
5572 Perl_langinfo(const nl_item item)
5573 {
5574     return Perl_langinfo8(item, NULL);
5575 }
5576
5577 const char *
5578 Perl_langinfo8(const nl_item item, utf8ness_t * utf8ness)
5579 {
5580     dTHX;
5581     locale_category_index cat_index;
5582
5583     PERL_ARGS_ASSERT_PERL_LANGINFO8;
5584
5585     if (utf8ness) {     /* Assume for now */
5586         *utf8ness = UTF8NESS_IMMATERIAL;
5587     }
5588
5589     /* Find the locale category that controls the input 'item'.  If we are not
5590      * paying attention to that category, instead return a default value.  Also
5591      * return the default value if there is no way for us to figure out the
5592      * correct value.  If we have some form of nl_langinfo(), we can always
5593      * figure it out, but lacking that, there may be alternative methods that
5594      * can be used to recover most of the possible items.  Some of those
5595      * methods need libc functions, which may or may not be available.  If
5596      * unavailable, we can't compute the correct value, so must here return the
5597      * default. */
5598     switch (item) {
5599
5600       case CODESET:
5601
5602 #ifdef USE_LOCALE_CTYPE
5603
5604         cat_index = LC_CTYPE_INDEX_;
5605         break;
5606
5607 #else
5608         return C_codeset;
5609 #endif
5610 #if defined(USE_LOCALE_MESSAGES) && defined(HAS_SOME_LANGINFO)
5611
5612       case YESEXPR: case YESSTR: case NOEXPR: case NOSTR:
5613         cat_index = LC_MESSAGES_INDEX_;
5614         break;
5615 #else
5616       case YESEXPR:   return "^[+1yY]";
5617       case YESSTR:    return "yes";
5618       case NOEXPR:    return "^[-0nN]";
5619       case NOSTR:     return "no";
5620 #endif
5621
5622       case CRNCYSTR:
5623
5624 #if  defined(USE_LOCALE_MONETARY)                                   \
5625  && (defined(HAS_SOME_LANGINFO) || defined(HAS_LOCALECONV))
5626
5627         cat_index = LC_MONETARY_INDEX_;
5628         break;
5629 #else
5630         return "-";
5631 #endif
5632
5633       case RADIXCHAR:
5634
5635 #ifdef CAN_CALCULATE_RADIX
5636
5637         cat_index = LC_NUMERIC_INDEX_;
5638         break;
5639 #else
5640         return C_decimal_point;
5641 #endif
5642
5643       case THOUSEP:
5644
5645 #if  defined(USE_LOCALE_NUMERIC)                                    \
5646  && (defined(HAS_SOME_LANGINFO) || defined(HAS_LOCALECONV))
5647
5648         cat_index = LC_NUMERIC_INDEX_;
5649         break;
5650 #else
5651         return C_thousands_sep;
5652 #endif
5653
5654 /* The other possible items are all in LC_TIME. */
5655 #ifdef USE_LOCALE_TIME
5656
5657       default:
5658         cat_index = LC_TIME_INDEX_;
5659         break;
5660
5661 #endif
5662 #if ! defined(USE_LOCALE_TIME) || ! defined(HAS_SOME_LANGINFO)
5663
5664     /* If not using LC_TIME, hard code the rest.  Or, if there is no
5665      * nl_langinfo(), we use strftime() as an alternative, and it is missing
5666      * functionality to get every single one, so hard-code those */
5667
5668       case ERA: return "";  /* Unimplemented; for use with strftime() %E
5669                                modifier */
5670
5671       /* These formats are defined by C89, so we assume that strftime supports
5672        * them, and so are returned unconditionally; they may not be what the
5673        * locale actually says, but should give good enough results for someone
5674        * using them as formats (as opposed to trying to parse them to figure
5675        * out what the locale says).  The other format items are actually tested
5676        * to verify they work on the platform */
5677       case D_FMT:         return "%x";
5678       case T_FMT:         return "%X";
5679       case D_T_FMT:       return "%c";
5680
5681 #  if defined(WIN32) || ! defined(USE_LOCALE_TIME)
5682
5683       /* strftime() on Windows doesn't have the POSIX (beyond C89) extensions
5684        * that would allow it to recover these */
5685       case ERA_D_FMT:     return "%x";
5686       case ERA_T_FMT:     return "%X";
5687       case ERA_D_T_FMT:   return "%c";
5688       case ALT_DIGITS:    return "0";
5689
5690 #  endif
5691 #  ifndef USE_LOCALE_TIME
5692
5693       case T_FMT_AMPM:    return "%r";
5694       case ABDAY_1:       return "Sun";
5695       case ABDAY_2:       return "Mon";
5696       case ABDAY_3:       return "Tue";
5697       case ABDAY_4:       return "Wed";
5698       case ABDAY_5:       return "Thu";
5699       case ABDAY_6:       return "Fri";
5700       case ABDAY_7:       return "Sat";
5701       case AM_STR:        return "AM";
5702       case PM_STR:        return "PM";
5703       case ABMON_1:       return "Jan";
5704       case ABMON_2:       return "Feb";
5705       case ABMON_3:       return "Mar";
5706       case ABMON_4:       return "Apr";
5707       case ABMON_5:       return "May";
5708       case ABMON_6:       return "Jun";
5709       case ABMON_7:       return "Jul";
5710       case ABMON_8:       return "Aug";
5711       case ABMON_9:       return "Sep";
5712       case ABMON_10:      return "Oct";
5713       case ABMON_11:      return "Nov";
5714       case ABMON_12:      return "Dec";
5715       case DAY_1:         return "Sunday";
5716       case DAY_2:         return "Monday";
5717       case DAY_3:         return "Tuesday";
5718       case DAY_4:         return "Wednesday";
5719       case DAY_5:         return "Thursday";
5720       case DAY_6:         return "Friday";
5721       case DAY_7:         return "Saturday";
5722       case MON_1:         return "January";
5723       case MON_2:         return "February";
5724       case MON_3:         return "March";
5725       case MON_4:         return "April";
5726       case MON_5:         return "May";
5727       case MON_6:         return "June";
5728       case MON_7:         return "July";
5729       case MON_8:         return "August";
5730       case MON_9:         return "September";
5731       case MON_10:        return "October";
5732       case MON_11:        return "November";
5733       case MON_12:        return "December";
5734
5735 #  endif
5736 #endif
5737
5738     } /* End of switch on item */
5739
5740 #ifndef USE_LOCALE
5741
5742     Perl_croak_nocontext("panic: Unexpected nl_langinfo() item %d", item);
5743     NOT_REACHED; /* NOTREACHED */
5744     PERL_UNUSED_VAR(cat_index);
5745
5746 #else
5747
5748     return my_langinfo_i(item, cat_index, query_nominal_locale_i(cat_index),
5749                          &PL_langinfo_buf, &PL_langinfo_bufsize, utf8ness);
5750 #endif
5751
5752 }
5753
5754 char *
5755 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour,
5756                        int mday, int mon, int year, int wday, int yday,
5757                        int isdst)
5758 {   /* Documented above */
5759     PERL_ARGS_ASSERT_MY_STRFTIME;
5760
5761     struct tm  mytm;
5762     ints_to_tm(&mytm, sec, min, hour, mday, mon, year, wday, yday, isdst);
5763     char * ret = strftime_tm(fmt, &mytm);
5764     return ret;
5765 }
5766
5767 SV *
5768 Perl_sv_strftime_tm(pTHX_ SV * fmt, const struct tm * mytm)
5769 {   /* Documented above */
5770     PERL_ARGS_ASSERT_SV_STRFTIME_TM;
5771
5772     utf8ness_t fmt_utf8ness = (SvUTF8(fmt) && LIKELY(! IN_BYTES))
5773                               ? UTF8NESS_YES
5774                               : UTF8NESS_UNKNOWN;
5775
5776     utf8ness_t result_utf8ness;
5777     char * retval = strftime8(SvPV_nolen(fmt),
5778                               mytm,
5779                               fmt_utf8ness,
5780                               &result_utf8ness,
5781                               true  /* calling from sv_strftime */
5782                              );
5783     SV * sv = NULL;
5784     if (retval) {
5785         STRLEN len = strlen(retval);
5786         sv = newSV(len);
5787         sv_usepvn_flags(sv, retval, len, SV_HAS_TRAILING_NUL);
5788
5789         if (result_utf8ness == UTF8NESS_YES) {
5790             SvUTF8_on(sv);
5791         }
5792     }
5793
5794     return sv;
5795 }
5796
5797 SV *
5798 Perl_sv_strftime_ints(pTHX_ SV * fmt, int sec, int min, int hour,
5799                             int mday, int mon, int year, int wday,
5800                             int yday, int isdst)
5801 {   /* Documented above */
5802     PERL_ARGS_ASSERT_SV_STRFTIME_INTS;
5803
5804     struct tm  mytm;
5805     ints_to_tm(&mytm, sec, min, hour, mday, mon, year, wday, yday, isdst);
5806     SV * ret = sv_strftime_tm(fmt, &mytm);
5807     return ret;
5808 }
5809
5810 #ifdef USE_LOCALE
5811
5812 /* There are several implementations of my_langinfo, depending on the
5813  * Configuration.  They all share the same beginning of the function */
5814 STATIC const char *
5815 S_my_langinfo_i(pTHX_
5816                 const nl_item item,           /* The item to look up */
5817                 const locale_category_index cat_index, /* The locale category
5818                                                           that controls it */
5819                 /* The locale to look up 'item' in. */
5820                 const char * locale,
5821
5822                 /* Where to store the result, and where the size of that buffer
5823                  * is stored, updated on exit. retbuf_sizep may be NULL for an
5824                  * empty-on-entry, single use buffer whose size we don't need
5825                  * to keep track of */
5826                 char ** retbufp,
5827                 Size_t * retbuf_sizep,
5828
5829                 /* If not NULL, the location to store the UTF8-ness of 'item's
5830                  * value, as documented */
5831                 utf8ness_t * utf8ness)
5832 {
5833     const char * retval = NULL;
5834
5835     PERL_ARGS_ASSERT_MY_LANGINFO_I;
5836     assert(cat_index < LC_ALL_INDEX_);
5837
5838     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
5839                            "Entering my_langinfo item=%ld, using locale %s\n",
5840                            (long) item, locale));
5841 /*--------------------------------------------------------------------------*/
5842 /* Above is the common beginning to all the implementations of my_langinfo().
5843  * Below are the various completions.
5844  *
5845  * Some platforms don't deal well with non-ASCII strings in locale X when
5846  * LC_CTYPE is not in X.  (Actually it is probably when X is UTF-8 and LC_CTYPE
5847  * isn't, or vice versa).  There is explicit code to bring the categories into
5848  * sync.  This doesn't seem to be a problem with nl_langinfo(), so that
5849  * implementation doesn't currently worry about it.  But it is a problem on
5850  * Windows boxes, which don't have nl_langinfo(). */
5851
5852 /*--------------------------------------------------------------------------*/
5853 #  if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available.  */
5854 #    ifdef USE_LOCALE_CTYPE
5855
5856     /* This function sorts out if things actually have to be switched or not,
5857      * for both save and restore. */
5858     const char * orig_CTYPE_locale = toggle_locale_c(LC_CTYPE, locale);
5859
5860 #    endif
5861
5862     const char * orig_switched_locale = toggle_locale_i(cat_index, locale);
5863
5864     gwLOCALE_LOCK;
5865     retval = save_to_buffer(nl_langinfo(item), retbufp, retbuf_sizep);
5866     gwLOCALE_UNLOCK;
5867
5868     if (utf8ness) {
5869         *utf8ness = get_locale_string_utf8ness_i(retval,
5870                                                  LOCALE_UTF8NESS_UNKNOWN,
5871                                                  locale, cat_index);
5872     }
5873
5874     restore_toggled_locale_i(cat_index, orig_switched_locale);
5875
5876 #    ifdef USE_LOCALE_CTYPE
5877
5878     restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
5879
5880 #    endif
5881
5882     return retval;
5883 /*--------------------------------------------------------------------------*/
5884 #  else   /* Below, emulate nl_langinfo as best we can */
5885
5886     /* The other completion is where we have to emulate nl_langinfo().  There
5887      * are various possibilities depending on the Configuration */
5888
5889 #    ifdef USE_LOCALE_CTYPE
5890
5891     const char * orig_CTYPE_locale = toggle_locale_c(LC_CTYPE, locale);
5892
5893 #    endif
5894
5895     const char * orig_switched_locale = toggle_locale_i(cat_index, locale);
5896
5897     /* Here, we are in the locale we want information about */
5898
5899     /* Almost all the items will have ASCII return values.  Set that here, and
5900      * override if necessary */
5901     utf8ness_t is_utf8 = UTF8NESS_IMMATERIAL;
5902
5903     switch (item) {
5904       default:
5905         assert(item < 0);   /* Make sure using perl_langinfo.h */
5906         retval = "";
5907         break;
5908
5909       case RADIXCHAR:
5910
5911 #    if      defined(HAS_SNPRINTF)                                          \
5912        && (! defined(HAS_LOCALECONV) || defined(TS_W32_BROKEN_LOCALECONV))
5913
5914         {
5915             /* snprintf() can be used to find the radix character by outputting
5916              * a known simple floating point number to a buffer, and parsing
5917              * it, inferring the radix as the bytes separating the integer and
5918              * fractional parts.  But localeconv() is more direct, not
5919              * requiring inference, so use it instead of the code just below,
5920              * if (likely) it is available and works ok */
5921
5922             char * floatbuf = NULL;
5923             const Size_t initial_size = 10;
5924
5925             Newx(floatbuf, initial_size, char);
5926
5927             /* 1.5 is exactly representable on binary computers */
5928             Size_t needed_size = snprintf(floatbuf, initial_size, "%.1f", 1.5);
5929
5930             /* If our guess wasn't big enough, increase and try again, based on
5931              * the real number that snprintf() is supposed to return */
5932             if (UNLIKELY(needed_size >= initial_size)) {
5933                 needed_size++;  /* insurance */
5934                 Renew(floatbuf, needed_size, char);
5935                 Size_t new_needed = snprintf(floatbuf, needed_size, "%.1f", 1.5);
5936                 assert(new_needed <= needed_size);
5937                 needed_size = new_needed;
5938             }
5939
5940             char * s = floatbuf;
5941             char * e = floatbuf + needed_size;
5942
5943             /* Find the '1' */
5944             while (s < e && *s != '1') {
5945                 s++;
5946             }
5947
5948             if (LIKELY(s < e)) {
5949                 s++;
5950             }
5951
5952             /* Find the '5' */
5953             char * item_start = s;
5954             while (s < e && *s != '5') {
5955                 s++;
5956             }
5957
5958             /* Everything in between is the radix string */
5959             if (LIKELY(s < e)) {
5960                 *s = '\0';
5961                 retval = save_to_buffer(item_start, retbufp, retbuf_sizep);
5962                 Safefree(floatbuf);
5963
5964                 if (utf8ness) {
5965                     is_utf8 = get_locale_string_utf8ness_i(retval,
5966                                                         LOCALE_UTF8NESS_UNKNOWN,
5967                                                         locale, cat_index);
5968                 }
5969
5970                 break;
5971             }
5972
5973             Safefree(floatbuf);
5974         }
5975
5976 #      ifdef HAS_LOCALECONV /* snprintf() failed; drop down to use
5977                                localeconv() */
5978
5979         /* FALLTHROUGH */
5980
5981 #      else                      /* snprintf() failed and no localeconv() */
5982
5983         retval = C_decimal_point;
5984         break;
5985
5986 #      endif
5987 #    endif
5988 #    ifdef HAS_LOCALECONV
5989
5990     /* These items are available from localeconv().  (To avoid using
5991      * TS_W32_BROKEN_LOCALECONV, one could use GetNumberFormat and
5992      * GetCurrencyFormat; patches welcome) */
5993
5994 #      define P_CS_PRECEDES    "p_cs_precedes"
5995 #      define CURRENCY_SYMBOL  "currency_symbol"
5996
5997    /* case RADIXCHAR:   // May drop down to here in some configurations */
5998       case THOUSEP:
5999       case CRNCYSTR:
6000        {
6001
6002         /* The hash gets populated with just the field(s) related to 'item'. */
6003         HV * result_hv = my_localeconv(item);
6004
6005         SV* string;
6006         if (item != CRNCYSTR) {
6007
6008             /* These items have been populated with just one key => value */
6009             (void) hv_iterinit(result_hv);
6010             HE * entry = hv_iternext(result_hv);
6011             string = hv_iterval(result_hv, entry);
6012         }
6013         else {
6014
6015             /* But CRNCYSTR localeconv() returns a slightly different value
6016              * than the nl_langinfo() API calls for, so have to modify this one
6017              * to conform.  We need another value from localeconv() to know
6018              * what to change it to.  my_localeconv() has populated the hash
6019              * with exactly both fields.  Delete this one, leaving just the
6020              * CRNCYSTR one in the hash */
6021             SV* precedes = hv_delete(result_hv,
6022                                      P_CS_PRECEDES, STRLENs(P_CS_PRECEDES),
6023                                      0);
6024             if (! precedes) {
6025                 locale_panic_("my_localeconv() unexpectedly didn't return"
6026                               " a value for " P_CS_PRECEDES);
6027             }
6028
6029             /* The modification is to prefix the localeconv() return with a
6030              * single byte, calculated as follows: */
6031             char prefix = (LIKELY(SvIV(precedes) != -1))
6032                           ? ((precedes != 0) ?  '-' : '+')
6033
6034                             /* khw couldn't find any documentation that
6035                              * CHAR_MAX (which we modify to -1) is the signal,
6036                              * but cygwin uses it thusly, and it makes sense
6037                              * given that CHAR_MAX indicates the value isn't
6038                              * used, so it neither precedes nor succeeds */
6039                           : '.';
6040
6041             /* Now get CRNCYSTR */
6042             (void) hv_iterinit(result_hv);
6043             HE * entry = hv_iternext(result_hv);
6044             string = hv_iterval(result_hv, entry);
6045
6046             /* And perform the modification */
6047             Perl_sv_setpvf(aTHX_ string, "%c%s", prefix, SvPV_nolen(string));
6048         }
6049
6050         /* Here, 'string' contains the value we want to return */
6051         retval = save_to_buffer(SvPV_nolen(string), retbufp, retbuf_sizep);
6052
6053         if (utf8ness) {
6054             is_utf8 = (SvUTF8(string))
6055                       ? UTF8NESS_YES
6056                       : (is_utf8_invariant_string( (U8 *) retval,
6057                                                   strlen(retval)))
6058                         ? UTF8NESS_IMMATERIAL
6059                         : UTF8NESS_NO;
6060         }
6061
6062         break;
6063
6064        }
6065
6066 #    endif  /* Some form of localeconv */
6067 #    ifdef HAS_STRFTIME
6068
6069       /* These formats are only available in later strftime's */
6070       case ERA_D_FMT: case ERA_T_FMT: case ERA_D_T_FMT: case T_FMT_AMPM:
6071
6072       /* The rest can be gotten from most versions of strftime(). */
6073       case ABDAY_1: case ABDAY_2: case ABDAY_3:
6074       case ABDAY_4: case ABDAY_5: case ABDAY_6: case ABDAY_7:
6075       case ALT_DIGITS:
6076       case AM_STR: case PM_STR:
6077       case ABMON_1: case ABMON_2: case ABMON_3: case ABMON_4:
6078       case ABMON_5: case ABMON_6: case ABMON_7: case ABMON_8:
6079       case ABMON_9: case ABMON_10: case ABMON_11: case ABMON_12:
6080       case DAY_1: case DAY_2: case DAY_3: case DAY_4:
6081       case DAY_5: case DAY_6: case DAY_7:
6082       case MON_1: case MON_2: case MON_3: case MON_4:
6083       case MON_5: case MON_6: case MON_7: case MON_8:
6084       case MON_9: case MON_10: case MON_11: case MON_12:
6085         {
6086             const char * format;
6087             bool return_format = FALSE;
6088             int mon = 0;
6089             int mday = 1;
6090             int hour = 6;
6091
6092             GCC_DIAG_IGNORE_STMT(-Wimplicit-fallthrough);
6093
6094             switch (item) {
6095               default:
6096                 locale_panic_(Perl_form(aTHX_ "switch case: %d problem", item));
6097                 NOT_REACHED; /* NOTREACHED */
6098
6099               case PM_STR: hour = 18;
6100               case AM_STR:
6101                 format = "%p";
6102                 break;
6103               case ABDAY_7: mday++;
6104               case ABDAY_6: mday++;
6105               case ABDAY_5: mday++;
6106               case ABDAY_4: mday++;
6107               case ABDAY_3: mday++;
6108               case ABDAY_2: mday++;
6109               case ABDAY_1:
6110                 format = "%a";
6111                 break;
6112               case DAY_7: mday++;
6113               case DAY_6: mday++;
6114               case DAY_5: mday++;
6115               case DAY_4: mday++;
6116               case DAY_3: mday++;
6117               case DAY_2: mday++;
6118               case DAY_1:
6119                 format = "%A";
6120                 break;
6121               case ABMON_12: mon++;
6122               case ABMON_11: mon++;
6123               case ABMON_10: mon++;
6124               case ABMON_9:  mon++;
6125               case ABMON_8:  mon++;
6126               case ABMON_7:  mon++;
6127               case ABMON_6:  mon++;
6128               case ABMON_5:  mon++;
6129               case ABMON_4:  mon++;
6130               case ABMON_3:  mon++;
6131               case ABMON_2:  mon++;
6132               case ABMON_1:
6133                 format = "%b";
6134                 break;
6135               case MON_12: mon++;
6136               case MON_11: mon++;
6137               case MON_10: mon++;
6138               case MON_9:  mon++;
6139               case MON_8:  mon++;
6140               case MON_7:  mon++;
6141               case MON_6:  mon++;
6142               case MON_5:  mon++;
6143               case MON_4:  mon++;
6144               case MON_3:  mon++;
6145               case MON_2:  mon++;
6146               case MON_1:
6147                 format = "%B";
6148                 break;
6149               case T_FMT_AMPM:
6150                 format = "%r";
6151                 return_format = TRUE;
6152                 break;
6153               case ERA_D_FMT:
6154                 format = "%Ex";
6155                 return_format = TRUE;
6156                 break;
6157               case ERA_T_FMT:
6158                 format = "%EX";
6159                 return_format = TRUE;
6160                 break;
6161               case ERA_D_T_FMT:
6162                 format = "%Ec";
6163                 return_format = TRUE;
6164                 break;
6165               case ALT_DIGITS:
6166                 format = "%Ow"; /* Find the alternate digit for 0 */
6167                 break;
6168             }
6169
6170             GCC_DIAG_RESTORE_STMT;
6171
6172             /* The year was deliberately chosen so that January 1 is on the
6173              * first day of the week.  Since we're only getting one thing at a
6174              * time, it all works */
6175             struct tm  mytm;
6176             ints_to_tm(&mytm, 30, 30, hour, mday, mon, 2011, 0, 0, 0);
6177             char * temp;
6178             if (utf8ness) {
6179                 temp = strftime8(format,
6180                                  &mytm,
6181                                  UTF8NESS_IMMATERIAL, /* All possible formats
6182                                                          specified above are
6183                                                          entirely ASCII */
6184                                  &is_utf8,
6185                                  false      /* not calling from sv_strftime */
6186                                 );
6187             }
6188             else {
6189                 temp = strftime_tm(format, &mytm);
6190             }
6191
6192             retval = save_to_buffer(temp, retbufp, retbuf_sizep);
6193             Safefree(temp);
6194
6195             /* If the item is 'ALT_DIGITS', '*retbuf' contains the alternate
6196              * format for wday 0.  If the value is the same as the normal 0,
6197              * there isn't an alternate, so clear the buffer.
6198              *
6199              * (wday was chosen because its range is all a single digit.
6200              * Things like tm_sec have two digits as the minimum: '00'.) */
6201             if (item == ALT_DIGITS && strEQ(*retbufp, "0")) {
6202                 retval = "";
6203                 break;
6204             }
6205
6206             /* ALT_DIGITS is problematic.  Experiments on it showed that
6207              * strftime() did not always work properly when going from alt-9 to
6208              * alt-10.  Only a few locales have this item defined, and in all
6209              * of them on Linux that khw was able to find, nl_langinfo() merely
6210              * returned the alt-0 character, possibly doubled.  Most Unicode
6211              * digits are in blocks of 10 consecutive code points, so that is
6212              * sufficient information for such scripts, as we can infer alt-1,
6213              * alt-2, ....  But for a Japanese locale, a CJK ideographic 0 is
6214              * returned, and the CJK digits are not in code point order, so you
6215              * can't really infer anything.  The localedef for this locale did
6216              * specify the succeeding digits, so that strftime() works properly
6217              * on them, without needing to infer anything.  But the
6218              * nl_langinfo() return did not give sufficient information for the
6219              * caller to understand what's going on.  So until there is
6220              * evidence that it should work differently, this returns the alt-0
6221              * string for ALT_DIGITS. */
6222
6223             if (return_format) {
6224
6225                 /* If to return the format, not the value, overwrite the buffer
6226                  * with it.  But some strftime()s will keep the original format
6227                  * if illegal, so change those to "" */
6228                 if (strEQ(*retbufp, format)) {
6229                     retval = "";
6230                 }
6231                 else {
6232                     retval = format;
6233                 }
6234
6235                 /* A format is always in ASCII */
6236                 is_utf8 = UTF8NESS_IMMATERIAL;
6237             }
6238
6239             break;
6240         }
6241
6242 #    endif
6243 #    ifdef USE_LOCALE_CTYPE
6244
6245       case CODESET:
6246
6247         /* The trivial case */
6248         if (isNAME_C_OR_POSIX(locale)) {
6249             retval = C_codeset;
6250             break;
6251         }
6252
6253 #      ifdef WIN32
6254
6255         /* This function retrieves the code page.  It is subject to change, but
6256          * is documented and has been stable for many releases */
6257         UINT ___lc_codepage_func(void);
6258
6259 #        ifndef WIN32_USE_FAKE_OLD_MINGW_LOCALES
6260
6261         retval = save_to_buffer(Perl_form(aTHX_ "%d", ___lc_codepage_func()),
6262                                 retbufp, retbuf_sizep);
6263 #        else
6264
6265         retval = save_to_buffer(nl_langinfo(CODESET),
6266                                 retbufp, retbuf_sizep);
6267 #        endif
6268
6269         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "locale='%s' cp=%s\n",
6270                                                locale, retval));
6271         break;
6272
6273 #      else
6274
6275         /* The codeset is important, but khw did not figure out a way for it to
6276          * be retrieved on non-Windows boxes without nl_langinfo().  But even
6277          * if we can't get it directly, we can usually determine if it is a
6278          * UTF-8 locale or not.  If it is UTF-8, we (correctly) use that for
6279          * the code set. */
6280
6281 #        if defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
6282
6283         /* If libc mbtowc() evaluates the bytes that form the REPLACEMENT
6284          * CHARACTER as that Unicode code point, this has to be a UTF-8 locale.
6285          * */
6286         wchar_t wc = 0;
6287         (void) Perl_mbtowc_(aTHX_ NULL, NULL, 0);/* Reset shift state */
6288         int mbtowc_ret = Perl_mbtowc_(aTHX_ &wc,
6289                                       STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8));
6290         if (mbtowc_ret >= 0 && wc == UNICODE_REPLACEMENT) {
6291             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6292                                    "mbtowc returned REPLACEMENT\n"));
6293             retval = "UTF-8";
6294             break;
6295         }
6296
6297         /* Here, it isn't a UTF-8 locale. */
6298
6299 #        else   /* mbtowc() is not available.  The chances of this code getting
6300                    compiled are very small, as it is a C99 required function,
6301                    and we are now requiring C99; perhaps if it is a defective
6302                    implementation.  But if so, there are other libc functions
6303                    that could be used instead. */
6304
6305         /* Sling together several possibilities, depending on platform
6306          * capabilities and what we found.
6307          *
6308          * For non-English locales or non-dollar currency locales, we likely
6309          * will find out whether a locale is UTF-8 or not */
6310
6311         utf8ness_t is_utf8 = UTF8NESS_UNKNOWN;
6312         char * scratch_buf = NULL;
6313
6314 #          if defined(USE_LOCALE_MONETARY) && defined(HAS_LOCALECONV)
6315 #            define LANGINFO_RECURSED_MONETARY  0x1
6316
6317         /* Can't use this method unless localeconv() is available, as that's
6318          * the way we find out the currency symbol.
6319          *
6320          * First try looking at the currency symbol (via a recursive call) to
6321          * see if it disambiguates things.  Often that will be in the native
6322          * script, and if the symbol isn't legal UTF-8, we know that the locale
6323          * isn't either.
6324          *
6325          * The recursion calls my_localeconv() to find CRNCYSTR, and that can
6326          * call is_locale_utf8() which will call my_langinfo(CODESET) which
6327          * will get to here again, ad infinitum.  The guard prevents that.
6328          */
6329         if ((PL_langinfo_recursed & LANGINFO_RECURSED_MONETARY) == 0) {
6330             PL_langinfo_recursed |= LANGINFO_RECURSED_MONETARY;
6331             (void) my_langinfo_c(CRNCYSTR, LC_MONETARY, locale, &scratch_buf,
6332                                  NULL, &is_utf8);
6333             PL_langinfo_recursed &= ~LANGINFO_RECURSED_MONETARY;
6334         }
6335
6336         Safefree(scratch_buf);
6337
6338 #          endif
6339 #          ifdef USE_LOCALE_TIME
6340 #            define LANGINFO_RECURSED_TIME      0x2
6341 #            ifdef LANGINFO_RECURSED_MONETARY
6342 #               if LANGINFO_RECURSED_MONETARY == LANGINFO_RECURSED_TIME
6343 #                 error LANGINFO_RECURSED_MONETARY must differ from LANGINFO_RECURSED_TIME
6344 #               endif
6345 #             endif
6346
6347         /* If we have ruled out being UTF-8, no point in checking further. */
6348         if (   is_utf8 != UTF8NESS_NO
6349             && (PL_langinfo_recursed & LANGINFO_RECURSED_TIME) == 0)
6350         {
6351             /* But otherwise do check more.  This is done even if the currency
6352              * symbol looks to be UTF-8, just in case that's a false positive.
6353              *
6354              * Look at the LC_TIME entries, like the names of the months or
6355              * weekdays.  We quit at the first one that is illegal UTF-8
6356              *
6357              * The recursion guard is because the recursed my_langinfo_c() will
6358              * call strftime8() to find the LC_TIME value passed to it, and
6359              * that will call my_langinfo(CODESET) for non-ASCII returns,
6360              * which will get here again, ad infinitum
6361              */
6362
6363             utf8ness_t this_is_utf8 = UTF8NESS_UNKNOWN;
6364             const int times[] = {
6365                 DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7,
6366                 MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7, MON_8,
6367                                             MON_9, MON_10, MON_11, MON_12,
6368                 ALT_DIGITS, AM_STR, PM_STR,
6369                 ABDAY_1, ABDAY_2, ABDAY_3, ABDAY_4, ABDAY_5, ABDAY_6,
6370                                                              ABDAY_7,
6371                 ABMON_1, ABMON_2, ABMON_3, ABMON_4, ABMON_5, ABMON_6,
6372                 ABMON_7, ABMON_8, ABMON_9, ABMON_10, ABMON_11, ABMON_12
6373             };
6374
6375             /* The code in the recursive call can handle switching the locales,
6376              * but by doing it here, we avoid switching each iteration of the
6377              * loop */
6378             const char * orig_TIME_locale = toggle_locale_c(LC_TIME, locale);
6379
6380             PL_langinfo_recursed |= LANGINFO_RECURSED_TIME;
6381             for (PERL_UINT_FAST8_T i = 0; i < C_ARRAY_LENGTH(times); i++) {
6382                 scratch_buf = NULL;
6383                 (void) my_langinfo_c(times[i], LC_TIME, locale, &scratch_buf,
6384                                      NULL, &this_is_utf8);
6385                 Safefree(scratch_buf);
6386                 if (this_is_utf8 == UTF8NESS_NO) {
6387                     is_utf8 = UTF8NESS_NO;
6388                     break;
6389                 }
6390
6391                 if (this_is_utf8 == UTF8NESS_YES) {
6392                     is_utf8 = UTF8NESS_YES;
6393                 }
6394             }
6395             PL_langinfo_recursed &= ~LANGINFO_RECURSED_TIME;
6396
6397             /* Here we have gone through all the LC_TIME elements.  is_utf8 has
6398              * been set as follows:
6399              *      UTF8NESS_NO           If at least one isn't legal UTF-8
6400              *      UTF8NESS_IMMMATERIAL  If all are ASCII
6401              *      UTF8NESS_YES          If all are legal UTF-8 (including
6402              *                            ASCII), and at least one isn't
6403              *                            ASCII. */
6404
6405             restore_toggled_locale_c(LC_TIME, orig_TIME_locale);
6406         }
6407
6408 #          endif    /* LC_TIME */
6409
6410         /* If nothing examined above rules out it being UTF-8, and at least one
6411          * thing fits as UTF-8 (and not plain ASCII), assume the codeset is
6412          * UTF-8. */
6413         if (is_utf8 == UTF8NESS_YES) {
6414             retval = "UTF-8";
6415             break;
6416         }
6417
6418         /* Here, nothing examined indicates that the codeset is UTF-8.  But
6419          * what is it?  The other locale categories are not likely to be of
6420          * further help:
6421          *
6422          * LC_NUMERIC   Only a few locales in the world have a non-ASCII radix
6423          *              or group separator.
6424          * LC_CTYPE     This code wouldn't be compiled if mbtowc() existed and
6425          *              was reliable.  This is unlikely in C99.  There are
6426          *              other functions that could be used instead, but are
6427          *              they going to exist, and be able to distinguish between
6428          *              UTF-8 and 8859-1?  Deal with this only if it becomes
6429          *              necessary.
6430          * LC_MESSAGES  The strings returned from strerror() would seem likely
6431          *              candidates, but experience has shown that many systems
6432          *              don't actually have translations installed for them.
6433          *              They are instead always in English, so everything in
6434          *              them is ASCII, which is of no help to us.  A Configure
6435          *              probe could possibly be written to see if this platform
6436          *              has non-ASCII error messages.  But again, wait until it
6437          *              turns out to be an actual problem. */
6438
6439 #        endif    /* ! mbtowc() */
6440
6441         /* Rejoin the mbtowc available/not-available cases.
6442          *
6443          * We got here only because we haven't been able to find the codeset.
6444          * The only other option khw could think of is to see if the codeset is
6445          * part of the locale name.  This is very less than ideal; often there
6446          * is no code set in the name; and at other times they even lie.
6447          *
6448          * But there is an XPG standard syntax, which many locales follow:
6449          *
6450          * language[_territory[.codeset]][@modifier]
6451          *
6452          * So we take the part between the dot and any '@' */
6453         retval = (const char *) strchr(locale, '.');
6454         if (! retval) {
6455             retval = "";  /* Alas, no dot */
6456             break;
6457         }
6458
6459         /* Don't include the dot */
6460         retval++;
6461
6462         /* And stop before any '@' */
6463         const char * modifier = strchr(retval, '@');
6464         if (modifier) {
6465             char * code_set_name;
6466             const Size_t name_len = modifier - retval;
6467             Newx(code_set_name, name_len + 1, char);         /* +1 for NUL */
6468             my_strlcpy(code_set_name, retval, name_len + 1);
6469             SAVEFREEPV(code_set_name);
6470             retval = code_set_name;
6471         }
6472
6473 #        if defined(HAS_MBTOWC) || defined(HAS_MBRTOWC)
6474
6475         /* When these functions, are available, they were tried earlier and
6476          * indicated that the locale did not act like a proper UTF-8 one.  So
6477          * if it claims to be UTF-8, it is a lie */
6478         if (is_codeset_name_UTF8(retval)) {
6479             retval = "";
6480             break;
6481         }
6482
6483 #        endif
6484
6485         /* Otherwise the code set name is considered to be everything between
6486          * the dot and the '@' */
6487         retval = save_to_buffer(retval, retbufp, retbuf_sizep);
6488
6489         break;
6490
6491 #      endif    /* ! WIN32 */
6492 #    endif      /* USE_LOCALE_CTYPE */
6493
6494     } /* Giant switch() of nl_langinfo() items */
6495
6496     restore_toggled_locale_i(cat_index, orig_switched_locale);
6497
6498 #    ifdef USE_LOCALE_CTYPE
6499     restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
6500 #    endif
6501
6502     if (utf8ness) {
6503         *utf8ness = is_utf8;
6504     }
6505
6506     return retval;
6507
6508 #  endif    /* All the implementations of my_langinfo() */
6509
6510 /*--------------------------------------------------------------------------*/
6511
6512 }   /* my_langinfo() */
6513
6514 #endif      /* USE_LOCALE */
6515
6516 /*
6517 =for apidoc_section $time
6518 =for apidoc      sv_strftime_tm
6519 =for apidoc_item sv_strftime_ints
6520 =for apidoc_item my_strftime
6521
6522 These implement the libc strftime(), but with a different API so that the return
6523 value is a pointer to the formatted result (which MUST be arranged to be FREED
6524 BY THE CALLER).  This allows these functions to increase the buffer size as
6525 needed, so that the caller doesn't have to worry about that.
6526
6527 On failure they return NULL, and set errno to C<EINVAL>.
6528
6529 C<sv_strftime_tm> and C<sv_strftime_ints> are preferred, as they transparently
6530 handle the UTF-8ness of the current locale, the input C<fmt>, and the returned
6531 result.  Only if the current C<LC_TIME> locale is a UTF-8 one (and S<C<use
6532 bytes>> is not in effect) will the result be marked as UTF-8.  These differ
6533 only in the form of their inputs.  C<sv_strftime_tm> takes a filled-in
6534 S<C<struct tm>> parameter.  C<sv_strftime_ints> takes a bunch of integer
6535 parameters that together completely define a given time.
6536
6537 C<my_strftime> is kept for backwards compatibility.  Knowing if the result
6538 should be considered UTF-8 or not requires significant extra logic.
6539
6540 Note that C<yday> and C<wday> effectively are ignored by C<sv_strftime_ints>
6541 and C<my_strftime>, as mini_mktime() overwrites them
6542
6543 Also note that all three functions are always executed in the underlying
6544 C<LC_TIME> locale of the program, giving results based on that locale.
6545
6546 =cut
6547  */
6548
6549 STATIC void
6550 S_ints_to_tm(pTHX_ struct tm * mytm,
6551                    int sec, int min, int hour, int mday, int mon, int year,
6552                    int wday, int yday, int isdst)
6553 {
6554     /* Create a struct tm structure from the input time-related integer
6555      * variables */
6556
6557     /* Override with the passed-in values */
6558     Zero(mytm, 1, struct tm);
6559     mytm->tm_sec = sec;
6560     mytm->tm_min = min;
6561     mytm->tm_hour = hour;
6562     mytm->tm_mday = mday;
6563     mytm->tm_mon = mon;
6564     mytm->tm_year = year;
6565     mytm->tm_wday = wday;
6566     mytm->tm_yday = yday;
6567     mytm->tm_isdst = isdst;
6568     mini_mktime(mytm);
6569
6570     /* use libc to get the values for tm_gmtoff and tm_zone on platforms that
6571      * have them [perl #18238] */
6572 #if  defined(HAS_MKTIME)                                      \
6573  && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
6574     struct tm mytm2 = *mytm;
6575     MKTIME_LOCK;
6576     mktime(&mytm2);
6577     MKTIME_UNLOCK;
6578 #  ifdef HAS_TM_TM_GMTOFF
6579     mytm->tm_gmtoff = mytm2.tm_gmtoff;
6580 #  endif
6581 #  ifdef HAS_TM_TM_ZONE
6582     mytm->tm_zone = mytm2.tm_zone;
6583 #  endif
6584 #endif
6585
6586     return;
6587 }
6588
6589 STATIC char *
6590 S_strftime_tm(pTHX_ const char *fmt, const struct tm *mytm)
6591 {
6592     PERL_ARGS_ASSERT_STRFTIME_TM;
6593
6594     /* Execute strftime() based on the input struct tm */
6595
6596     /* An empty format yields an empty result */
6597     const int fmtlen = strlen(fmt);
6598     if (fmtlen == 0) {
6599         char *ret;
6600         Newxz (ret, 1, char);
6601         return ret;
6602     }
6603
6604 #ifndef HAS_STRFTIME
6605     Perl_croak(aTHX_ "panic: no strftime");
6606 #else
6607 #  if defined(USE_LOCALE_CTYPE) && defined(USE_LOCALE_TIME)
6608
6609     const char * orig_CTYPE_LOCALE = toggle_locale_c(LC_CTYPE,
6610                                                      querylocale_c(LC_TIME));
6611 #  endif
6612
6613     /* Guess an initial size for the returned string based on an expansion
6614      * factor of the input format, but with a minimum that should handle most
6615      * common cases.  If this guess is too small, we will try again with a
6616      * larger one */
6617     int bufsize = MAX(fmtlen * 2, 64);
6618
6619     char *buf = NULL;   /* Makes Renew() act as Newx() on the first iteration */
6620     do {
6621         Renew(buf, bufsize, char);
6622
6623         /* allowing user-supplied (rather than literal) formats is normally
6624          * frowned upon as a potential security risk; but this is part of the
6625          * API so we have to allow it (and the available formats have a much
6626          * lower chance of doing something bad than the ones for printf etc. */
6627         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
6628
6629         STRFTIME_LOCK;
6630         int len = strftime(buf, bufsize, fmt, mytm);
6631         STRFTIME_UNLOCK;
6632
6633         GCC_DIAG_RESTORE_STMT;
6634
6635         /* A non-zero return indicates success.  But to make sure we're not
6636          * dealing with some rogue strftime that returns how much space it
6637          * needs instead of 0 when there isn't enough, check that the return
6638          * indicates we have at least one byte of spare space (which will be
6639          * used for the terminating NUL). */
6640         if (inRANGE(len, 1, bufsize - 1)) {
6641             goto strftime_return;
6642         }
6643
6644         /* There are several possible reasons for a 0 return code for a
6645          * non-empty format, and they are not trivial to tease apart.  This
6646          * issue is a known bug in the strftime() API.  What we do to cope is
6647          * to assume that the reason is not enough space in the buffer, so
6648          * increase it and try again. */
6649         bufsize *= 2;
6650
6651         /* But don't just keep increasing the size indefinitely.  Stop when it
6652          * becomes obvious that the reason for failure is something besides not
6653          * enough space.  The most likely largest expanding format is %c.  On
6654          * khw's Linux box, the maximum result of this is 67 characters, in the
6655          * km_KH locale.  If a new script comes along that uses 4 UTF-8 bytes
6656          * per character, and with a similar expansion factor, that would be a
6657          * 268:2 byte ratio, or a bit more than 128:1 = 2**7:1.  Some strftime
6658          * implementations allow you to say %1000c to pad to 1000 bytes.  This
6659          * shows that it is impossible to implement this without a heuristic
6660          * (which can fail).  But it indicates we need to be generous in the
6661          * upper limit before failing.  The previous heuristic used was too
6662          * stingy.  Since the size doubles per iteration, it doesn't take many
6663          * to reach the limit */
6664     } while (bufsize < ((1 << 11) + 1) * fmtlen);
6665
6666     /* Here, strftime() returned 0, and it likely wasn't for lack of space.
6667      * There are two possible reasons:
6668      *
6669      * First is that the result is legitimately 0 length.  This can happen
6670      * when the format is precisely "%p".  That is the only documented format
6671      * that can have an empty result. */
6672     if (strEQ(fmt, "%p")) {
6673         Renew(buf, 1, char);
6674         *buf = '\0';
6675         goto strftime_return;
6676     }
6677
6678     /* The other reason is that the format string is malformed.  Probably it is
6679      * that the string is syntactically invalid for the locale.  On some
6680      * platforms an invalid conversion specifier '%?' (for all illegal '?') is
6681      * treated as a literal, but others may fail when '?' is illegal */
6682     Safefree(buf);
6683     SET_EINVAL;
6684     buf = NULL;
6685
6686   strftime_return:
6687
6688 #  if defined(USE_LOCALE_CTYPE) && defined(USE_LOCALE_TIME)
6689
6690     restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_LOCALE);
6691
6692 #  endif
6693
6694     return buf;
6695
6696 #endif
6697
6698 }
6699
6700 STATIC char *
6701 S_strftime8(pTHX_ const char * fmt,
6702                   const struct tm * mytm,
6703                   const utf8ness_t fmt_utf8ness,
6704                   utf8ness_t * result_utf8ness,
6705                   const bool came_from_sv)
6706 {
6707     PERL_ARGS_ASSERT_STRFTIME8;
6708
6709     /* Wrap strftime_tm, taking into account the input and output UTF-8ness */
6710
6711 #ifdef USE_LOCALE_TIME
6712 #  define INDEX_TO_USE  LC_TIME_INDEX_
6713
6714     const char * locale = querylocale_c(LC_TIME);
6715     locale_utf8ness_t locale_utf8ness = LOCALE_UTF8NESS_UNKNOWN;
6716
6717 #else
6718 #  define INDEX_TO_USE  LC_ALL_INDEX_   /* Effectively out of bounds */
6719
6720     const char * locale = "C";
6721     locale_utf8ness_t locale_utf8ness = LOCALE_NOT_UTF8;
6722
6723 #endif
6724
6725     switch (fmt_utf8ness) {
6726       case UTF8NESS_IMMATERIAL:
6727         break;
6728
6729       case UTF8NESS_NO: /* Known not to be UTF-8; must not be UTF-8 locale */
6730         if (is_locale_utf8(locale)) {
6731             SET_EINVAL;
6732             return NULL;
6733         }
6734
6735         locale_utf8ness = LOCALE_NOT_UTF8;
6736         break;
6737
6738       case UTF8NESS_YES:    /* Known to be UTF-8; must be UTF-8 locale if can't
6739                                downgrade. */
6740         if (! is_locale_utf8(locale)) {
6741             locale_utf8ness = LOCALE_NOT_UTF8;
6742
6743             bool is_utf8 = true;
6744             Size_t fmt_len = strlen(fmt);
6745             fmt = (char *) bytes_from_utf8((U8 *) fmt, &fmt_len, &is_utf8);
6746             if (is_utf8) {
6747                 SET_EINVAL;
6748                 return NULL;
6749             }
6750
6751             SAVEFREEPV(fmt);
6752         }
6753         else {
6754             locale_utf8ness = LOCALE_IS_UTF8;
6755         }
6756
6757         break;
6758
6759       case UTF8NESS_UNKNOWN:
6760         if (! is_locale_utf8(locale)) {
6761             locale_utf8ness = LOCALE_NOT_UTF8;
6762         }
6763         else {
6764             locale_utf8ness = LOCALE_IS_UTF8;
6765             if (came_from_sv) {
6766
6767                 /* Upgrade 'fmt' to UTF-8 for a UTF-8 locale.  Otherwise the
6768                  * locale would find any UTF-8 variant characters to be
6769                  * malformed */
6770                 Size_t fmt_len = strlen(fmt);
6771                 fmt = (char *) bytes_to_utf8((U8 *) fmt, &fmt_len);
6772                 SAVEFREEPV(fmt);
6773             }
6774         }
6775
6776         break;
6777     }
6778
6779     char * retval = strftime_tm(fmt, mytm);
6780     *result_utf8ness = get_locale_string_utf8ness_i(retval,
6781                                                     locale_utf8ness,
6782                                                     locale,
6783                                                     INDEX_TO_USE);
6784     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
6785                           "fmt=%s, retval=%s; utf8ness=%d",
6786                           fmt,
6787                           ((is_utf8_string((U8 *) retval, 0))
6788                            ? retval
6789                            :_byte_dump_string((U8 *) retval, strlen(retval),0)),
6790                           *result_utf8ness));
6791     return retval;
6792
6793 #undef INDEX_TO_USE
6794
6795 }
6796
6797 #ifdef USE_LOCALE
6798
6799 STATIC void
6800 S_give_perl_locale_control(pTHX_
6801 #  ifdef LC_ALL
6802                            const char * lc_all_string,
6803 #  else
6804                            const char ** locales,
6805 #  endif
6806                            const line_t caller_line)
6807 {
6808     PERL_UNUSED_ARG(caller_line);
6809
6810     /* This is called when the program is in the global locale and are
6811      * switching to per-thread (if available).  And it is called at
6812      * initialization time to do the same.
6813      */
6814
6815 #  if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE)
6816
6817     /* On Windows, convert to per-thread behavior.  This isn't necessary in
6818      * POSIX 2008, as the conversion gets done automatically in the
6819      * void_setlocale_i() calls below. */
6820     if (_configthreadlocale(_ENABLE_PER_THREAD_LOCALE) == -1) {
6821         locale_panic_("_configthreadlocale returned an error");
6822     }
6823
6824 #  endif
6825 #  if ! defined(USE_THREAD_SAFE_LOCALE)                               \
6826    && ! defined(USE_POSIX_2008_LOCALE)
6827 #    if defined(LC_ALL)
6828     PERL_UNUSED_ARG(lc_all_string);
6829 #    else
6830     PERL_UNUSED_ARG(locales);
6831 #    endif
6832 #  else
6833
6834     /* This platform has per-thread locale handling.  Do the conversion. */
6835
6836 #    if defined(LC_ALL)
6837
6838     void_setlocale_c_with_caller(LC_ALL, lc_all_string, __FILE__, caller_line);
6839
6840 #    else
6841
6842     for_all_individual_category_indexes(i) {
6843         void_setlocale_i_with_caller(i, locales[i], __FILE__, caller_line);
6844     }
6845
6846 #    endif
6847 #  endif
6848
6849     /* Finally, update our remaining records.  'true' => force recalculation.
6850      * This is needed because we don't know what's happened while Perl hasn't
6851      * had control, so we need to figure out the current state */
6852
6853 #  if defined(LC_ALL)
6854
6855     new_LC_ALL(lc_all_string, true);
6856
6857 #    else
6858
6859     new_LC_ALL(calculate_LC_ALL_string(locales,
6860                                        INTERNAL_FORMAT,
6861                                        WANT_TEMP_PV,
6862                                        caller_line),
6863                true);
6864 #    endif
6865
6866 }
6867
6868 STATIC void
6869 S_output_check_environment_warning(pTHX_ const char * const language,
6870                                          const char * const lc_all,
6871                                          const char * const lang)
6872 {
6873     PerlIO_printf(Perl_error_log,
6874                   "perl: warning: Please check that your locale settings:\n");
6875
6876 #  ifdef __GLIBC__
6877
6878     PerlIO_printf(Perl_error_log, "\tLANGUAGE = %c%s%c,\n",
6879                                   language ? '"' : '(',
6880                                   language ? language : "unset",
6881                                   language ? '"' : ')');
6882 #  else
6883     PERL_UNUSED_ARG(language);
6884 #  endif
6885
6886     PerlIO_printf(Perl_error_log, "\tLC_ALL = %c%s%c,\n",
6887                                   lc_all ? '"' : '(',
6888                                   lc_all ? lc_all : "unset",
6889                                   lc_all ? '"' : ')');
6890
6891     for_all_individual_category_indexes(i) {
6892         const char * value = PerlEnv_getenv(category_names[i]);
6893         PerlIO_printf(Perl_error_log,
6894                       "\t%s = %c%s%c,\n",
6895                       category_names[i],
6896                       value ? '"' : '(',
6897                       value ? value : "unset",
6898                       value ? '"' : ')');
6899     }
6900
6901     PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n",
6902                                   lang ? '"' : '(',
6903                                   lang ? lang : "unset",
6904                                   lang ? '"' : ')');
6905     PerlIO_printf(Perl_error_log,
6906                   "    are supported and installed on your system.\n");
6907 }
6908
6909 #endif
6910
6911 /* A helper macro for the next function.  Needed because would be called in two
6912  * places.  Knows about the internal workings of the function */
6913 #define GET_DESCRIPTION(trial, name)                                    \
6914     ((isNAME_C_OR_POSIX(name))                                          \
6915      ? "the standard locale"                                            \
6916      : ((trial == (system_default_trial)                                \
6917                   ? "the system default locale"                         \
6918                   : "a fallback locale")))
6919
6920 /*
6921  * Initialize locale awareness.
6922  */
6923 int
6924 Perl_init_i18nl10n(pTHX_ int printwarn)
6925 {
6926     /* printwarn is:
6927      *    0 if not to output warning when setup locale is bad
6928      *    1 if to output warning based on value of PERL_BADLANG
6929      *    >1 if to output regardless of PERL_BADLANG
6930      *
6931      * returns
6932      *    1 = set ok or not applicable,
6933      *    0 = fallback to a locale of lower priority
6934      *   -1 = fallback to all locales failed, not even to the C locale
6935      *
6936      * Under -DDEBUGGING, if the environment variable PERL_DEBUG_LOCALE_INIT is
6937      * set, debugging information is output.
6938      *
6939      * This routine effectively does the following in most cases:
6940      *
6941      *      basic initialization;
6942      *      asserts that the compiled tables are consistent;
6943      *      initialize data structures;
6944      *      make sure we are in the global locale;
6945      *      setlocale(LC_ALL, "");
6946      *      switch to per-thread locale if applicable;
6947      *
6948      * The "" causes the locale to be set to what the environment variables at
6949      * the time say it should be.
6950      *
6951      * To handle possible failures, the setlocale is expanded to be like:
6952      *
6953      *      trial_locale = pre-first-trial;
6954      *      while (has_another_trial()) {
6955      *          trial_locale = next_trial();
6956      *          if setlocale(LC_ALL, trial_locale) {
6957      *              ok = true;
6958      *              break;
6959      *          }
6960      *
6961      *          had_failure = true;
6962      *          warn();
6963      *      }
6964      *
6965      *      if (had_failure) {
6966      *          warn_even_more();
6967      *          if (! ok) warn_still_more();
6968      *      }
6969      *
6970      * The first trial is either:
6971      *      ""      to examine the environment variables for the locale
6972      *      NULL    to use the values already set for the locale by the program
6973      *              embedding this perl instantiation.
6974      *
6975      * Something is wrong if this trial fails, but there is a sequence of
6976      * fallbacks to try should that happen.  They are given in the enum below.
6977
6978      * If there is no LC_ALL defined on the system, the setlocale() above is
6979      * replaced by a loop setting each individual category separately.
6980      *
6981      * In a non-embeded environment, this code is executed exactly once.  It
6982      * sets up the global locale environment.  At the end, if some sort of
6983      * thread-safety is in effect, it will turn thread 0 into using that, with
6984      * the same locale as the global initially.  thread 0 can then change its
6985      * locale at will without affecting the global one.
6986      *
6987      * At destruction time, thread 0 will revert to the global locale as the
6988      * other threads die.
6989      *
6990      * Care must be taken in an embedded environment.  This code will be
6991      * executed for each instantiation.  Since it changes the global locale, it
6992      * could clash with another running instantiation that isn't using
6993      * per-thread locales.  perlembed suggests having the controlling program
6994      * set each instantiation's locale and set PERL_SKIP_LOCALE_INIT so this
6995      * code uses that without actually changing anything.  Then the onus is on
6996      * the controlling program to prevent any races.  The code below does
6997      * enough locking so as to prevent system calls from overwriting data
6998      * before it is safely copied here, but that isn't a general solution.
6999      */
7000
7001 #ifndef USE_LOCALE
7002
7003     PERL_UNUSED_ARG(printwarn);
7004     const int ok = 1;
7005
7006 #else  /* USE_LOCALE to near the end of the routine */
7007
7008     int ok = 0;
7009
7010 #  ifdef __GLIBC__
7011
7012     const char * const language = PerlEnv_getenv("LANGUAGE");
7013
7014 #  else
7015     const char * const language = NULL;     /* Unused placeholder */
7016 #  endif
7017
7018     /* A later getenv() could zap this, so only use here */
7019     const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
7020
7021     const bool locwarn = (printwarn > 1
7022                           || (          printwarn
7023                               && (    ! bad_lang_use_once
7024                                   || (
7025                                          /* disallow with "" or "0" */
7026                                          *bad_lang_use_once
7027                                        && strNE("0", bad_lang_use_once)))));
7028
7029 #  ifndef DEBUGGING
7030 #    define DEBUG_LOCALE_INIT(a,b,c)
7031 #  else
7032
7033     DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
7034
7035 #    define DEBUG_LOCALE_INIT(cat_index, locale, result)                    \
7036         DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",                       \
7037                     setlocale_debug_string_i(cat_index, locale, result)));
7038
7039 #    ifdef LC_ALL
7040     assert(categories[LC_ALL_INDEX_] == LC_ALL);
7041     assert(strEQ(category_names[LC_ALL_INDEX_], "LC_ALL"));
7042 #      ifdef USE_POSIX_2008_LOCALE
7043     assert(category_masks[LC_ALL_INDEX_] == LC_ALL_MASK);
7044 #      endif
7045 #    endif
7046
7047     for_all_individual_category_indexes(i) {
7048         assert(category_name_lengths[i] == strlen(category_names[i]));
7049     }
7050
7051 #  endif    /* DEBUGGING */
7052
7053     /* Initialize the per-thread mbrFOO() state variables.  See POSIX.xs for
7054      * why these particular incantations are used. */
7055 #  ifdef HAS_MBRLEN
7056     memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
7057 #  endif
7058 #  ifdef HAS_MBRTOWC
7059     memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
7060 #  endif
7061 #  ifdef HAS_WCTOMBR
7062     wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
7063 #  endif
7064 #  ifdef USE_PL_CURLOCALES
7065
7066     for (unsigned int i = 0; i <= LC_ALL_INDEX_; i++) {
7067         PL_curlocales[i] = savepv("C");
7068     }
7069
7070 #  endif
7071 #  ifdef USE_PL_CUR_LC_ALL
7072
7073     PL_cur_LC_ALL = savepv("C");
7074
7075 #  endif
7076 #  if ! defined(PERL_LC_ALL_USES_NAME_VALUE_PAIRS) && defined(LC_ALL)
7077
7078     LOCALE_LOCK;
7079
7080     /* If we haven't done so already, translate the LC_ALL positions of
7081      * categories into our internal indices. */
7082     if (map_LC_ALL_position_to_index[0] == LC_ALL_INDEX_) {
7083
7084         /* Use this array, initialized by a config.h constant */
7085         int lc_all_category_positions[] = PERL_LC_ALL_CATEGORY_POSITIONS_INIT;
7086         STATIC_ASSERT_STMT(   C_ARRAY_LENGTH(lc_all_category_positions)
7087                            == LC_ALL_INDEX_);
7088
7089         for (unsigned int i = 0;
7090              i < C_ARRAY_LENGTH(lc_all_category_positions);
7091              i++)
7092         {
7093             map_LC_ALL_position_to_index[i] =
7094                               get_category_index(lc_all_category_positions[i]);
7095         }
7096     }
7097
7098     LOCALE_UNLOCK;
7099
7100 #  endif
7101 #  ifdef USE_POSIX_2008_LOCALE
7102
7103     /* This is a global, so be sure to keep another instance from zapping it */
7104     LOCALE_LOCK;
7105     if (PL_C_locale_obj) {
7106         LOCALE_UNLOCK;
7107     }
7108     else {
7109         PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", (locale_t) 0);
7110         if (! PL_C_locale_obj) {
7111             LOCALE_UNLOCK;
7112             locale_panic_(Perl_form(aTHX_
7113                                 "Cannot create POSIX 2008 C locale object"));
7114         }
7115         LOCALE_UNLOCK;
7116
7117         DEBUG_Lv(PerlIO_printf(Perl_debug_log, "created C object %p\n",
7118                                                PL_C_locale_obj));
7119     }
7120
7121     /* Switch to using the POSIX 2008 interface now.  This would happen below
7122      * anyway, but deferring it can lead to leaks of memory that would also get
7123      * malloc'd in the interim.  We arbitrarily switch to the C locale,
7124      * overridden below  */
7125     if (! uselocale(PL_C_locale_obj)) {
7126         locale_panic_(Perl_form(aTHX_
7127                                 "Can't uselocale(%p), LC_ALL supposed to"
7128                                 " be 'C'",
7129                                 PL_C_locale_obj));
7130     }
7131
7132 #    ifdef MULTIPLICITY
7133
7134     PL_cur_locale_obj = PL_C_locale_obj;
7135
7136 #    endif
7137 #  endif
7138
7139     /* Now initialize some data structures.  This is entirely so that
7140      * later-executed code doesn't have to concern itself with things not being
7141      * initialized.  Arbitrarily use the C locale (which we know has to exist
7142      * on the system). */
7143
7144 #  ifdef USE_LOCALE_NUMERIC
7145
7146     PL_numeric_radix_sv    = newSV(1);
7147     PL_underlying_radix_sv = newSV(1);
7148     Newxz(PL_numeric_name, 1, char);    /* Single NUL character */
7149
7150 #  endif
7151 #  ifdef USE_LOCALE_COLLATE
7152
7153     Newxz(PL_collation_name, 1, char);
7154
7155 #  endif
7156 #  ifdef USE_LOCALE_CTYPE
7157
7158     Newxz(PL_ctype_name, 1, char);
7159
7160 #  endif
7161
7162     new_LC_ALL("C", true /* Don't shortcut */);
7163
7164 /*===========================================================================*/
7165
7166     /* Now ready to override the initialization with the values that the user
7167      * wants.  This is done in the global locale as explained in the
7168      * introductory comments to this function */
7169     switch_to_global_locale();
7170
7171     const char * const lc_all     = PerlEnv_getenv("LC_ALL");
7172     const char * const lang       = PerlEnv_getenv("LANG");
7173
7174     /* We try each locale in the enum, in order, until we get one that works,
7175      * or exhaust the list.  Normally the loop is executed just once.
7176      *
7177      * Each enum value is +1 from the previous */
7178     typedef enum {
7179             dummy_trial       = -1,
7180             environment_trial =  0,     /* "" or NULL; code below assumes value
7181                                            0 is the first real trial */
7182             LC_ALL_trial,               /* ENV{LC_ALL} */
7183             LANG_trial,                 /* ENV{LANG} */
7184             system_default_trial,       /* Windows .ACP */
7185             C_trial,                    /* C locale */
7186             beyond_final_trial,
7187     } trials;
7188
7189     trials trial;
7190     SSize_t already_checked = 0;
7191     const char * checked[C_trial];
7192
7193 #  ifdef LC_ALL
7194     const char * lc_all_string;
7195 #  else
7196     const char * curlocales[LC_ALL_INDEX_];
7197 #  endif
7198
7199     /* Loop through the initial setting and all the possible fallbacks,
7200      * breaking out of the loop on success */
7201     trial = dummy_trial;
7202     while (trial != beyond_final_trial) {
7203
7204         /* Each time through compute the next trial to use based on the one in
7205          * the previous iteration and switch to the new one.  This enforces the
7206          * order in which the fallbacks are applied */
7207       next_trial:
7208         trial = (trials) ((int) trial + 1);     /* Casts are needed for g++ */
7209
7210         const char * locale = NULL;
7211
7212         /* Set up the parameters for this trial */
7213         switch (trial) {
7214           case dummy_trial:
7215             locale_panic_("Unexpectedly got 'dummy_trial");
7216             break;
7217
7218           case environment_trial:
7219             /* This is either "" to get the values from the environment, or
7220              * NULL if the calling program has initialized the values already.
7221              * */
7222             locale = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
7223                      ? NULL
7224                      : "";
7225             break;
7226
7227           case LC_ALL_trial:
7228             if (! lc_all || strEQ(lc_all, "")) {
7229                 continue;   /* No-op */
7230             }
7231
7232             locale = lc_all;
7233             break;
7234
7235           case LANG_trial:
7236             if (! lang || strEQ(lang, "")) {
7237                 continue;   /* No-op */
7238             }
7239
7240             locale = lang;
7241             break;
7242
7243           case system_default_trial:
7244
7245 #  if ! defined(WIN32) || ! defined(LC_ALL)
7246
7247             continue;   /* No-op */
7248
7249 #  else
7250             /* For Windows, we also try the system default locale before "C".
7251              * (If there exists a Windows without LC_ALL we skip this because
7252              * it gets too complicated.  For those, "C" is the next fallback
7253              * possibility). */
7254             locale = ".ACP";
7255 #  endif
7256             break;
7257
7258           case C_trial:
7259             locale = "C";
7260             break;
7261
7262           case beyond_final_trial:
7263             continue;     /* No-op, causes loop to exit */
7264         }
7265
7266         /* If the locale is a substantive name, don't try the same locale
7267          * twice. */
7268         if (locale && strNE(locale, "")) {
7269             for (unsigned int i = 0; i < already_checked; i++) {
7270                 if (strEQ(checked[i], locale)) {
7271                     goto next_trial;
7272                 }
7273             }
7274
7275             /* And, for future iterations, indicate we've tried this locale */
7276             checked[already_checked] = savepv(locale);
7277             SAVEFREEPV(checked[already_checked]);
7278             already_checked++;
7279         }
7280
7281 #  ifdef LC_ALL
7282
7283         STDIZED_SETLOCALE_LOCK;
7284         lc_all_string = savepv(stdized_setlocale(LC_ALL, locale));
7285         STDIZED_SETLOCALE_UNLOCK;
7286
7287         DEBUG_LOCALE_INIT(LC_ALL_INDEX_, locale, lc_all_string);
7288
7289         if (LIKELY(lc_all_string)) {     /* Succeeded */
7290             ok = 1;
7291             break;
7292         }
7293
7294         if (trial == 0 && locwarn) {
7295             PerlIO_printf(Perl_error_log,
7296                                   "perl: warning: Setting locale failed.\n");
7297             output_check_environment_warning(language, lc_all, lang);
7298         }
7299
7300 #  else /* Below is ! LC_ALL */
7301
7302         bool setlocale_failure = FALSE;  /* This trial hasn't failed so far */
7303         bool dowarn = trial == 0 && locwarn;
7304
7305         for_all_individual_category_indexes(j) {
7306             STDIZED_SETLOCALE_LOCK;
7307             curlocales[j] = savepv(stdized_setlocale(categories[j], locale));
7308             STDIZED_SETLOCALE_UNLOCK;
7309
7310             DEBUG_LOCALE_INIT(j, locale, curlocales[j]);
7311
7312             if (UNLIKELY(! curlocales[j])) {
7313                 setlocale_failure = TRUE;
7314
7315                 /* If are going to warn below, continue to loop so all failures
7316                  * are included in the message */
7317                 if (! dowarn) {
7318                     break;
7319                 }
7320             }
7321         }
7322
7323         if (LIKELY(! setlocale_failure)) {  /* All succeeded */
7324             ok = 1;
7325             break;  /* Exit trial_locales loop */
7326         }
7327
7328         /* Here, this trial failed */
7329
7330         if (dowarn) {
7331             PerlIO_printf(Perl_error_log,
7332                 "perl: warning: Setting locale failed for the categories:\n");
7333
7334             for_all_individual_category_indexes(j) {
7335                 if (! curlocales[j]) {
7336                     PerlIO_printf(Perl_error_log, "\t%s\n", category_names[j]);
7337                 }
7338             }
7339
7340             output_check_environment_warning(language, lc_all, lang);
7341         }   /* end of warning on first failure */
7342
7343 #  endif /* LC_ALL */
7344
7345     }   /* end of looping through the trial locales */
7346
7347     /* If we had to do more than the first trial, it means that one failed, and
7348      * we may need to output a warning, and, if none worked, do more */
7349     if (UNLIKELY(trial != 0)) {
7350         if (locwarn) {
7351             const char * description = "a fallback locale";
7352             const char * name = NULL;;
7353
7354             /* If we didn't find a good fallback, list all we tried */
7355             if (! ok && already_checked > 0) {
7356                 PerlIO_printf(Perl_error_log, "perl: warning: Failed to fall"
7357                                               " back to ");
7358                 if (already_checked > 1) {  /* more than one was tried */
7359                     PerlIO_printf(Perl_error_log, "any of:\n");
7360                 }
7361
7362                 while (already_checked > 0) {
7363                     name = checked[--already_checked];
7364                     description = GET_DESCRIPTION(trial, name);
7365                     PerlIO_printf(Perl_error_log, "%s (\"%s\")\n",
7366                                                   description, name);
7367                 }
7368             }
7369
7370             if (ok) {
7371
7372                 /* Here, a fallback worked.  So we have saved its name, and the
7373                  * trial that succeeded is still valid */
7374 #  ifdef LC_ALL
7375                 const char * individ_locales[LC_ALL_INDEX_] = { NULL };
7376
7377                 /* Even though we know the valid string for LC_ALL that worked,
7378                  * translate it into our internal format, which is the
7379                  * name=value pairs notation.  This is easier for a human to
7380                  * decipher than the positional notation.  Some platforms
7381                  * can return "C C C C C C" for LC_ALL.  This code also
7382                  * standardizes that result into plain "C". */
7383                 switch (parse_LC_ALL_string(lc_all_string,
7384                                             (const char **) &individ_locales,
7385                                             no_override,
7386                                             false,   /* Return only [0] if
7387                                                         suffices */
7388                                             false,   /* Don't panic on error */
7389                                             __LINE__))
7390                 {
7391                   case invalid:
7392
7393                     /* Here, the parse failed, which shouldn't happen, but if
7394                      * it does, we have an easy fallback that allows us to keep
7395                      * going. */
7396                     name = lc_all_string;
7397                     break;
7398
7399                   case no_array:    /* The original is a single locale */
7400                     name = lc_all_string;
7401                     break;
7402
7403                   case only_element_0:  /* element[0] is a single locale valid
7404                                            for all categories */
7405                     SAVEFREEPV(individ_locales[0]);
7406                     name = individ_locales[0];
7407                     break;
7408
7409                   case full_array:
7410                     name = calculate_LC_ALL_string(individ_locales,
7411                                                    INTERNAL_FORMAT,
7412                                                    WANT_TEMP_PV,
7413                                                    __LINE__);
7414                     for_all_individual_category_indexes(j) {
7415                         Safefree(individ_locales[j]);
7416                     }
7417                 }
7418 #  else
7419                 name = calculate_LC_ALL_string(curlocales,
7420                                                INTERNAL_FORMAT,
7421                                                WANT_TEMP_PV,
7422                                                __LINE__);
7423 #  endif
7424                 description = GET_DESCRIPTION(trial, name);
7425             }
7426             else {
7427
7428                 /* Nothing seems to be working, yet we want to continue
7429                  * executing.  It may well be that locales are mostly
7430                  * irrelevant to this particular program, and there must be
7431                  * some locale underlying the program.  Figure it out as best
7432                  * we can, by querying the system's current locale */
7433
7434 #  ifdef LC_ALL
7435
7436                 STDIZED_SETLOCALE_LOCK;
7437                 name = stdized_setlocale(LC_ALL, NULL);
7438                 STDIZED_SETLOCALE_UNLOCK;
7439
7440                 if (UNLIKELY(! name)) {
7441                     name = "locale name not determinable";
7442                 }
7443
7444 #  else /* Below is ! LC_ALL */
7445
7446                 const char * system_locales[LC_ALL_INDEX_] = { NULL };
7447
7448                 for_all_individual_category_indexes(j) {
7449                     STDIZED_SETLOCALE_LOCK;
7450                     system_locales[j] = savepv(stdized_setlocale(categories[j],
7451                                                                  NULL));
7452                     STDIZED_SETLOCALE_UNLOCK;
7453
7454                     if (UNLIKELY(! system_locales[j])) {
7455                         system_locales[j] = "not determinable";
7456                     }
7457                 }
7458
7459                 /* We use the name=value form for the string, as that is more
7460                  * human readable than the positional notation */
7461                 name = calculate_LC_ALL_string(system_locales,
7462                                                INTERNAL_FORMAT,
7463                                                WANT_TEMP_PV,
7464                                                __LINE__);
7465                 description = "what the system says";
7466
7467                 for_all_individual_category_indexes(j) {
7468                     Safefree(system_locales[j]);
7469                 }
7470 #  endif
7471             }
7472
7473             PerlIO_printf(Perl_error_log,
7474                           "perl: warning: Falling back to %s (\"%s\").\n",
7475                           description, name);
7476
7477             /* Here, ok being true indicates that the first attempt failed, but
7478              * a fallback succeeded; false => nothing working.  Translate to
7479              * API return values. */
7480             ok = (ok) ? 0 : -1;
7481         }
7482     }
7483
7484 #  ifdef LC_ALL
7485
7486     give_perl_locale_control(lc_all_string, __LINE__);
7487     Safefree(lc_all_string);
7488
7489 #  else
7490
7491     give_perl_locale_control((const char **) &curlocales, __LINE__);
7492
7493     for_all_individual_category_indexes(j) {
7494         Safefree(curlocales[j]);
7495     }
7496
7497 #  endif
7498 #  if defined(USE_PERLIO) && defined(USE_LOCALE_CTYPE)
7499
7500     /* Set PL_utf8locale to TRUE if using PerlIO _and_ the current LC_CTYPE
7501      * locale is UTF-8.  give_perl_locale_control() just above has already
7502      * calculated the latter value and saved it in PL_in_utf8_CTYPE_locale. If
7503      * both PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
7504      * are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer on
7505      * STDIN, STDOUT, STDERR, _and_ the default open discipline.  */
7506     PL_utf8locale = PL_in_utf8_CTYPE_locale;
7507
7508     /* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
7509        This is an alternative to using the -C command line switch
7510        (the -C if present will override this). */
7511     {
7512          const char *p = PerlEnv_getenv("PERL_UNICODE");
7513          PL_unicode = p ? parse_unicode_opts(&p) : 0;
7514          if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
7515              PL_utf8cache = -1;
7516     }
7517
7518 #  endif
7519 #  if defined(USE_POSIX_2008_LOCALE) && defined(MULTIPLICITY)
7520     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
7521                            "finished Perl_init_i18nl10n; actual obj=%p,"
7522                            " expected obj=%p, initial=%s\n",
7523                            uselocale(0), PL_cur_locale_obj,
7524                            get_LC_ALL_display()));
7525 #  endif
7526
7527     /* So won't continue to output stuff */
7528     DEBUG_INITIALIZATION_set(FALSE);
7529
7530 #endif /* USE_LOCALE */
7531
7532     return ok;
7533 }
7534
7535 #undef GET_DESCRIPTION
7536 #ifdef USE_LOCALE_COLLATE
7537
7538 STATIC void
7539 S_compute_collxfrm_coefficients(pTHX)
7540 {
7541
7542     /* A locale collation definition includes primary, secondary, tertiary,
7543      * etc. weights for each character.  To sort, the primary weights are used,
7544      * and only if they compare equal, then the secondary weights are used, and
7545      * only if they compare equal, then the tertiary, etc.
7546      *
7547      * strxfrm() works by taking the input string, say ABC, and creating an
7548      * output transformed string consisting of first the primary weights,
7549      * A¹B¹C¹ followed by the secondary ones, A²B²C²; and then the tertiary,
7550      * etc, yielding A¹B¹C¹ A²B²C² A³B³C³ ....  Some characters may not have
7551      * weights at every level.  In our example, let's say B doesn't have a
7552      * tertiary weight, and A doesn't have a secondary weight.  The constructed
7553      * string is then going to be
7554      *  A¹B¹C¹ B²C² A³C³ ....
7555      * This has the desired effect that strcmp() will look at the secondary or
7556      * tertiary weights only if the strings compare equal at all higher
7557      * priority weights.  The spaces shown here, like in
7558      *  "A¹B¹C¹ A²B²C² "
7559      * are not just for readability.  In the general case, these must actually
7560      * be bytes, which we will call here 'separator weights'; and they must be
7561      * smaller than any other weight value, but since these are C strings, only
7562      * the terminating one can be a NUL (some implementations may include a
7563      * non-NUL separator weight just before the NUL).  Implementations tend to
7564      * reserve 01 for the separator weights.  They are needed so that a shorter
7565      * string's secondary weights won't be misconstrued as primary weights of a
7566      * longer string, etc.  By making them smaller than any other weight, the
7567      * shorter string will sort first.  (Actually, if all secondary weights are
7568      * smaller than all primary ones, there is no need for a separator weight
7569      * between those two levels, etc.)
7570      *
7571      * The length of the transformed string is roughly a linear function of the
7572      * input string.  It's not exactly linear because some characters don't
7573      * have weights at all levels.  When we call strxfrm() we have to allocate
7574      * some memory to hold the transformed string.  The calculations below try
7575      * to find coefficients 'm' and 'b' for this locale so that m*x + b equals
7576      * how much space we need, given the size of the input string in 'x'.  If
7577      * we calculate too small, we increase the size as needed, and call
7578      * strxfrm() again, but it is better to get it right the first time to
7579      * avoid wasted expensive string transformations.
7580      *
7581      * We use the string below to find how long the transformation of it is.
7582      * Almost all locales are supersets of ASCII, or at least the ASCII
7583      * letters.  We use all of them, half upper half lower, because if we used
7584      * fewer, we might hit just the ones that are outliers in a particular
7585      * locale.  Most of the strings being collated will contain a preponderance
7586      * of letters, and even if they are above-ASCII, they are likely to have
7587      * the same number of weight levels as the ASCII ones.  It turns out that
7588      * digits tend to have fewer levels, and some punctuation has more, but
7589      * those are relatively sparse in text, and khw believes this gives a
7590      * reasonable result, but it could be changed if experience so dictates. */
7591     const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
7592     char * x_longer;        /* Transformed 'longer' */
7593     Size_t x_len_longer;    /* Length of 'x_longer' */
7594
7595     char * x_shorter;   /* We also transform a substring of 'longer' */
7596     Size_t x_len_shorter;
7597
7598     PL_in_utf8_COLLATE_locale = (PL_collation_standard)
7599                                 ? 0
7600                                 : is_locale_utf8(PL_collation_name);
7601     PL_strxfrm_NUL_replacement = '\0';
7602     PL_strxfrm_max_cp = 0;
7603
7604     /* mem_collxfrm_() is used get the transformation (though here we are
7605      * interested only in its length).  It is used because it has the
7606      * intelligence to handle all cases, but to work, it needs some values of
7607      * 'm' and 'b' to get it started.  For the purposes of this calculation we
7608      * use a very conservative estimate of 'm' and 'b'.  This assumes a weight
7609      * can be multiple bytes, enough to hold any UV on the platform, and there
7610      * are 5 levels, 4 weight bytes, and a trailing NUL.  */
7611     PL_collxfrm_base = 5;
7612     PL_collxfrm_mult = 5 * sizeof(UV);
7613
7614     /* Find out how long the transformation really is */
7615     x_longer = mem_collxfrm_(longer,
7616                              sizeof(longer) - 1,
7617                              &x_len_longer,
7618
7619                              /* We avoid converting to UTF-8 in the called
7620                               * function by telling it the string is in UTF-8
7621                               * if the locale is a UTF-8 one.  Since the string
7622                               * passed here is invariant under UTF-8, we can
7623                               * claim it's UTF-8 even if it isn't.  */
7624                               PL_in_utf8_COLLATE_locale);
7625     Safefree(x_longer);
7626
7627     /* Find out how long the transformation of a substring of 'longer' is.
7628      * Together the lengths of these transformations are sufficient to
7629      * calculate 'm' and 'b'.  The substring is all of 'longer' except the
7630      * first character.  This minimizes the chances of being swayed by outliers
7631      * */
7632     x_shorter = mem_collxfrm_(longer + 1,
7633                               sizeof(longer) - 2,
7634                               &x_len_shorter,
7635                               PL_in_utf8_COLLATE_locale);
7636     Safefree(x_shorter);
7637
7638     /* If the results are nonsensical for this simple test, the whole locale
7639      * definition is suspect.  Mark it so that locale collation is not active
7640      * at all for it.  XXX Should we warn? */
7641     if (   x_len_shorter == 0
7642         || x_len_longer == 0
7643         || x_len_shorter >= x_len_longer)
7644     {
7645         PL_collxfrm_mult = 0;
7646         PL_collxfrm_base = 1;
7647         DEBUG_L(PerlIO_printf(Perl_debug_log,
7648                 "Disabling locale collation for LC_COLLATE='%s';"
7649                 " length for shorter sample=%zu; longer=%zu\n",
7650                 PL_collation_name, x_len_shorter, x_len_longer));
7651     }
7652     else {
7653         SSize_t base;       /* Temporary */
7654
7655         /* We have both: m * strlen(longer)  + b = x_len_longer
7656          *               m * strlen(shorter) + b = x_len_shorter;
7657          * subtracting yields:
7658          *          m * (strlen(longer) - strlen(shorter))
7659          *                             = x_len_longer - x_len_shorter
7660          * But we have set things up so that 'shorter' is 1 byte smaller than
7661          * 'longer'.  Hence:
7662          *          m = x_len_longer - x_len_shorter
7663          *
7664          * But if something went wrong, make sure the multiplier is at least 1.
7665          */
7666         if (x_len_longer > x_len_shorter) {
7667             PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
7668         }
7669         else {
7670             PL_collxfrm_mult = 1;
7671         }
7672
7673         /*     mx + b = len
7674          * so:      b = len - mx
7675          * but in case something has gone wrong, make sure it is non-negative
7676          * */
7677         base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
7678         if (base < 0) {
7679             base = 0;
7680         }
7681
7682         /* Add 1 for the trailing NUL */
7683         PL_collxfrm_base = base + 1;
7684     }
7685
7686     DEBUG_L(PerlIO_printf(Perl_debug_log,
7687                           "?UTF-8 locale=%d; x_len_shorter=%zu, "
7688                           "x_len_longer=%zu,"
7689                           " collate multipler=%zu, collate base=%zu\n",
7690                           PL_in_utf8_COLLATE_locale,
7691                           x_len_shorter, x_len_longer,
7692                           PL_collxfrm_mult, PL_collxfrm_base));
7693 }
7694
7695 char *
7696 Perl_mem_collxfrm_(pTHX_ const char *input_string,
7697                          STRLEN len,    /* Length of 'input_string' */
7698                          STRLEN *xlen,  /* Set to length of returned string
7699                                            (not including the collation index
7700                                            prefix) */
7701                          bool utf8      /* Is the input in UTF-8? */
7702                    )
7703 {
7704     /* mem_collxfrm_() is like strxfrm() but with two important differences.
7705      * First, it handles embedded NULs. Second, it allocates a bit more memory
7706      * than needed for the transformed data itself.  The real transformed data
7707      * begins at offset COLLXFRM_HDR_LEN.  *xlen is set to the length of that,
7708      * and doesn't include the collation index size.
7709      *
7710      * It is the caller's responsibility to eventually free the memory returned
7711      * by this function.
7712      *
7713      * Please see sv_collxfrm() to see how this is used. */
7714
7715 #  define COLLXFRM_HDR_LEN    sizeof(PL_collation_ix)
7716
7717     char * s = (char *) input_string;
7718     STRLEN s_strlen = strlen(input_string);
7719     char *xbuf = NULL;
7720     STRLEN xAlloc;          /* xalloc is a reserved word in VC */
7721     STRLEN length_in_chars;
7722     bool first_time = TRUE; /* Cleared after first loop iteration */
7723
7724 #  ifdef USE_LOCALE_CTYPE
7725         const char * orig_CTYPE_locale = NULL;
7726 #  endif
7727
7728 #  if defined(USE_POSIX_2008_LOCALE) && defined HAS_STRXFRM_L
7729     locale_t constructed_locale = (locale_t) 0;
7730 #  endif
7731
7732     PERL_ARGS_ASSERT_MEM_COLLXFRM_;
7733
7734     /* Must be NUL-terminated */
7735     assert(*(input_string + len) == '\0');
7736
7737     if (PL_collxfrm_mult == 0) {     /* unknown or bad */
7738         if (PL_collxfrm_base != 0) { /* bad collation => skip */
7739             DEBUG_L(PerlIO_printf(Perl_debug_log,
7740                           "mem_collxfrm_: locale's collation is defective\n"));
7741             goto bad;
7742         }
7743
7744         /* (mult, base) == (0,0) means we need to calculate mult and base
7745          * before proceeding */
7746         S_compute_collxfrm_coefficients(aTHX);
7747     }
7748
7749     /* Replace any embedded NULs with the control that sorts before any others.
7750      * This will give as good as possible results on strings that don't
7751      * otherwise contain that character, but otherwise there may be
7752      * less-than-perfect results with that character and NUL.  This is
7753      * unavoidable unless we replace strxfrm with our own implementation. */
7754     if (UNLIKELY(s_strlen < len)) {   /* Only execute if there is an embedded
7755                                          NUL */
7756         char * e = s + len;
7757         char * sans_nuls;
7758         STRLEN sans_nuls_len;
7759         int try_non_controls;
7760         char this_replacement_char[] = "?\0";   /* Room for a two-byte string,
7761                                                    making sure 2nd byte is NUL.
7762                                                  */
7763         STRLEN this_replacement_len;
7764
7765         /* If we don't know what non-NUL control character sorts lowest for
7766          * this locale, find it */
7767         if (PL_strxfrm_NUL_replacement == '\0') {
7768             int j;
7769             char * cur_min_x = NULL;    /* The min_char's xfrm, (except it also
7770                                            includes the collation index
7771                                            prefixed. */
7772
7773             DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
7774
7775             /* Unlikely, but it may be that no control will work to replace
7776              * NUL, in which case we instead look for any character.  Controls
7777              * are preferred because collation order is, in general, context
7778              * sensitive, with adjoining characters affecting the order, and
7779              * controls are less likely to have such interactions, allowing the
7780              * NUL-replacement to stand on its own.  (Another way to look at it
7781              * is to imagine what would happen if the NUL were replaced by a
7782              * combining character; it wouldn't work out all that well.) */
7783             for (try_non_controls = 0;
7784                  try_non_controls < 2;
7785                  try_non_controls++)
7786             {
7787
7788 #  ifdef USE_LOCALE_CTYPE
7789
7790                 /* In this case we use isCNTRL_LC() below, which relies on
7791                  * LC_CTYPE, so that must be switched to correspond with the
7792                  * LC_COLLATE locale */
7793                 if (! try_non_controls && ! PL_in_utf8_COLLATE_locale) {
7794                     orig_CTYPE_locale = toggle_locale_c(LC_CTYPE,
7795                                                         PL_collation_name);
7796                 }
7797 #  endif
7798                 /* Look through all legal code points (NUL isn't) */
7799                 for (j = 1; j < 256; j++) {
7800                     char * x;       /* j's xfrm plus collation index */
7801                     STRLEN x_len;   /* length of 'x' */
7802                     STRLEN trial_len = 1;
7803                     char cur_source[] = { '\0', '\0' };
7804
7805                     /* Skip non-controls the first time through the loop.  The
7806                      * controls in a UTF-8 locale are the L1 ones */
7807                     if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
7808                                                ? ! isCNTRL_L1(j)
7809                                                : ! isCNTRL_LC(j))
7810                     {
7811                         continue;
7812                     }
7813
7814                     /* Create a 1-char string of the current code point */
7815                     cur_source[0] = (char) j;
7816
7817                     /* Then transform it */
7818                     x = mem_collxfrm_(cur_source, trial_len, &x_len,
7819                                       0 /* The string is not in UTF-8 */);
7820
7821                     /* Ignore any character that didn't successfully transform.
7822                      * */
7823                     if (! x) {
7824                         continue;
7825                     }
7826
7827                     /* If this character's transformation is lower than
7828                      * the current lowest, this one becomes the lowest */
7829                     if (   cur_min_x == NULL
7830                         || strLT(x         + COLLXFRM_HDR_LEN,
7831                                  cur_min_x + COLLXFRM_HDR_LEN))
7832                     {
7833                         PL_strxfrm_NUL_replacement = j;
7834                         Safefree(cur_min_x);
7835                         cur_min_x = x;
7836                     }
7837                     else {
7838                         Safefree(x);
7839                     }
7840                 } /* end of loop through all 255 characters */
7841
7842 #  ifdef USE_LOCALE_CTYPE
7843                 restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
7844 #  endif
7845
7846                 /* Stop looking if found */
7847                 if (cur_min_x) {
7848                     break;
7849                 }
7850
7851                 /* Unlikely, but possible, if there aren't any controls that
7852                  * work in the locale, repeat the loop, looking for any
7853                  * character that works */
7854                 DEBUG_L(PerlIO_printf(Perl_debug_log,
7855                 "mem_collxfrm_: No control worked.  Trying non-controls\n"));
7856             } /* End of loop to try first the controls, then any char */
7857
7858             if (! cur_min_x) {
7859                 DEBUG_L(PerlIO_printf(Perl_debug_log,
7860                     "mem_collxfrm_: Couldn't find any character to replace"
7861                     " embedded NULs in locale %s with", PL_collation_name));
7862                 goto bad;
7863             }
7864
7865             DEBUG_L(PerlIO_printf(Perl_debug_log,
7866                     "mem_collxfrm_: Replacing embedded NULs in locale %s with "
7867                     "0x%02X\n", PL_collation_name, PL_strxfrm_NUL_replacement));
7868
7869             Safefree(cur_min_x);
7870         } /* End of determining the character that is to replace NULs */
7871
7872         /* If the replacement is variant under UTF-8, it must match the
7873          * UTF8-ness of the original */
7874         if ( ! UVCHR_IS_INVARIANT(PL_strxfrm_NUL_replacement) && utf8) {
7875             this_replacement_char[0] =
7876                                 UTF8_EIGHT_BIT_HI(PL_strxfrm_NUL_replacement);
7877             this_replacement_char[1] =
7878                                 UTF8_EIGHT_BIT_LO(PL_strxfrm_NUL_replacement);
7879             this_replacement_len = 2;
7880         }
7881         else {
7882             this_replacement_char[0] = PL_strxfrm_NUL_replacement;
7883             /* this_replacement_char[1] = '\0' was done at initialization */
7884             this_replacement_len = 1;
7885         }
7886
7887         /* The worst case length for the replaced string would be if every
7888          * character in it is NUL.  Multiply that by the length of each
7889          * replacement, and allow for a trailing NUL */
7890         sans_nuls_len = (len * this_replacement_len) + 1;
7891         Newx(sans_nuls, sans_nuls_len, char);
7892         *sans_nuls = '\0';
7893
7894         /* Replace each NUL with the lowest collating control.  Loop until have
7895          * exhausted all the NULs */
7896         while (s + s_strlen < e) {
7897             my_strlcat(sans_nuls, s, sans_nuls_len);
7898
7899             /* Do the actual replacement */
7900             my_strlcat(sans_nuls, this_replacement_char, sans_nuls_len);
7901
7902             /* Move past the input NUL */
7903             s += s_strlen + 1;
7904             s_strlen = strlen(s);
7905         }
7906
7907         /* And add anything that trails the final NUL */
7908         my_strlcat(sans_nuls, s, sans_nuls_len);
7909
7910         /* Switch so below we transform this modified string */
7911         s = sans_nuls;
7912         len = strlen(s);
7913     } /* End of replacing NULs */
7914
7915     /* Make sure the UTF8ness of the string and locale match */
7916     if (utf8 != PL_in_utf8_COLLATE_locale) {
7917         /* XXX convert above Unicode to 10FFFF? */
7918         const char * const t = s;   /* Temporary so we can later find where the
7919                                        input was */
7920
7921         /* Here they don't match.  Change the string's to be what the locale is
7922          * expecting */
7923
7924         if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
7925             s = (char *) bytes_to_utf8((const U8 *) s, &len);
7926             utf8 = TRUE;
7927         }
7928         else {   /* locale is not UTF-8; but input is; downgrade the input */
7929
7930             s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
7931
7932             /* If the downgrade was successful we are done, but if the input
7933              * contains things that require UTF-8 to represent, have to do
7934              * damage control ... */
7935             if (UNLIKELY(utf8)) {
7936
7937                 /* What we do is construct a non-UTF-8 string with
7938                  *  1) the characters representable by a single byte converted
7939                  *     to be so (if necessary);
7940                  *  2) and the rest converted to collate the same as the
7941                  *     highest collating representable character.  That makes
7942                  *     them collate at the end.  This is similar to how we
7943                  *     handle embedded NULs, but we use the highest collating
7944                  *     code point instead of the smallest.  Like the NUL case,
7945                  *     this isn't perfect, but is the best we can reasonably
7946                  *     do.  Every above-255 code point will sort the same as
7947                  *     the highest-sorting 0-255 code point.  If that code
7948                  *     point can combine in a sequence with some other code
7949                  *     points for weight calculations, us changing something to
7950                  *     be it can adversely affect the results.  But in most
7951                  *     cases, it should work reasonably.  And note that this is
7952                  *     really an illegal situation: using code points above 255
7953                  *     on a locale where only 0-255 are valid.  If two strings
7954                  *     sort entirely equal, then the sort order for the
7955                  *     above-255 code points will be in code point order. */
7956
7957                 utf8 = FALSE;
7958
7959                 /* If we haven't calculated the code point with the maximum
7960                  * collating order for this locale, do so now */
7961                 if (! PL_strxfrm_max_cp) {
7962                     int j;
7963
7964                     /* The current transformed string that collates the
7965                      * highest (except it also includes the prefixed collation
7966                      * index. */
7967                     char * cur_max_x = NULL;
7968
7969                     /* Look through all legal code points (NUL isn't) */
7970                     for (j = 1; j < 256; j++) {
7971                         char * x;
7972                         STRLEN x_len;
7973                         char cur_source[] = { '\0', '\0' };
7974
7975                         /* Create a 1-char string of the current code point */
7976                         cur_source[0] = (char) j;
7977
7978                         /* Then transform it */
7979                         x = mem_collxfrm_(cur_source, 1, &x_len, FALSE);
7980
7981                         /* If something went wrong (which it shouldn't), just
7982                          * ignore this code point */
7983                         if (! x) {
7984                             continue;
7985                         }
7986
7987                         /* If this character's transformation is higher than
7988                          * the current highest, this one becomes the highest */
7989                         if (   cur_max_x == NULL
7990                             || strGT(x         + COLLXFRM_HDR_LEN,
7991                                      cur_max_x + COLLXFRM_HDR_LEN))
7992                         {
7993                             PL_strxfrm_max_cp = j;
7994                             Safefree(cur_max_x);
7995                             cur_max_x = x;
7996                         }
7997                         else {
7998                             Safefree(x);
7999                         }
8000                     }
8001
8002                     if (! cur_max_x) {
8003                         DEBUG_L(PerlIO_printf(Perl_debug_log,
8004                             "mem_collxfrm_: Couldn't find any character to"
8005                             " replace above-Latin1 chars in locale %s with",
8006                             PL_collation_name));
8007                         goto bad;
8008                     }
8009
8010                     DEBUG_L(PerlIO_printf(Perl_debug_log,
8011                             "mem_collxfrm_: highest 1-byte collating character"
8012                             " in locale %s is 0x%02X\n",
8013                             PL_collation_name,
8014                             PL_strxfrm_max_cp));
8015
8016                     Safefree(cur_max_x);
8017                 }
8018
8019                 /* Here we know which legal code point collates the highest.
8020                  * We are ready to construct the non-UTF-8 string.  The length
8021                  * will be at least 1 byte smaller than the input string
8022                  * (because we changed at least one 2-byte character into a
8023                  * single byte), but that is eaten up by the trailing NUL */
8024                 Newx(s, len, char);
8025
8026                 {
8027                     STRLEN i;
8028                     STRLEN d= 0;
8029                     char * e = (char *) t + len;
8030
8031                     for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
8032                         U8 cur_char = t[i];
8033                         if (UTF8_IS_INVARIANT(cur_char)) {
8034                             s[d++] = cur_char;
8035                         }
8036                         else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(t + i, e)) {
8037                             s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
8038                         }
8039                         else {  /* Replace illegal cp with highest collating
8040                                    one */
8041                             s[d++] = PL_strxfrm_max_cp;
8042                         }
8043                     }
8044                     s[d++] = '\0';
8045                     Renew(s, d, char);   /* Free up unused space */
8046                 }
8047             }
8048         }
8049
8050         /* Here, we have constructed a modified version of the input.  It could
8051          * be that we already had a modified copy before we did this version.
8052          * If so, that copy is no longer needed */
8053         if (t != input_string) {
8054             Safefree(t);
8055         }
8056     }
8057
8058     length_in_chars = (utf8)
8059                       ? utf8_length((U8 *) s, (U8 *) s + len)
8060                       : len;
8061
8062     /* The first element in the output is the collation id, used by
8063      * sv_collxfrm(); then comes the space for the transformed string.  The
8064      * equation should give us a good estimate as to how much is needed */
8065     xAlloc = COLLXFRM_HDR_LEN
8066            + PL_collxfrm_base
8067            + (PL_collxfrm_mult * length_in_chars);
8068     Newx(xbuf, xAlloc, char);
8069     if (UNLIKELY(! xbuf)) {
8070         DEBUG_L(PerlIO_printf(Perl_debug_log,
8071                       "mem_collxfrm_: Couldn't malloc %zu bytes\n", xAlloc));
8072         goto bad;
8073     }
8074
8075     /* Store the collation id */
8076     *(PERL_UINTMAX_T *)xbuf = PL_collation_ix;
8077
8078 #  if defined(USE_POSIX_2008_LOCALE) && defined HAS_STRXFRM_L
8079 #    ifdef USE_LOCALE_CTYPE
8080
8081     constructed_locale = newlocale(LC_CTYPE_MASK, PL_collation_name,
8082                                    duplocale(use_curlocale_scratch()));
8083 #    else
8084
8085     constructed_locale = duplocale(use_curlocale_scratch());
8086
8087 #    endif
8088 #    define my_strxfrm(dest, src, n)  strxfrm_l(dest, src, n,           \
8089                                                 constructed_locale)
8090 #    define CLEANUP_STRXFRM                                             \
8091         STMT_START {                                                    \
8092             if (constructed_locale != (locale_t) 0)                     \
8093                 freelocale(constructed_locale);                         \
8094         } STMT_END
8095 #  else
8096 #    define my_strxfrm(dest, src, n)  strxfrm(dest, src, n)
8097 #    ifdef USE_LOCALE_CTYPE
8098
8099     orig_CTYPE_locale = toggle_locale_c(LC_CTYPE, PL_collation_name);
8100
8101 #      define CLEANUP_STRXFRM                                           \
8102                 restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale)
8103 #    else
8104 #      define CLEANUP_STRXFRM  NOOP
8105 #    endif
8106 #  endif
8107
8108     /* Then the transformation of the input.  We loop until successful, or we
8109      * give up */
8110     for (;;) {
8111
8112         errno = 0;
8113         *xlen = my_strxfrm(xbuf + COLLXFRM_HDR_LEN,
8114                            s,
8115                            xAlloc - COLLXFRM_HDR_LEN);
8116
8117
8118         /* If the transformed string occupies less space than we told strxfrm()
8119          * was available, it means it transformed the whole string. */
8120         if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
8121
8122             /* But there still could have been a problem */
8123             if (errno != 0) {
8124                 DEBUG_L(PerlIO_printf(Perl_debug_log,
8125                        "strxfrm failed for LC_COLLATE=%s; errno=%d, input=%s\n",
8126                        PL_collation_name, errno,
8127                        _byte_dump_string((U8 *) s, len, 0)));
8128                 goto bad;
8129             }
8130
8131             /* Here, the transformation was successful.  Some systems include a
8132              * trailing NUL in the returned length.  Ignore it, using a loop in
8133              * case multiple trailing NULs are returned. */
8134             while (   (*xlen) > 0
8135                    && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
8136             {
8137                 (*xlen)--;
8138             }
8139
8140             /* If the first try didn't get it, it means our prediction was low.
8141              * Modify the coefficients so that we predict a larger value in any
8142              * future transformations */
8143             if (! first_time) {
8144                 STRLEN needed = *xlen + 1;   /* +1 For trailing NUL */
8145                 STRLEN computed_guess = PL_collxfrm_base
8146                                       + (PL_collxfrm_mult * length_in_chars);
8147
8148                 /* On zero-length input, just keep current slope instead of
8149                  * dividing by 0 */
8150                 const STRLEN new_m = (length_in_chars != 0)
8151                                      ? needed / length_in_chars
8152                                      : PL_collxfrm_mult;
8153
8154                 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8155                     "initial size of %zu bytes for a length "
8156                     "%zu string was insufficient, %zu needed\n",
8157                     computed_guess, length_in_chars, needed));
8158
8159                 /* If slope increased, use it, but discard this result for
8160                  * length 1 strings, as we can't be sure that it's a real slope
8161                  * change */
8162                 if (length_in_chars > 1 && new_m  > PL_collxfrm_mult) {
8163
8164 #  ifdef DEBUGGING
8165
8166                     STRLEN old_m = PL_collxfrm_mult;
8167                     STRLEN old_b = PL_collxfrm_base;
8168
8169 #  endif
8170
8171                     PL_collxfrm_mult = new_m;
8172                     PL_collxfrm_base = 1;   /* +1 For trailing NUL */
8173                     computed_guess = PL_collxfrm_base
8174                                     + (PL_collxfrm_mult * length_in_chars);
8175                     if (computed_guess < needed) {
8176                         PL_collxfrm_base += needed - computed_guess;
8177                     }
8178
8179                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8180                                     "slope is now %zu; was %zu, base "
8181                         "is now %zu; was %zu\n",
8182                         PL_collxfrm_mult, old_m,
8183                         PL_collxfrm_base, old_b));
8184                 }
8185                 else {  /* Slope didn't change, but 'b' did */
8186                     const STRLEN new_b = needed
8187                                         - computed_guess
8188                                         + PL_collxfrm_base;
8189                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8190                         "base is now %zu; was %zu\n", new_b, PL_collxfrm_base));
8191                     PL_collxfrm_base = new_b;
8192                 }
8193             }
8194
8195             break;
8196         }
8197
8198         if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
8199             DEBUG_L(PerlIO_printf(Perl_debug_log,
8200                   "mem_collxfrm_: Needed %zu bytes, max permissible is %u\n",
8201                   *xlen, PERL_INT_MAX));
8202             goto bad;
8203         }
8204
8205         /* A well-behaved strxfrm() returns exactly how much space it needs
8206          * (usually not including the trailing NUL) when it fails due to not
8207          * enough space being provided.  Assume that this is the case unless
8208          * it's been proven otherwise */
8209         if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
8210             xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
8211         }
8212         else { /* Here, either:
8213                 *  1)  The strxfrm() has previously shown bad behavior; or
8214                 *  2)  It isn't the first time through the loop, which means
8215                 *      that the strxfrm() is now showing bad behavior, because
8216                 *      we gave it what it said was needed in the previous
8217                 *      iteration, and it came back saying it needed still more.
8218                 *      (Many versions of cygwin fit this.  When the buffer size
8219                 *      isn't sufficient, they return the input size instead of
8220                 *      how much is needed.)
8221                 * Increase the buffer size by a fixed percentage and try again.
8222                 * */
8223             xAlloc += (xAlloc / 4) + 1;
8224             PL_strxfrm_is_behaved = FALSE;
8225
8226             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8227                      "mem_collxfrm_ required more space than previously"
8228                      " calculated for locale %s, trying again with new"
8229                      " guess=%zu+%zu\n",
8230                 PL_collation_name,  COLLXFRM_HDR_LEN,
8231                      xAlloc - COLLXFRM_HDR_LEN));
8232         }
8233
8234         Renew(xbuf, xAlloc, char);
8235         if (UNLIKELY(! xbuf)) {
8236             DEBUG_L(PerlIO_printf(Perl_debug_log,
8237                       "mem_collxfrm_: Couldn't realloc %zu bytes\n", xAlloc));
8238             goto bad;
8239         }
8240
8241         first_time = FALSE;
8242     }
8243
8244     CLEANUP_STRXFRM;
8245
8246     DEBUG_L(print_collxfrm_input_and_return(s, s + len, xbuf, *xlen, utf8));
8247
8248     /* Free up unneeded space; retain enough for trailing NUL */
8249     Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
8250
8251     if (s != input_string) {
8252         Safefree(s);
8253     }
8254
8255     return xbuf;
8256
8257   bad:
8258
8259     CLEANUP_STRXFRM;
8260     DEBUG_L(print_collxfrm_input_and_return(s, s + len, NULL, 0, utf8));
8261
8262     Safefree(xbuf);
8263     if (s != input_string) {
8264         Safefree(s);
8265     }
8266     *xlen = 0;
8267
8268     return NULL;
8269 }
8270
8271 #  ifdef DEBUGGING
8272
8273 STATIC void
8274 S_print_collxfrm_input_and_return(pTHX_
8275                                   const char * s,
8276                                   const char * e,
8277                                   const char * xbuf,
8278                                   const STRLEN xlen,
8279                                   const bool is_utf8)
8280 {
8281
8282     PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
8283
8284     PerlIO_printf(Perl_debug_log,
8285                   "mem_collxfrm_[ix %" UVuf "] for locale '%s':\n"
8286                   "     input=%s\n    return=%s\n    return len=%zu\n",
8287                   (UV) PL_collation_ix, PL_collation_name,
8288                   get_displayable_string(s, e, is_utf8),
8289                   ((xbuf == NULL)
8290                    ? "(null)"
8291                    : ((xlen == 0)
8292                       ? "(empty)"
8293                       : _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
8294                                           xlen, 0))),
8295                   xlen);
8296 }
8297
8298 #  endif    /* DEBUGGING */
8299
8300 SV *
8301 Perl_strxfrm(pTHX_ SV * src)
8302 {
8303     PERL_ARGS_ASSERT_STRXFRM;
8304
8305     /* For use by POSIX::strxfrm().  If they differ, toggle LC_CTYPE to
8306      * LC_COLLATE to avoid potential mojibake.
8307      *
8308      * If we can't calculate a collation, 'src' is instead returned, so that
8309      * future comparisons will be by code point order */
8310
8311 #  ifdef USE_LOCALE_CTYPE
8312
8313     const char * orig_ctype = toggle_locale_c(LC_CTYPE,
8314                                               querylocale_c(LC_COLLATE));
8315 #  endif
8316
8317     SV * dst = src;
8318     STRLEN dstlen;
8319     STRLEN srclen;
8320     const char *p = SvPV_const(src, srclen);
8321     const U32 utf8_flag = SvUTF8(src);
8322     char *d = mem_collxfrm_(p, srclen, &dstlen, cBOOL(utf8_flag));
8323
8324     assert(utf8_flag == 0 || utf8_flag == SVf_UTF8);
8325
8326     if (d != NULL) {
8327         assert(dstlen > 0);
8328         dst =newSVpvn_flags(d + COLLXFRM_HDR_LEN,
8329                             dstlen, SVs_TEMP|utf8_flag);
8330         Safefree(d);
8331     }
8332
8333 #  ifdef USE_LOCALE_CTYPE
8334
8335     restore_toggled_locale_c(LC_CTYPE, orig_ctype);
8336
8337 #  endif
8338
8339     return dst;
8340 }
8341
8342 #endif /* USE_LOCALE_COLLATE */
8343 #ifdef USE_LOCALE
8344
8345 STATIC const char *
8346 S_toggle_locale_i(pTHX_ const locale_category_index cat_index,
8347                         const char * new_locale,
8348                         const line_t caller_line)
8349 {
8350     PERL_ARGS_ASSERT_TOGGLE_LOCALE_I;
8351     assert(cat_index <= LC_ALL_INDEX_);
8352
8353     /* Changes the locale for the category specified by 'index' to 'new_locale,
8354      * if they aren't already the same.
8355      *
8356      * Returns a copy of the name of the original locale for 'cat_index'
8357      * so can be switched back to with the companion function
8358      * restore_toggled_locale_i(),  (NULL if no restoral is necessary.) */
8359
8360     /* Find the original locale of the category we may need to change, so that
8361      * it can be restored to later */
8362     const char * locale_to_restore_to = querylocale_i(cat_index);
8363
8364     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8365              "(%" LINE_Tf "): toggle_locale_i: index=%d(%s), wanted=%s,"
8366              " actual=%s\n",
8367              caller_line, cat_index, category_names[cat_index],
8368              new_locale, locale_to_restore_to));
8369
8370     if (! locale_to_restore_to) {
8371         locale_panic_via_(Perl_form(aTHX_
8372                                     "Could not find current %s locale",
8373                                     category_names[cat_index]),
8374                          __FILE__, caller_line);
8375     }
8376
8377     /* If the locales are the same, there's nothing to do */
8378     if (strEQ(locale_to_restore_to, new_locale)) {
8379         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8380                                "(%" LINE_Tf "): %s locale unchanged as %s\n",
8381                                caller_line, category_names[cat_index],
8382                                new_locale));
8383
8384         return NULL;
8385     }
8386
8387     /* Finally, change the locale to the new one */
8388     void_setlocale_i_with_caller(cat_index, new_locale, __FILE__, caller_line);
8389
8390     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8391                            "(%" LINE_Tf "): %s locale switched to %s\n",
8392                            caller_line, category_names[cat_index], new_locale));
8393
8394     return locale_to_restore_to;
8395
8396 #  ifndef DEBUGGING
8397     PERL_UNUSED_ARG(caller_line);
8398 #  endif
8399
8400 }
8401
8402 STATIC void
8403 S_restore_toggled_locale_i(pTHX_ const locale_category_index cat_index,
8404                                  const char * restore_locale,
8405                                  const line_t caller_line)
8406 {
8407     /* Restores the locale for LC_category corresponding to cat_index to
8408      * 'restore_locale' (which is a copy that will be freed by this function),
8409      * or do nothing if the latter parameter is NULL */
8410
8411     PERL_ARGS_ASSERT_RESTORE_TOGGLED_LOCALE_I;
8412     assert(cat_index <= LC_ALL_INDEX_);
8413
8414     if (restore_locale == NULL) {
8415         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8416                                "(%" LINE_Tf "): No need to restore %s\n",
8417                                caller_line, category_names[cat_index]));
8418         return;
8419     }
8420
8421     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
8422                            "(%" LINE_Tf "): %s restoring locale to %s\n",
8423                            caller_line, category_names[cat_index],
8424                            restore_locale));
8425
8426     void_setlocale_i_with_caller(cat_index, restore_locale,
8427                                   __FILE__, caller_line);
8428
8429 #  ifndef DEBUGGING
8430     PERL_UNUSED_ARG(caller_line);
8431 #  endif
8432
8433 }
8434
8435 #  ifdef USE_LOCALE_CTYPE
8436
8437 STATIC bool
8438 S_is_codeset_name_UTF8(const char * name)
8439 {
8440     /* Return a boolean as to if the passed-in name indicates it is a UTF-8
8441      * code set.  Several variants are possible */
8442     const Size_t len = strlen(name);
8443
8444     PERL_ARGS_ASSERT_IS_CODESET_NAME_UTF8;
8445
8446 #    ifdef WIN32
8447
8448     /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
8449     if (memENDs(name, len, "65001")) {
8450         return TRUE;
8451     }
8452
8453 #    endif
8454                /* 'UTF8' or 'UTF-8' */
8455     return (    inRANGE(len, 4, 5)
8456             &&  name[len-1] == '8'
8457             && (   memBEGINs(name, len, "UTF")
8458                 || memBEGINs(name, len, "utf"))
8459             && (len == 4 || name[3] == '-'));
8460 }
8461
8462 #  endif
8463 #endif  /* USE_LOCALE */
8464
8465 bool
8466 Perl__is_in_locale_category(pTHX_ const bool compiling, const int category)
8467 {
8468     /* Internal function which returns if we are in the scope of a pragma that
8469      * enables the locale category 'category'.  'compiling' should indicate if
8470      * this is during the compilation phase (TRUE) or not (FALSE). */
8471
8472     const COP * const cop = (compiling) ? &PL_compiling : PL_curcop;
8473
8474     SV *these_categories = cop_hints_fetch_pvs(cop, "locale", 0);
8475     if (! these_categories || these_categories == &PL_sv_placeholder) {
8476         return FALSE;
8477     }
8478
8479     /* The pseudo-category 'not_characters' is -1, so just add 1 to each to get
8480      * a valid unsigned */
8481     assert(category >= -1);
8482     return cBOOL(SvUV(these_categories) & (1U << (category + 1)));
8483 }
8484
8485 /* my_strerror() returns a mortalized copy of the text of the error message
8486  * associated with 'errnum'.
8487  *
8488  * If not called from within the scope of 'use locale', it uses the text from
8489  * the C locale.  If Perl is compiled to not pay attention to LC_CTYPE nor
8490  * LC_MESSAGES, it uses whatever strerror() returns.  Otherwise the text is
8491  * derived from the locale, LC_MESSAGES if we have that; LC_CTYPE if not.
8492  *
8493  * It returns in *utf8ness the result's UTF-8ness
8494  *
8495  * The function just calls strerror(), but temporarily switches locales, if
8496  * needed.  Many platforms require LC_CTYPE and LC_MESSAGES to be in the same
8497  * CODESET in order for the return from strerror() to not contain '?' symbols,
8498  * or worse, mojibaked.  It's cheaper to just use the stricter criteria of
8499  * being in the same locale.  So the code below uses a common locale for both
8500  * categories.  Again, that is C if not within 'use locale' scope; or the
8501  * LC_MESSAGES locale if in scope and we have that category; and LC_CTYPE if we
8502  * don't have LC_MESSAGES; and whatever strerror returns if we don't have
8503  * either category.
8504  *
8505  * There are two sets of implementations.  The first below is if we have
8506  * strerror_l().  This is the simpler.  We just use the already-built C locale
8507  * object if not in locale scope, or build up a custom one otherwise.
8508  *
8509  * When strerror_l() is not available, we may have to swap locales temporarily
8510  * to bring the two categories into sync with each other, and possibly to the C
8511  * locale.
8512  *
8513  * Because the prepropessing directives to conditionally compile this function
8514  * would greatly obscure the logic of the various implementations, the whole
8515  * function is repeated for each configuration, with some common macros. */
8516
8517 /* Used to shorten the definitions of the following implementations of
8518  * my_strerror() */
8519 #define DEBUG_STRERROR_ENTER(errnum, in_locale)                             \
8520     DEBUG_Lv(PerlIO_printf(Perl_debug_log,                                  \
8521                            "my_strerror called with errnum %d;"             \
8522                            " Within locale scope=%d\n",                     \
8523                            errnum, in_locale))
8524
8525 #define DEBUG_STRERROR_RETURN(errstr, utf8ness)                             \
8526     DEBUG_Lv(PerlIO_printf(Perl_debug_log,                                  \
8527                            "Strerror returned; saving a copy: '%s';"        \
8528                            " utf8ness=%d\n",                                \
8529                            get_displayable_string(errstr,                   \
8530                                                   errstr + strlen(errstr),  \
8531                                                   *utf8ness),               \
8532                            (int) *utf8ness))
8533
8534 /* On platforms that have precisely one of these categories (Windows
8535  * qualifies), these yield the correct one */
8536 #if defined(USE_LOCALE_CTYPE)
8537 #  define WHICH_LC_INDEX LC_CTYPE_INDEX_
8538 #elif defined(USE_LOCALE_MESSAGES)
8539 #  define WHICH_LC_INDEX LC_MESSAGES_INDEX_
8540 #endif
8541
8542 /*===========================================================================*/
8543 /* First set of implementations, when have strerror_l() */
8544
8545 #if defined(USE_POSIX_2008_LOCALE) && defined(HAS_STRERROR_L)
8546
8547 #  if ! defined(USE_LOCALE_CTYPE) && ! defined(USE_LOCALE_MESSAGES)
8548
8549 /* Here, neither category is defined: use the C locale */
8550 const char *
8551 Perl_my_strerror(pTHX_ const int errnum, utf8ness_t * utf8ness)
8552 {
8553     PERL_ARGS_ASSERT_MY_STRERROR;
8554
8555     DEBUG_STRERROR_ENTER(errnum, 0);
8556
8557     const char *errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
8558     *utf8ness = UTF8NESS_IMMATERIAL;
8559
8560     DEBUG_STRERROR_RETURN(errstr, utf8ness);
8561
8562     SAVEFREEPV(errstr);
8563     return errstr;
8564 }
8565
8566 #  elif ! defined(USE_LOCALE_CTYPE) || ! defined(USE_LOCALE_MESSAGES)
8567
8568 /*--------------------------------------------------------------------------*/
8569
8570 /* Here one or the other of CTYPE or MESSAGES is defined, but not both.  If we
8571  * are not within 'use locale' scope of the only one defined, we use the C
8572  * locale; otherwise use the current locale object */
8573
8574 const char *
8575 Perl_my_strerror(pTHX_ const int errnum, utf8ness_t * utf8ness)
8576 {
8577     PERL_ARGS_ASSERT_MY_STRERROR;
8578
8579     DEBUG_STRERROR_ENTER(errnum, IN_LC(categories[WHICH_LC_INDEX]));
8580
8581     /* Use C if not within locale scope;  Otherwise, use current locale */
8582     const locale_t which_obj = (IN_LC(categories[WHICH_LC_INDEX]))
8583                                ? PL_C_locale_obj
8584                                : use_curlocale_scratch();
8585
8586     const char *errstr = savepv(strerror_l(errnum, which_obj));
8587     *utf8ness = get_locale_string_utf8ness_i(errstr, LOCALE_UTF8NESS_UNKNOWN,
8588                                              NULL, WHICH_LC_INDEX);
8589     DEBUG_STRERROR_RETURN(errstr, utf8ness);
8590
8591     SAVEFREEPV(errstr);
8592     return errstr;
8593 }
8594
8595 /*--------------------------------------------------------------------------*/
8596 #  else     /* Are using both categories.  Place them in the same CODESET,
8597              * either C or the LC_MESSAGES locale */
8598
8599 const char *
8600 Perl_my_strerror(pTHX_ const int errnum, utf8ness_t * utf8ness)
8601 {
8602     PERL_ARGS_ASSERT_MY_STRERROR;
8603
8604     DEBUG_STRERROR_ENTER(errnum, IN_LC(LC_MESSAGES));
8605
8606     const char *errstr;
8607     if (! IN_LC(LC_MESSAGES)) {    /* Use C if not within locale scope */
8608         errstr = savepv(strerror_l(errnum, PL_C_locale_obj));
8609         *utf8ness = UTF8NESS_IMMATERIAL;
8610     }
8611     else {  /* Otherwise, use the LC_MESSAGES locale, making sure LC_CTYPE
8612                matches */
8613         locale_t cur = duplocale(use_curlocale_scratch());
8614
8615         cur = newlocale(LC_CTYPE_MASK, querylocale_c(LC_MESSAGES), cur);
8616         errstr = savepv(strerror_l(errnum, cur));
8617         *utf8ness = get_locale_string_utf8ness_i(errstr,
8618                                                  LOCALE_UTF8NESS_UNKNOWN,
8619                                                  NULL, LC_MESSAGES_INDEX_);
8620         freelocale(cur);
8621     }
8622
8623     DEBUG_STRERROR_RETURN(errstr, utf8ness);
8624
8625     SAVEFREEPV(errstr);
8626     return errstr;
8627 }
8628 #  endif    /* Above is using strerror_l */
8629 /*===========================================================================*/
8630 #else       /* Below is not using strerror_l */
8631 #  if ! defined(USE_LOCALE_CTYPE) && ! defined(USE_LOCALE_MESSAGES)
8632
8633 /* If not using using either of the categories, return plain, unadorned
8634  * strerror */
8635
8636 const char *
8637 Perl_my_strerror(pTHX_ const int errnum, utf8ness_t * utf8ness)
8638 {
8639     PERL_ARGS_ASSERT_MY_STRERROR;
8640
8641     DEBUG_STRERROR_ENTER(errnum, 0);
8642
8643     const char *errstr = savepv(Strerror(errnum));
8644     *utf8ness = UTF8NESS_IMMATERIAL;
8645
8646     DEBUG_STRERROR_RETURN(errstr, utf8ness);
8647
8648     SAVEFREEPV(errstr);
8649     return errstr;
8650 }
8651
8652 /*--------------------------------------------------------------------------*/
8653 #  elif ! defined(USE_LOCALE_CTYPE) || ! defined(USE_LOCALE_MESSAGES)
8654
8655 /* Here one or the other of CTYPE or MESSAGES is defined, but not both.  If we
8656  * are not within 'use locale' scope of the only one defined, we use the C
8657  * locale; otherwise use the current locale */
8658
8659 const char *
8660 Perl_my_strerror(pTHX_ const int errnum, utf8ness_t * utf8ness)
8661 {
8662     PERL_ARGS_ASSERT_MY_STRERROR;
8663
8664     DEBUG_STRERROR_ENTER(errnum, IN_LC(categories[WHICH_LC_INDEX]));
8665
8666     const char *errstr;
8667     if (IN_LC(categories[WHICH_LC_INDEX])) {
8668         errstr = savepv(Strerror(errnum));
8669         *utf8ness = get_locale_string_utf8ness_i(errstr,
8670                                                  LOCALE_UTF8NESS_UNKNOWN,
8671                                                  NULL, WHICH_LC_INDEX);
8672     }
8673     else {
8674
8675         LOCALE_LOCK;
8676
8677         const char * orig_locale = toggle_locale_i(WHICH_LC_INDEX, "C");
8678
8679         errstr = savepv(Strerror(errnum));
8680
8681         restore_toggled_locale_i(WHICH_LC_INDEX, orig_locale);
8682
8683         LOCALE_UNLOCK;
8684
8685         *utf8ness = UTF8NESS_IMMATERIAL;
8686     }
8687
8688     DEBUG_STRERROR_RETURN(errstr, utf8ness);
8689
8690     SAVEFREEPV(errstr);
8691     return errstr;
8692 }
8693
8694 /*--------------------------------------------------------------------------*/
8695 #  else
8696
8697 /* Below, have both LC_CTYPE and LC_MESSAGES.  Place them in the same CODESET,
8698  * either C or the LC_MESSAGES locale */
8699
8700 const char *
8701 Perl_my_strerror(pTHX_ const int errnum, utf8ness_t * utf8ness)
8702 {
8703     PERL_ARGS_ASSERT_MY_STRERROR;
8704
8705     DEBUG_STRERROR_ENTER(errnum, IN_LC(LC_MESSAGES));
8706
8707     const char * desired_locale = (IN_LC(LC_MESSAGES))
8708                                   ? querylocale_c(LC_MESSAGES)
8709                                   : "C";
8710     /* XXX Can fail on z/OS */
8711
8712     LOCALE_LOCK;
8713
8714     const char* orig_CTYPE_locale    = toggle_locale_c(LC_CTYPE,
8715                                                        desired_locale);
8716     const char* orig_MESSAGES_locale = toggle_locale_c(LC_MESSAGES,
8717                                                        desired_locale);
8718     const char *errstr = savepv(Strerror(errnum));
8719
8720     restore_toggled_locale_c(LC_MESSAGES, orig_MESSAGES_locale);
8721     restore_toggled_locale_c(LC_CTYPE, orig_CTYPE_locale);
8722
8723     LOCALE_UNLOCK;
8724
8725     *utf8ness = get_locale_string_utf8ness_i(errstr, LOCALE_UTF8NESS_UNKNOWN,
8726                                              NULL, LC_MESSAGES_INDEX_);
8727     DEBUG_STRERROR_RETURN(errstr, utf8ness);
8728
8729     SAVEFREEPV(errstr);
8730     return errstr;
8731 }
8732
8733 /*--------------------------------------------------------------------------*/
8734 #  endif /* end of not using strerror_l() */
8735 #endif   /* end of all the my_strerror() implementations */
8736
8737 /*
8738
8739 =for apidoc switch_to_global_locale
8740
8741 This function copies the locale state of the calling thread into the program's
8742 global locale, and converts the thread to use that global locale.
8743
8744 It is intended so that Perl can safely be used with C libraries that access the
8745 global locale and which can't be converted to not access it.  Effectively, this
8746 means libraries that call C<L<setlocale(3)>> on non-Windows systems.  (For
8747 portability, it is a good idea to use it on Windows as well.)
8748
8749 A downside of using it is that it disables the services that Perl provides to
8750 hide locale gotchas from your code.  The service you most likely will miss
8751 regards the radix character (decimal point) in floating point numbers.  Code
8752 executed after this function is called can no longer just assume that this
8753 character is correct for the current circumstances.
8754
8755 To return to Perl control, and restart the gotcha prevention services, call
8756 C<L</sync_locale>>.  Behavior is undefined for any pure Perl code that executes
8757 while the switch is in effect.
8758
8759 The global locale and the per-thread locales are independent.  As long as just
8760 one thread converts to the global locale, everything works smoothly.  But if
8761 more than one does, they can easily interfere with each other, and races are
8762 likely.  On Windows systems prior to Visual Studio 15 (at which point Microsoft
8763 fixed a bug), races can occur (even if only one thread has been converted to
8764 the global locale), but only if you use the following operations:
8765
8766 =over
8767
8768 =item L<POSIX::localeconv|POSIX/localeconv>
8769
8770 =item L<I18N::Langinfo>, items C<CRNCYSTR> and C<THOUSEP>
8771
8772 =item L<perlapi/Perl_langinfo>, items C<CRNCYSTR> and C<THOUSEP>
8773
8774 =back
8775
8776 The first item is not fixable (except by upgrading to a later Visual Studio
8777 release), but it would be possible to work around the latter two items by
8778 having Perl change its algorithm for calculating these to use Windows API
8779 functions (likely C<GetNumberFormat> and C<GetCurrencyFormat>); patches
8780 welcome.
8781
8782 XS code should never call plain C<setlocale>, but should instead be converted
8783 to either call L<C<Perl_setlocale>|perlapi/Perl_setlocale> (which is a drop-in
8784 for the system C<setlocale>) or use the methods given in L<perlcall> to call
8785 L<C<POSIX::setlocale>|POSIX/setlocale>.  Either one will transparently properly
8786 handle all cases of single- vs multi-thread, POSIX 2008-supported or not.
8787
8788 =cut
8789 */
8790
8791 #if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE)
8792 #  define CHANGE_SYSTEM_LOCALE_TO_GLOBAL                                \
8793     STMT_START {                                                        \
8794         if (_configthreadlocale(_DISABLE_PER_THREAD_LOCALE) == -1) {    \
8795             locale_panic_("_configthreadlocale returned an error");     \
8796         }                                                               \
8797     } STMT_END
8798 #elif defined(USE_POSIX_2008_LOCALE)
8799 #  define CHANGE_SYSTEM_LOCALE_TO_GLOBAL                                \
8800     STMT_START {                                                        \
8801         locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);              \
8802         if (! old_locale) {                                             \
8803             locale_panic_("Could not change to global locale");         \
8804         }                                                               \
8805                                                                         \
8806         /* Free the per-thread memory */                                \
8807         if (   old_locale != LC_GLOBAL_LOCALE                           \
8808             && old_locale != PL_C_locale_obj)                           \
8809         {                                                               \
8810             freelocale(old_locale);                                     \
8811         }                                                               \
8812     } STMT_END
8813 #else
8814 #  define CHANGE_SYSTEM_LOCALE_TO_GLOBAL
8815 #endif
8816
8817 void
8818 Perl_switch_to_global_locale(pTHX)
8819 {
8820
8821 #ifdef USE_LOCALE
8822
8823     DEBUG_L(PerlIO_printf(Perl_debug_log, "Entering switch_to_global; %s\n",
8824                                           get_LC_ALL_display()));
8825
8826    /* In these cases, we use the system state to determine if we are in the
8827     * global locale or not. */
8828 #  ifdef USE_POSIX_2008_LOCALE
8829
8830     const bool perl_controls = (LC_GLOBAL_LOCALE != uselocale((locale_t) 0));
8831
8832 #  elif defined(USE_THREAD_SAFE_LOCALE) && defined(WIN32)
8833
8834     int config_return = _configthreadlocale(0);
8835     if (config_return == -1) {
8836         locale_panic_("_configthreadlocale returned an error");
8837     }
8838     const bool perl_controls = (config_return == _ENABLE_PER_THREAD_LOCALE);
8839
8840 #  else
8841
8842     const bool perl_controls = false;
8843
8844 #  endif
8845
8846     /* No-op if already in global */
8847     if (! perl_controls) {
8848         return;
8849     }
8850
8851 #  ifdef LC_ALL
8852
8853     const char * thread_locale = calculate_LC_ALL_string(NULL,
8854                                                          EXTERNAL_FORMAT_FOR_SET,
8855                                                          WANT_TEMP_PV,
8856                                                          __LINE__);
8857     CHANGE_SYSTEM_LOCALE_TO_GLOBAL;
8858     posix_setlocale(LC_ALL, thread_locale);
8859
8860 #  else   /* Must be USE_POSIX_2008_LOCALE) */
8861
8862     const char * cur_thread_locales[LC_ALL_INDEX_];
8863
8864     /* Save each category's current per-thread state */
8865     for_all_individual_category_indexes(i) {
8866         cur_thread_locales[i] = querylocale_i(i);
8867     }
8868
8869     CHANGE_SYSTEM_LOCALE_TO_GLOBAL;
8870
8871     /* Set the global to what was our per-thread state */
8872     POSIX_SETLOCALE_LOCK;
8873     for_all_individual_category_indexes(i) {
8874         posix_setlocale(categories[i], cur_thread_locales[i]);
8875     }
8876     POSIX_SETLOCALE_UNLOCK;
8877
8878 #  endif
8879 #  ifdef USE_LOCALE_NUMERIC
8880
8881     /* Switch to the underlying C numeric locale; the application is on its
8882      * own. */
8883     POSIX_SETLOCALE_LOCK;
8884     posix_setlocale(LC_NUMERIC, PL_numeric_name);
8885     POSIX_SETLOCALE_UNLOCK;
8886
8887 #  endif
8888 #endif
8889
8890 }
8891
8892 /*
8893
8894 =for apidoc sync_locale
8895
8896 This function copies the state of the program global locale into the calling
8897 thread, and converts that thread to using per-thread locales, if it wasn't
8898 already, and the platform supports them.  The LC_NUMERIC locale is toggled into
8899 the standard state (using the C locale's conventions), if not within the
8900 lexical scope of S<C<use locale>>.
8901
8902 Perl will now consider itself to have control of the locale.
8903
8904 Since unthreaded perls have only a global locale, this function is a no-op
8905 without threads.
8906
8907 This function is intended for use with C libraries that do locale manipulation.
8908 It allows Perl to accommodate the use of them.  Call this function before
8909 transferring back to Perl space so that it knows what state the C code has left
8910 things in.
8911
8912 XS code should not manipulate the locale on its own.  Instead,
8913 L<C<Perl_setlocale>|perlapi/Perl_setlocale> can be used at any time to query or
8914 change the locale (though changing the locale is antisocial and dangerous on
8915 multi-threaded systems that don't have multi-thread safe locale operations.
8916 (See L<perllocale/Multi-threaded operation>).
8917
8918 Using the libc L<C<setlocale(3)>> function should be avoided.  Nevertheless,
8919 certain non-Perl libraries called from XS, do call it, and their behavior may
8920 not be able to be changed.  This function, along with
8921 C<L</switch_to_global_locale>>, can be used to get seamless behavior in these
8922 circumstances, as long as only one thread is involved.
8923
8924 If the library has an option to turn off its locale manipulation, doing that is
8925 preferable to using this mechanism.  C<Gtk> is such a library.
8926
8927 The return value is a boolean: TRUE if the global locale at the time of call
8928 was in effect for the caller; and FALSE if a per-thread locale was in effect.
8929
8930 =cut
8931 */
8932
8933 bool
8934 Perl_sync_locale(pTHX)
8935 {
8936
8937 #ifndef USE_LOCALE
8938
8939     return TRUE;
8940
8941 #else
8942
8943     bool was_in_global = TRUE;
8944
8945 #  ifdef USE_THREAD_SAFE_LOCALE
8946 #    if defined(WIN32)
8947
8948     int config_return = _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
8949     if (config_return == -1) {
8950         locale_panic_("_configthreadlocale returned an error");
8951     }
8952     was_in_global = (config_return == _DISABLE_PER_THREAD_LOCALE);
8953
8954 #    elif defined(USE_POSIX_2008_LOCALE)
8955
8956     was_in_global = (LC_GLOBAL_LOCALE == uselocale(LC_GLOBAL_LOCALE));
8957
8958 #    else
8959 #      error Unexpected Configuration
8960 #    endif
8961 #  endif    /* USE_THREAD_SAFE_LOCALE */
8962
8963     /* Here, we are in the global locale.  Get and save the values for each
8964      * category, and convert the current thread to use them */
8965
8966 #  ifdef LC_ALL
8967
8968     STDIZED_SETLOCALE_LOCK;
8969     const char * lc_all_string = savepv(stdized_setlocale(LC_ALL, NULL));
8970     STDIZED_SETLOCALE_UNLOCK;
8971
8972     give_perl_locale_control(lc_all_string, __LINE__);
8973     Safefree(lc_all_string);
8974
8975 #  else
8976
8977     const char * current_globals[LC_ALL_INDEX_];
8978     for_all_individual_category_indexes(i) {
8979         STDIZED_SETLOCALE_LOCK;
8980         current_globals[i] = savepv(stdized_setlocale(categories[i], NULL));
8981         STDIZED_SETLOCALE_UNLOCK;
8982     }
8983
8984     give_perl_locale_control((const char **) &current_globals, __LINE__);
8985
8986     for_all_individual_category_indexes(i) {
8987         Safefree(current_globals[i]);
8988     }
8989
8990 #  endif
8991
8992     return was_in_global;
8993
8994 #endif
8995
8996 }
8997
8998 #if defined(DEBUGGING) && defined(USE_LOCALE)
8999
9000 STATIC char *
9001 S_my_setlocale_debug_string_i(pTHX_
9002                               const locale_category_index cat_index,
9003                               const char* locale, /* Optional locale name */
9004
9005                               /* return value from setlocale() when attempting
9006                                * to set 'category' to 'locale' */
9007                               const char* retval,
9008
9009                               const line_t line)
9010 {
9011     /* Returns a pointer to a NUL-terminated string in static storage with
9012      * added text about the info passed in.  This is not thread safe and will
9013      * be overwritten by the next call, so this should be used just to
9014      * formulate a string to immediately print or savepv() on. */
9015
9016     const char * locale_quote;
9017     const char * retval_quote;
9018
9019     assert(cat_index <= LC_ALL_INDEX_);
9020
9021     if (locale == NULL) {
9022         locale_quote = "";
9023         locale = "NULL";
9024     }
9025     else {
9026         locale_quote = "\"";
9027     }
9028
9029     if (retval == NULL) {
9030         retval_quote = "";
9031         retval = "NULL";
9032     }
9033     else {
9034         retval_quote = "\"";
9035     }
9036
9037 #  ifdef USE_LOCALE_THREADS
9038 #    define THREAD_FORMAT "%p:"
9039 #    define THREAD_ARGUMENT aTHX_
9040 #  else
9041 #    define THREAD_FORMAT
9042 #    define THREAD_ARGUMENT
9043 #  endif
9044
9045     return Perl_form(aTHX_
9046                      "%s:%" LINE_Tf ": " THREAD_FORMAT
9047                      " setlocale(%s[%d], %s%s%s) returned %s%s%s\n",
9048
9049                      __FILE__, line, THREAD_ARGUMENT
9050                      category_names[cat_index], categories[cat_index],
9051                      locale_quote, locale, locale_quote,
9052                      retval_quote, retval, retval_quote);
9053 }
9054
9055 #endif
9056 #ifdef USE_PERL_SWITCH_LOCALE_CONTEXT
9057
9058 void
9059 Perl_switch_locale_context(pTHX)
9060 {
9061     /* libc keeps per-thread locale status information in some configurations.
9062      * So, we can't just switch out aTHX to switch to a new thread.  libc has
9063      * to follow along.  This routine does that based on per-interpreter
9064      * variables we keep just for this purpose.
9065      *
9066      * There are two implementations where this is an issue.  For the other
9067      * implementations, it doesn't matter because libc is using global values
9068      * that all threads know about.
9069      *
9070      * The two implementations are where libc keeps thread-specific information
9071      * on its own.  These are
9072      *
9073      * POSIX 2008:  The current locale is kept by libc as an object.  We save
9074      *              a copy of that in the per-thread PL_cur_locale_obj, and so
9075      *              this routine uses that copy to tell the thread it should be
9076      *              operating with that object
9077      * Windows thread-safe locales:  A given thread in Windows can be being run
9078      *              with per-thread locales, or not.  When the thread context
9079      *              changes, libc doesn't automatically know if the thread is
9080      *              using per-thread locales, nor does it know what the new
9081      *              thread's locale is.  We keep that information in the
9082      *              per-thread variables:
9083      *                  PL_controls_locale  indicates if this thread is using
9084      *                                      per-thread locales or not
9085      *                  PL_cur_LC_ALL       indicates what the the locale
9086      *                                      should be if it is a per-thread
9087      *                                      locale.
9088      */
9089
9090     if (UNLIKELY(   PL_veto_switch_non_tTHX_context
9091                  || PL_phase == PERL_PHASE_CONSTRUCT))
9092     {
9093         return;
9094     }
9095
9096 #  ifdef USE_POSIX_2008_LOCALE
9097
9098     if (! uselocale(PL_cur_locale_obj)) {
9099         locale_panic_(Perl_form(aTHX_
9100                                 "Can't uselocale(%p), LC_ALL supposed to"
9101                                 " be '%s'",
9102                                 PL_cur_locale_obj, get_LC_ALL_display()));
9103     }
9104
9105 #  elif defined(WIN32)
9106
9107     if (! bool_setlocale_c(LC_ALL, PL_cur_LC_ALL)) {
9108         locale_panic_(Perl_form(aTHX_ "Can't setlocale(%s)", PL_cur_LC_ALL));
9109     }
9110
9111 #  endif
9112
9113 }
9114
9115 #endif
9116
9117 void
9118 Perl_thread_locale_init(pTHX)
9119 {
9120
9121 #ifdef USE_THREAD_SAFE_LOCALE
9122 #  ifdef USE_POSIX_2008_LOCALE
9123
9124     /* Called from a thread on startup.
9125      *
9126      * The operations here have to be done from within the calling thread, as
9127      * they affect libc's knowledge of the thread; libc has no knowledge of
9128      * aTHX */
9129
9130      DEBUG_L(PerlIO_printf(Perl_debug_log,
9131                            "new thread, initial locale is %s;"
9132                            " calling setlocale(LC_ALL, \"C\")\n",
9133                            get_LC_ALL_display()));
9134
9135     if (! uselocale(PL_C_locale_obj)) {
9136
9137         /* Not being able to change to the C locale is severe; don't keep
9138          * going.  */
9139         locale_panic_(Perl_form(aTHX_
9140                                 "Can't uselocale(%p), 'C'", PL_C_locale_obj));
9141         NOT_REACHED; /* NOTREACHED */
9142     }
9143
9144 #    ifdef MULTIPLICITY
9145
9146     PL_cur_locale_obj = PL_C_locale_obj;
9147
9148 #    endif
9149 #  elif defined(WIN32)
9150
9151     /* On Windows, make sure new thread has per-thread locales enabled */
9152     if (_configthreadlocale(_ENABLE_PER_THREAD_LOCALE) == -1) {
9153         locale_panic_("_configthreadlocale returned an error");
9154     }
9155     void_setlocale_c(LC_ALL, "C");
9156
9157 #  endif
9158 #endif
9159
9160 }
9161
9162 void
9163 Perl_thread_locale_term(pTHX)
9164 {
9165     /* Called from a thread as it gets ready to terminate.
9166      *
9167      * The operations here have to be done from within the calling thread, as
9168      * they affect libc's knowledge of the thread; libc has no knowledge of
9169      * aTHX */
9170
9171 #if defined(USE_POSIX_2008_LOCALE) && defined(USE_THREADS)
9172
9173     /* Switch to the global locale, so can free up the per-thread object */
9174     locale_t actual_obj = uselocale(LC_GLOBAL_LOCALE);
9175     if (actual_obj != LC_GLOBAL_LOCALE && actual_obj != PL_C_locale_obj) {
9176         freelocale(actual_obj);
9177     }
9178
9179     /* Prevent leaks even if something has gone wrong */
9180     locale_t expected_obj = PL_cur_locale_obj;
9181     if (UNLIKELY(   expected_obj != actual_obj
9182                  && expected_obj != LC_GLOBAL_LOCALE
9183                  && expected_obj != PL_C_locale_obj))
9184     {
9185         freelocale(expected_obj);
9186     }
9187
9188     PL_cur_locale_obj = LC_GLOBAL_LOCALE;
9189
9190 #endif
9191 #ifdef WIN32_USE_FAKE_OLD_MINGW_LOCALES
9192
9193     /* When faking the mingw implementation, we coerce this function into doing
9194      * something completely different from its intent -- namely to free up our
9195      * static buffer to avoid a leak.  This function gets called for each
9196      * thread that is terminating, so will give us a chance to free the buffer
9197      * from the appropriate pool.  On unthreaded systems, it gets called by the
9198      * mutex termination code. */
9199
9200 #  ifdef MULTIPLICITY
9201
9202     if (aTHX != wsetlocale_buf_aTHX) {
9203         return;
9204     }
9205
9206 #  endif
9207
9208     if (wsetlocale_buf_size > 0) {
9209         Safefree(wsetlocale_buf);
9210         wsetlocale_buf_size = 0;
9211     }
9212
9213 #endif
9214
9215 }
9216
9217 /*
9218  * ex: set ts=8 sts=4 sw=4 et:
9219  */