Add Perl_setlocale()

khw could not find any modules on CPAN that correctly use the C library
function setlocale().  (The very few that do try, do not use it
correctly, looking at the return value incorrectly, so they are broken.)
This analysis does not include modules that call non-Perl libaries that
may call setlocale().

And, a future commit will render the setlocale() function useless in
some configurations on some platforms.

So this commit adds Perl_setlocale(), for XS code to call, and which is
always effective, but it should not be used to alter the locale except
on platforms where the predefined variable ${^SAFE_LOCALES} evaluates to
1.

This function is also what POSIX::setlocale() calls to do the real work.

diff --git a/embed.fnc b/embed.fnc
index ce876eb..80035a8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1296,7 +1296,7 @@ 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
-EXnpo  |char*  |setlocale      |int category|NULLOK const char* locale
+Ando   |const char*|Perl_setlocale|const int category|NULLOK const char* locale
 #if defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H)
 Ando   |const char*|Perl_langinfo|const nl_item item
 #else

diff --git a/embedvar.h b/embedvar.h
index fe33c86..d7eb929 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -284,6 +284,8 @@
 #define PL_scopestack_name     (vTHX->Iscopestack_name)
 #define PL_secondgv            (vTHX->Isecondgv)
 #define PL_seen_deprecated_macro       (vTHX->Iseen_deprecated_macro)
+#define PL_setlocale_buf       (vTHX->Isetlocale_buf)
+#define PL_setlocale_bufsize   (vTHX->Isetlocale_bufsize)
 #define PL_sharehook           (vTHX->Isharehook)
 #define PL_sig_pending         (vTHX->Isig_pending)
 #define PL_sighandlerp         (vTHX->Isighandlerp)

diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 2d3e69f..f54ca26 100644 (file)
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -2237,15 +2237,11 @@ setlocale(category, locale = 0)
     PREINIT:
        char *          retval;
     CODE:
