Emulate POSIX locale setting on Windows

Locale initialization and setting on Windows haven't been as
described in perllocale for setting locales to "".  This is because that
tells Windows to use the system default locale, as set through the
Control Panel, but on POSIX systems, it means to look at various
environment variables.

This commit creates a wrapper for setlocale, used only on Windows, that
looks for the appropriate environment variables when called with a ""
input locale.  If none are found, it continues to use the system default
locale.

diff --git a/embed.fnc b/embed.fnc
index 6f743e4..e9795a7 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1069,6 +1069,11 @@ ApdO     |AV*    |get_av         |NN const char *name|I32 flags
 ApdO   |HV*    |get_hv         |NN const char *name|I32 flags
 ApdO   |CV*    |get_cv         |NN const char* name|I32 flags
 Apd    |CV*    |get_cvn_flags  |NN const char* name|STRLEN len|I32 flags
+#ifdef WIN32
+ApPM   |char*  |my_setlocale   |int category|NULLOK const char* locale
+#else
+AmPM   |char*  |my_setlocale   |int category|NULLOK const char* locale
+#endif
 ApOM   |int    |init_i18nl10n  |int printwarn
 ApOM   |int    |init_i18nl14n  |int printwarn
 ApOM   |void   |new_collate    |NULLOK const char* newcoll

diff --git a/embed.h b/embed.h
index d1224eb..1075912 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -849,6 +849,9 @@
 #define PerlIO_unread(a,b,c)   Perl_PerlIO_unread(aTHX_ a,b,c)
 #define PerlIO_write(a,b,c)    Perl_PerlIO_write(aTHX_ a,b,c)
 #endif
+#if defined(WIN32)
+#define my_setlocale(a,b)      Perl_my_setlocale(aTHX_ a,b)
+#endif
 #if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS)
 #define do_aspawn(a,b,c)       Perl_do_aspawn(aTHX_ a,b,c)
 #define do_spawn(a)            Perl_do_spawn(aTHX_ a)

diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 08e459c..f8d7c24 100644 (file)
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -951,7 +951,11 @@ setlocale(category, locale = 0)
     PREINIT:
        char *          retval;
     CODE:
+#ifdef WIN32    /* Use wrapper on Windows */
+       retval = Perl_my_setlocale(aTHX_ category, locale);
+#else
        retval = setlocale(category, locale);
+#endif
        if (! retval) {
             XSRETURN_UNDEF;
         }

diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm
index 83a9e2c..0ca9ee9 100644 (file)
--- a/ext/POSIX/lib/POSIX.pm
+++ b/ext/POSIX/lib/POSIX.pm
@@ -4,7 +4,7 @@ use warnings;
 
 our ($AUTOLOAD, %SIGRT);
 
-our $VERSION = '1.38_01';
+our $VERSION = '1.38_02';
 
 require XSLoader;
 

diff --git a/locale.c b/locale.c
index 6654468..18f5ee9 100644 (file)
--- a/locale.c
+++ b/locale.c
@@ -331,6 +331,85 @@ Perl_new_collate(pTHX_ const char *newcoll)
 #endif /* USE_LOCALE_COLLATE */
 }
 
+#ifdef WIN32
+
+char *
+Perl_my_setlocale(pTHX_ int category, const char* locale)
+{
+    /* This, for Windows, emulates POSIX setlocale() behavior.  There is no
+     * difference unless the input locale is "", which means on Windows to get
+     * the machine default, which is set via the computer's "Regional and
+     * Language Options" (or its current equivalent).  In POSIX, it instead
+     * means to find the locale from the user's environment.  This routine
+     * looks in the environment, and, if anything is found, uses that instead
+     * of going to the machine default.  If there is no environment override,
+     * the machine default is used, as normal, by calling the real setlocale()
+     * with "".  The POSIX behavior is to use the LC_ALL variable if set;
+     * otherwise to use the particular category's variable if set; otherwise to
+     * use the LANG variable. */
+
+    if (locale && strEQ(locale, "")) {
+#   ifdef LC_ALL
+        locale = PerlEnv_getenv("LC_ALL");
+        if (! locale) {
+#endif
+            switch (category) {
+#   ifdef LC_ALL
+                case LC_ALL:
+                    break;  /* We already know its variable isn't set */
+#   endif
+#   ifdef USE_LOCALE_TIME
+                case LC_TIME:
+                    locale = PerlEnv_getenv("LC_TIME");
+                    break;
+#   endif
+#   ifdef USE_LOCALE_CTYPE
+                case LC_CTYPE:
+                    locale = PerlEnv_getenv("LC_CTYPE");
+                    break;
+#   endif
+#   ifdef USE_LOCALE_COLLATE
+                case LC_COLLATE:
+                    locale = PerlEnv_getenv("LC_COLLATE");
+                    break;
+#   endif
+#   ifdef USE_LOCALE_MONETARY
+                case LC_MONETARY:
+                    locale = PerlEnv_getenv("LC_MONETARY");
+                    break;
+#   endif
+#   ifdef USE_LOCALE_NUMERIC
+                case LC_NUMERIC:
+                    locale = PerlEnv_getenv("LC_NUMERIC");
+                    break;
+#   endif
+#   ifdef USE_LOCALE_MESSAGES
+                case LC_MESSAGES:
+                    locale = PerlEnv_getenv("LC_MESSAGES");
+                    break;
+#   endif
+                default:
+                    /* This is a category, like PAPER_SIZE that we don't
+                     * know about; and so can't provide a wrapper. */
+                    break;
+            }
+            if (! locale) {
+                locale = PerlEnv_getenv("LANG");
+                if (! locale) {
+                    locale = "";
+                }
+            }
+#   ifdef LC_ALL
+        }
+#   endif
+    }
+
+    return setlocale(category, locale);
+}
+
+#endif
+
+
 /*
  * Initialize locale awareness.
  */
