diff options
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | locale.c | 95 | ||||
| -rw-r--r-- | makedef.pl | 8 | ||||
| -rw-r--r-- | perl.c | 13 | ||||
| -rw-r--r-- | perl.h | 18 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | perlvars.h | 4 |
7 files changed, 118 insertions, 24 deletions
diff --git a/embedvar.h b/embedvar.h index ec0b7b182d..cf4912ca58 100644 --- a/embedvar.h +++ b/embedvar.h @@ -365,6 +365,8 @@ #if defined(PERL_GLOBAL_STRUCT) +#define PL_C_locale_obj (my_vars->GC_locale_obj) +#define PL_GC_locale_obj (my_vars->GC_locale_obj) #define PL_appctx (my_vars->Gappctx) #define PL_Gappctx (my_vars->Gappctx) #define PL_check (my_vars->Gcheck) @@ -2464,47 +2464,94 @@ Perl__is_in_locale_category(pTHX_ const bool compiling, const int category) } char * -Perl_my_strerror(pTHX_ const int errnum) { +Perl_my_strerror(pTHX_ const int errnum) +{ + /* Returns a mortalized copy of the text of the error message associated + * with 'errnum'. It uses the current locale's text unless the platform + * doesn't have the LC_MESSAGES category or we are not being called from + * within the scope of 'use locale'. In the former case, it uses whatever + * strerror returns; in the latter case it uses the text from the C locale. + * + * The function just calls strerror(), but temporarily switches, if needed, + * to the C locale */ + + char *errstr; + +#ifdef USE_LOCALE_MESSAGES /* If platform doesn't have messages category, we + don't do any switching to the C locale; we just + use whatever strerror() returns */ + const bool within_locale_scope = IN_LC(LC_MESSAGES); + dVAR; - /* Uses C locale for the error text unless within scope of 'use locale' for - * LC_MESSAGES */ +# ifdef USE_THREAD_SAFE_LOCALE + locale_t save_locale; +# else + char * save_locale; + bool locale_is_C; -#ifdef USE_LOCALE_MESSAGES - if (! IN_LC(LC_MESSAGES)) { - char * save_locale; + /* We have a critical section to prevent another thread from changing the + * locale out from under us (or zapping the buffer returned from + * setlocale() ) */ + LOCALE_LOCK; + +# endif + + if (! within_locale_scope) { - /* We have a critical section to prevent another thread from changing - * the locale out from under us (or zapping the buffer returned from - * setlocale() ) */ - LOCALE_LOCK; +# ifdef USE_THREAD_SAFE_LOCALE /* Use the thread-safe locale functions */ + + save_locale = uselocale(PL_C_locale_obj); + +# else /* Not thread-safe build */ save_locale = setlocale(LC_MESSAGES, NULL); - if (! isNAME_C_OR_POSIX(save_locale)) { - char *errstr; + locale_is_C = isNAME_C_OR_POSIX(save_locale); - /* The next setlocale likely will zap this, so create a copy */ - save_locale = savepv(save_locale); + /* Switch to the C locale if not already in it */ + if (! locale_is_C) { + /* The setlocale() just below likely will zap 'save_locale', so + * create a copy. */ + save_locale = savepv(save_locale); setlocale(LC_MESSAGES, "C"); + } - /* This points to the static space in Strerror, with all its - * limitations */ - errstr = Strerror(errnum); +# endif - setlocale(LC_MESSAGES, save_locale); - Safefree(save_locale); + } /* end of ! within_locale_scope */ - LOCALE_UNLOCK; +#endif - return errstr; - } + errstr = Strerror(errnum); + if (errstr) { + errstr = savepv(errstr); + SAVEFREEPV(errstr); + } + +#ifdef USE_LOCALE_MESSAGES + + if (! within_locale_scope) { - LOCALE_UNLOCK; +# ifdef USE_THREAD_SAFE_LOCALE + + uselocale(save_locale); } + +# else + + if (! locale_is_C) { + setlocale(LC_MESSAGES, save_locale); + Safefree(save_locale); + } + } + + LOCALE_UNLOCK; + +# endif #endif - return Strerror(errnum); + return errstr; } /* diff --git a/makedef.pl b/makedef.pl index 956914e7ed..80723ca9ff 100644 --- a/makedef.pl +++ b/makedef.pl @@ -398,6 +398,14 @@ unless ($define{'USE_ITHREADS'}) { ); } +unless ( $define{'USE_ITHREADS'} + && $define{'HAS_NEWLOCALE'}) +{ + ++$skip{$_} foreach qw( + PL_C_locale_obj + ); +} + unless ($define{'PERL_IMPLICIT_CONTEXT'}) { ++$skip{$_} foreach qw( PL_my_cxt_index @@ -420,6 +420,9 @@ perl_construct(pTHXx) PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); +#ifdef USE_THREAD_SAFE_LOCALE + PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); +#endif ENTER; } @@ -1124,6 +1127,16 @@ perl_destruct(pTHXx) PL_SB_invlist = NULL; PL_WB_invlist = NULL; +#ifdef USE_THREAD_SAFE_LOCALE + if (PL_C_locale_obj) { + /* Make sure we aren't using the locale space we are about to free */ + uselocale(LC_GLOBAL_LOCALE); + + freelocale(PL_C_locale_obj); + PL_C_locale_obj = (locale_t) NULL; + } +#endif + if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = NULL; @@ -729,6 +729,10 @@ # include <locale.h> #endif +#ifdef I_XLOCALE +# include <xlocale.h> +#endif + #if !defined(NO_LOCALE) && defined(HAS_SETLOCALE) # define USE_LOCALE # define HAS_SKIP_LOCALE_INIT /* Solely for XS code to test for this @@ -6053,6 +6057,20 @@ typedef struct am_table_short AMTS; # endif /* PERL_CORE or PERL_IN_XSUB_RE */ +#if defined(USE_ITHREADS) \ + && defined(HAS_NEWLOCALE) \ + && defined(LC_ALL_MASK) \ + && defined(HAS_FREELOCALE) \ + && defined(HAS_USELOCALE) \ + && ! defined(NO_THREAD_SAFE_USELOCALE) + + /* The code is written for simplicity to assume that any platform advanced + * enough to have the Posix 2008 locale functions has LC_ALL. The test + * above makes sure that assumption is valid */ + +# define USE_THREAD_SAFE_LOCALE +#endif + #else /* No locale usage */ # define LOCALE_INIT # define LOCALE_TERM @@ -99,6 +99,8 @@ END_EXTERN_C #else /* !PERL_CORE */ +#undef PL_C_locale_obj +#define PL_C_locale_obj (*Perl_GC_locale_obj_ptr(NULL)) #undef PL_appctx #define PL_appctx (*Perl_Gappctx_ptr(NULL)) #undef PL_check diff --git a/perlvars.h b/perlvars.h index 5466294963..89e2e1eb52 100644 --- a/perlvars.h +++ b/perlvars.h @@ -101,6 +101,10 @@ PERLVARI(G, mmap_page_size, IV, 0) PERLVAR(G, hints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */ PERLVAR(G, locale_mutex, perl_mutex) /* Mutex for setlocale() changing */ +# ifdef HAS_NEWLOCALE +PERLVAR(G, C_locale_obj, locale_t) +# endif + #endif #ifdef DEBUGGING |