-       retval = Perl_setlocale(category, locale);
-        if (! retval) { /* Should never happen that a query would return an
-                         * error, but be sure */
+       retval = (char *) Perl_setlocale(category, locale);
+        if (! retval) {
             XSRETURN_UNDEF;
         }
 
-        /* Make sure the returned copy gets cleaned up */
-        SAVEFREEPV(retval);
-
         RETVAL = retval;
     OUTPUT:
        RETVAL

diff --git a/intrpvar.h b/intrpvar.h
index 51fb16b..884fa87 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -590,6 +590,8 @@ PERLVARI(I, collation_standard, bool, TRUE)
 
 PERLVARI(I, langinfo_buf, char *, NULL)
 PERLVARI(I, langinfo_bufsize, Size_t, 0)
+PERLVARI(I, setlocale_buf, char *, NULL)
+PERLVARI(I, setlocale_bufsize, Size_t, 0)
 
 #ifdef PERL_SAWAMPERSAND
 PERLVAR(I, sawampersand, U8)           /* must save all match strings */

diff --git a/locale.c b/locale.c
index 4a3d3a0..357f9d4 100644 (file)
--- a/locale.c
+++ b/locale.c
@@ -610,8 +610,8 @@ S_new_ctype(pTHX_ const char *newctype)
      * that tofold() is tolc() since fold case is not a concept in POSIX,
      *
      * Any code changing the locale (outside this file) should use
-     * POSIX::setlocale, which calls this function.  Therefore this function
-     * should be called directly only from this file and from
+     * Perl_setlocale or POSIX::setlocale, which call this function.  Therefore
+     * this function should be called directly only from this file and from
      * POSIX::setlocale() */
 
     dVAR;
@@ -1208,13 +1208,43 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
 
 #endif
 
-char *
-Perl_setlocale(int category, const char * locale)
+/*
+
+=head1 Locale-related functions and macros
+
+=for apidoc Perl_setlocale
+
+This is an (almost) drop-in replacement for the system L<C<setlocale(3)>>,
+taking the same parameters, and returning the same information, except that it
+returns the correct underlying C<LC_NUMERIC> locale, instead of C<C> always, as
+perl keeps that locale category as C<C>, changing it briefly during the
+operations where the underlying one is required.
+
+The other reason it isn't completely a drop-in replacement is that it is
+declared to return S<C<const char *>>, whereas the system setlocale omits the
+C<const>.  (If it were being written today, plain setlocale would be declared
+const, since it is illegal to change the information it returns; doing so leads
+to segfaults.)
+
+C<Perl_setlocale> should not be used to change the locale except on systems
+where the predefined variable C<${^SAFE_LOCALES}> is 1.
+
+The return points to a per-thread static buffer, which is overwritten the next
+time C<Perl_setlocale> is called from the same thread.
+
+=cut
+
+*/
+
+const char *
+Perl_setlocale(const int category, const char * locale)
 {
     /* This wraps POSIX::setlocale() */
 
-    char * retval;
-    char * newlocale;
+    const char * retval;
+    const char * newlocale;
+    dSAVEDERRNO;
+    DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
     dTHX;
 
 #ifdef USE_LOCALE_NUMERIC
@@ -1225,14 +1255,16 @@ Perl_setlocale(int category, const char * locale)
      * results.  All other categories don't require special handling */
     if (locale == NULL) {
         if (category == LC_NUMERIC) {
-            return savepv(PL_numeric_name);
+
+            /* We don't have to copy this return value, as it is a per-thread
+             * variable, and won't change until a future setlocale */
+            return PL_numeric_name;
         }
 
 #  ifdef LC_ALL
 
-        else if (category == LC_ALL && ! PL_numeric_underlying) {
-
-            SET_NUMERIC_UNDERLYING();
+        else if (category == LC_ALL) {
+            STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
         }
 
 #  endif
@@ -1241,26 +1273,32 @@ Perl_setlocale(int category, const char * locale)
 
 #endif
 
-    /* Save retval since subsequent setlocale() calls may overwrite it. */
-    retval = savepv(do_setlocale_r(category, locale));
+    retval = do_setlocale_r(category, locale);
+    SAVE_ERRNO;
+
+#if defined(USE_LOCALE_NUMERIC) && defined(LC_ALL)
+
+    if (locale == NULL && category == LC_ALL) {
+        RESTORE_LC_NUMERIC();
+    }
+
+#endif
 
     DEBUG_L(PerlIO_printf(Perl_debug_log,
         "%s:%d: %s\n", __FILE__, __LINE__,
             setlocale_debug_string(category, locale, retval)));
-    if (! retval) {
-        /* Should never happen that a query would return an error, but be
-         * sure and reset to C locale */
-        if (locale == 0) {
-            SET_NUMERIC_STANDARD();
-        }
 
+    RESTORE_ERRNO;
+
+    if (! retval) {
         return NULL;
     }
 
-    /* If locale == NULL, we are just querying the state, but may have switched
-     * to NUMERIC_UNDERLYING.  Switch back before returning. */
+    save_to_buffer(retval, &PL_setlocale_buf, &PL_setlocale_bufsize, 0);
+    retval = PL_setlocale_buf;
+
+    /* If locale == NULL, we are just querying the state */
     if (locale == NULL) {
-        SET_NUMERIC_STANDARD();
         return retval;
     }
 
@@ -1324,7 +1362,6 @@ Perl_setlocale(int category, const char * locale)
 
     return retval;
 
-
 }
 
 PERL_STATIC_INLINE const char *
@@ -1352,8 +1389,6 @@ S_save_to_buffer(const char * string, char **buf, Size_t *buf_size, const Size_t
 
 /*
 
-=head1 Locale-related functions and macros
-
 =for apidoc Perl_langinfo
 
 This is an (almost ª) drop-in replacement for the system C<L<nl_langinfo(3)>>,

diff --git a/perl.c b/perl.c
index 9817220..a638bae 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1163,6 +1163,11 @@ perl_destruct(pTHXx)
 #  endif
 #endif
 
+    if (PL_setlocale_buf) {
+        Safefree(PL_setlocale_buf);
+        PL_setlocale_buf = NULL;
+    }
+
     if (PL_langinfo_buf) {
         Safefree(PL_langinfo_buf);
         PL_langinfo_buf = NULL;

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 9ec810d..b4e10fe 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -371,6 +371,10 @@ useful for XS or C code that only need the thread context because their
 debugging statements that get compiled only under C<-DDEBUGGING> need
 one.
 
+=item *
+
+A new API function L<perlapi/Perl_setlocale> has been added.
+
 =back
 
 =head1 Selected Bug Fixes

diff --git a/proto.h b/proto.h
index 9f6d0df..d35e295 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -49,6 +49,7 @@ PERL_CALLCONV int     Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag)
 #define PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC  \
        assert(file)
 
+PERL_CALLCONV const char*      Perl_setlocale(const int category, const char* locale);
 PERL_CALLCONV void*    Perl_Slab_Alloc(pTHX_ size_t sz)
                        __attribute__warn_unused_result__;
 
@@ -2946,7 +2947,6 @@ PERL_CALLCONV void        Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd);
 PERL_CALLCONV void     Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd);
 PERL_CALLCONV void     Perl_setfd_inhexec(int fd);
 PERL_CALLCONV void     Perl_setfd_inhexec_for_sysfd(pTHX_ int fd);
-PERL_CALLCONV char*    Perl_setlocale(int category, const char* locale);
 PERL_CALLCONV HEK*     Perl_share_hek(pTHX_ const char* str, SSize_t len, U32 hash);
 #define PERL_ARGS_ASSERT_SHARE_HEK     \
        assert(str)

diff --git a/sv.c b/sv.c
index df98a95..4377e95 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -15569,6 +15569,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_langinfo_buf = NULL;
     PL_langinfo_bufsize = 0;
 
+    PL_setlocale_buf = NULL;
+    PL_setlocale_bufsize = 0;
+
     /* Unicode inversion lists */
     PL_Latin1          = sv_dup_inc(proto_perl->ILatin1, param);
     PL_UpperLatin1     = sv_dup_inc(proto_perl->IUpperLatin1, param);