@@ -378,7 +457,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 
 #   ifdef LC_ALL
     if (lang) {
-       if (setlocale(LC_ALL, setlocale_init))
+       if (my_setlocale(LC_ALL, setlocale_init))
            done = TRUE;
        else
            setlocale_failure = TRUE;
@@ -387,7 +466,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #       ifdef USE_LOCALE_CTYPE
        Safefree(curctype);
        if (! (curctype =
-              setlocale(LC_CTYPE,
+              my_setlocale(LC_CTYPE,
                         (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
                                    ? setlocale_init : NULL)))
            setlocale_failure = TRUE;
@@ -397,7 +476,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #       ifdef USE_LOCALE_COLLATE
        Safefree(curcoll);
        if (! (curcoll =
-              setlocale(LC_COLLATE,
+              my_setlocale(LC_COLLATE,
                         (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
                                   ? setlocale_init : NULL)))
            setlocale_failure = TRUE;
@@ -407,7 +486,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #       ifdef USE_LOCALE_NUMERIC
        Safefree(curnum);
        if (! (curnum =
-              setlocale(LC_NUMERIC,
+              my_setlocale(LC_NUMERIC,
                         (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
                                  ? setlocale_init : NULL)))
            setlocale_failure = TRUE;
@@ -421,28 +500,28 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #endif /* !LOCALE_ENVIRON_REQUIRED */
 
 #ifdef LC_ALL
-    if (! setlocale(LC_ALL, setlocale_init))
+    if (! my_setlocale(LC_ALL, setlocale_init))
        setlocale_failure = TRUE;
 #endif /* LC_ALL */
 
     if (!setlocale_failure) {
 #ifdef USE_LOCALE_CTYPE
        Safefree(curctype);
-       if (! (curctype = setlocale(LC_CTYPE, setlocale_init)))
+       if (! (curctype = my_setlocale(LC_CTYPE, setlocale_init)))
            setlocale_failure = TRUE;
        else
            curctype = savepv(curctype);
 #endif /* USE_LOCALE_CTYPE */
 #ifdef USE_LOCALE_COLLATE
        Safefree(curcoll);
-       if (! (curcoll = setlocale(LC_COLLATE, setlocale_init)))
+       if (! (curcoll = my_setlocale(LC_COLLATE, setlocale_init)))
            setlocale_failure = TRUE;
        else
            curcoll = savepv(curcoll);
 #endif /* USE_LOCALE_COLLATE */
 #ifdef USE_LOCALE_NUMERIC
        Safefree(curnum);
-       if (! (curnum = setlocale(LC_NUMERIC, setlocale_init)))
+       if (! (curnum = my_setlocale(LC_NUMERIC, setlocale_init)))
            setlocale_failure = TRUE;
        else
            curnum = savepv(curnum);

diff --git a/perl.h b/perl.h
index 0503209..e940ab6 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -702,6 +702,9 @@
 #   if !defined(NO_LOCALE_MONETARY) && defined(LC_MONETARY)
 #      define USE_LOCALE_MONETARY
 #   endif
+#   ifndef WIN32    /* No wrapper except on Windows */
+#       define my_setlocale(a,b) setlocale(a,b)
+#   endif
 #endif /* !NO_LOCALE && HAS_SETLOCALE */
 
 #include <setjmp.h>

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index c1c6fbb..490a260 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -726,6 +726,12 @@ calculate byte offsets for a large portion of the string. [perl
 C< for ( $h{k} || '' ) > no longer auto-vivifies C<$h{k}>.  [perl
 #120374]
 
+=item *
+
+On Windows machines, Perl now emulates the POSIX use of the environment
+for locale initialization.  Previously, the environment was ignored.
+See L<perllocale/ENVIRONMENT>.
+
 =back
 
 =head1 Known Problems

diff --git a/pod/perllocale.pod b/pod/perllocale.pod
index 0698b34..be41f0a 100644 (file)
--- a/pod/perllocale.pod
+++ b/pod/perllocale.pod
@@ -1115,7 +1115,8 @@ and you should investigate what the problem is.
 
 The following environment variables are not specific to Perl: They are
 part of the standardized (ISO C, XPG4, POSIX 1.c) C<setlocale()> method
-for controlling an application's opinion on data.
+for controlling an application's opinion on data.  Windows is non-POSIX,
+but Perl arranges for the following to work as described anyway.
 
 =over 12
 

diff --git a/proto.h b/proto.h
index 88e246a..9c2640f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5082,6 +5082,11 @@ PERL_CALLCONV void       Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop
        assert(idop)
 
 #endif
+#if !(defined(WIN32))
+/* PERL_CALLCONV char* my_setlocale(pTHX_ int category, const char* locale)
+                       __attribute__pure__; */
+
+#endif
 #if !(defined(_MSC_VER))
 PERL_CALLCONV_NO_RET int       Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__noreturn__
@@ -8061,6 +8066,9 @@ PERL_CALLCONV SSize_t     Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_
 
 #endif
 #if defined(WIN32)
+PERL_CALLCONV char*    Perl_my_setlocale(pTHX_ int category, const char* locale)
+                       __attribute__pure__;
+
 PERL_CALLCONV_NO_RET void      win32_croak_not_implemented(const char * fname)
                        __attribute__noreturn__
                        __attribute__nonnull__(1);