In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/ec268cc8df7c7a90811a099d422eef6a31bf9f8b?hp=36dde45600330dc1ed3fd533b0c7ed6e6a1e1477>
- Log -----------------------------------------------------------------
commit ec268cc8df7c7a90811a099d422eef6a31bf9f8b
Author: Karl Williamson <k...@cpan.org>
Date: Sat Jul 15 12:36:54 2017 -0600
embed.fnc: Fix declaration of my_strerror()
This was improperly made public (but the docs indicate it should not be
used by the public).
M embed.fnc
M embed.h
commit 8d8472df12072ded59429badcdacbeed8c53f5ef
Author: Karl Williamson <k...@cpan.org>
Date: Sat Jul 15 12:03:01 2017 -0600
embed.fnc Change Some functions only used in macros
The X flag is used for this situation where a function is public only
because it is called from a public macro.
M embed.fnc
M embed.h
M perl.h
commit a4f00dcc5feacca75d4cec1952f7dae09e1a2ad3
Author: Karl Williamson <k...@cpan.org>
Date: Sat Jul 15 11:11:41 2017 -0600
Move bulk of POSIX::setlocale to locale.c
This cleans up the interface, as it allows several functions to now be
static that used to have to be called from outside locale.c
M embed.fnc
M embed.h
M ext/POSIX/POSIX.xs
M ext/POSIX/lib/POSIX.pm
M locale.c
M perl.h
M proto.h
commit 0887d051f49229ff72dc6fd22105ce922a11003f
Author: Karl Williamson <k...@cpan.org>
Date: Sat Jul 15 15:01:44 2017 -0600
Fix File::Glob/t/rt131211.t
The \b boundaries I added in commit
5a993d81c4b1abf13cd3ae4cbc04f26c7516bc37 were wrong. \b{wb} give a better
result.
M ext/File-Glob/t/rt131211.t
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 35 ++++----
embed.h | 29 +++----
ext/File-Glob/t/rt131211.t | 2 +-
ext/POSIX/POSIX.xs | 110 ++----------------------
ext/POSIX/lib/POSIX.pm | 2 +-
locale.c | 204 ++++++++++++++++++++++++++++++++++++++++-----
perl.h | 22 +++--
proto.h | 26 +++---
8 files changed, 241 insertions(+), 189 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 5c0a89e9de..8dc61d857e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1255,21 +1255,14 @@ 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
-ApM |char* |my_setlocale |int category|NULLOK const char* locale
-#else
-AmM |char* |my_setlocale |int category|NULLOK const char* locale
-#endif
+EXnpo |char* |setlocale |int category|NULLOK const char* locale
ApOM |int |init_i18nl10n |int printwarn
ApOM |int |init_i18nl14n |int printwarn
-ApM |char* |my_strerror |const int errnum
-ApOM |void |new_collate |NULLOK const char* newcoll
-ApOM |void |new_ctype |NN const char* newctype
-EXpMn |void |_warn_problematic_locale
-ApOM |void |new_numeric |NULLOK const char* newcoll
-Ap |void |set_numeric_local
-Ap |void |set_numeric_radix
-Ap |void |set_numeric_standard
+p |char* |my_strerror |const int errnum
+Xpn |void |_warn_problematic_locale
+p |void |new_numeric |NULLOK const char* newcoll
+Xp |void |set_numeric_local
+Xp |void |set_numeric_standard
ApM |bool |_is_in_locale_category|const bool compiling|const int category
Apd |void |sync_locale
ApdO |void |require_pv |NN const char* pv
@@ -2722,6 +2715,12 @@ s |bool |isa_lookup |NN HV *stash|NN const
char * const name \
#if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
s |char* |stdize_locale |NN char* locs
+s |void |new_collate |NULLOK const char* newcoll
+s |void |new_ctype |NN const char* newctype
+s |void |set_numeric_radix
+#ifdef WIN32
+s |char* |my_setlocale |int category|NULLOK const char* locale
+#endif
# ifdef DEBUGGING
s |void |print_collxfrm_input_and_return \
|NN const char * const s \
@@ -2731,17 +2730,15 @@ s |void |print_collxfrm_input_and_return
\
s |void |print_bytes_for_locale |NN const char * const s \
|NN const char * const e \
|const bool is_utf8
+snR |char * |setlocale_debug_string |const int category \
+ |NULLOK const char* const locale \
+ |NULLOK const char* const retval
# endif
#endif
-#if defined(USE_LOCALE) \
+#if defined(USE_LOCALE) \
&& (defined(PERL_IN_LOCALE_C) || defined (PERL_EXT_POSIX))
ApM |bool |_is_cur_LC_category_utf8|int category
-# ifdef DEBUGGING
-AMnpR |char * |_setlocale_debug_string|const int category \
- |NULLOK const char* const locale \
- |NULLOK const char* const retval
-# endif
#endif
diff --git a/embed.h b/embed.h
index 5439de8c0b..0cdf036e90 100644
--- a/embed.h
+++ b/embed.h
@@ -363,7 +363,6 @@
#define my_popen_list(a,b,c) Perl_my_popen_list(aTHX_ a,b,c)
#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
#define my_socketpair Perl_my_socketpair
-#define my_strerror(a) Perl_my_strerror(aTHX_ a)
#define my_strftime(a,b,c,d,e,f,g,h,i,j) Perl_my_strftime(aTHX_
a,b,c,d,e,f,g,h,i,j)
#define newANONATTRSUB(a,b,c,d) Perl_newANONATTRSUB(aTHX_ a,b,c,d)
#define newANONHASH(a) Perl_newANONHASH(aTHX_ a)
@@ -429,9 +428,6 @@
#define newWHILEOP(a,b,c,d,e,f,g) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
#define newXS(a,b,c) Perl_newXS(aTHX_ a,b,c)
#define newXS_flags(a,b,c,d,e) Perl_newXS_flags(aTHX_ a,b,c,d,e)
-#define new_collate(a) Perl_new_collate(aTHX_ a)
-#define new_ctype(a) Perl_new_ctype(aTHX_ a)
-#define new_numeric(a) Perl_new_numeric(aTHX_ a)
#define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b)
#define new_version(a) Perl_new_version(aTHX_ a)
#define nothreadhook() Perl_nothreadhook(aTHX)
@@ -579,9 +575,6 @@
#define scan_vstring(a,b,c) Perl_scan_vstring(aTHX_ a,b,c)
#define seed() Perl_seed(aTHX)
#define set_context Perl_set_context
-#define set_numeric_local() Perl_set_numeric_local(aTHX)
-#define set_numeric_radix() Perl_set_numeric_radix(aTHX)
-#define set_numeric_standard() Perl_set_numeric_standard(aTHX)
#define setdefout(a) Perl_setdefout(aTHX_ a)
#define share_hek(a,b,c) Perl_share_hek(aTHX_ a,b,c)
#define sortsv(a,b,c) Perl_sortsv(aTHX_ a,b,c)
@@ -824,9 +817,6 @@
#if defined(DEBUGGING)
#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
#define pad_sv(a) Perl_pad_sv(aTHX_ a)
-# if defined(USE_LOCALE) && (defined(PERL_IN_LOCALE_C) || defined
(PERL_EXT_POSIX))
-#define _setlocale_debug_string Perl__setlocale_debug_string
-# endif
#endif
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
#define csighandler Perl_csighandler
@@ -928,9 +918,6 @@
#define quadmath_format_needed Perl_quadmath_format_needed
#define quadmath_format_single Perl_quadmath_format_single
#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)
@@ -938,7 +925,6 @@
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#define _byte_dump_string(a,b,c) Perl__byte_dump_string(aTHX_ a,b,c)
-#define _warn_problematic_locale Perl__warn_problematic_locale
#define append_utf8_from_native_byte S_append_utf8_from_native_byte
#define av_reify(a) Perl_av_reify(aTHX_ a)
#define current_re_engine() Perl_current_re_engine(aTHX)
@@ -1163,6 +1149,7 @@
#ifdef PERL_CORE
#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a)
#define Slab_Free(a) Perl_Slab_Free(aTHX_ a)
+#define _warn_problematic_locale Perl__warn_problematic_locale
#define abort_execution(a,b) Perl_abort_execution(aTHX_ a,b)
#define alloc_LOGOP(a,b,c) Perl_alloc_LOGOP(aTHX_ a,b,c)
#define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c)
@@ -1343,12 +1330,14 @@
#define my_clearenv() Perl_my_clearenv(aTHX)
#define my_lstat_flags(a) Perl_my_lstat_flags(aTHX_ a)
#define my_stat_flags(a) Perl_my_stat_flags(aTHX_ a)
+#define my_strerror(a) Perl_my_strerror(aTHX_ a)
#define my_unexec() Perl_my_unexec(aTHX)
#define newATTRSUB_x(a,b,c,d,e,f) Perl_newATTRSUB_x(aTHX_ a,b,c,d,e,f)
#define newSTUB(a,b) Perl_newSTUB(aTHX_ a,b)
#define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c)
#define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_
a,b,c,d,e,f,g)
+#define new_numeric(a) Perl_new_numeric(aTHX_ a)
#define nextargv(a,b) Perl_nextargv(aTHX_ a,b)
#define noperl_die Perl_noperl_die
#define notify_parser_that_changed_to_utf8()
Perl_notify_parser_that_changed_to_utf8(aTHX)
@@ -1390,6 +1379,8 @@
#define scalar(a) Perl_scalar(aTHX_ a)
#define scalarvoid(a) Perl_scalarvoid(aTHX_ a)
#define set_caret_X() Perl_set_caret_X(aTHX)
+#define set_numeric_local() Perl_set_numeric_local(aTHX)
+#define set_numeric_standard() Perl_set_numeric_standard(aTHX)
#define sub_crush_depth(a) Perl_sub_crush_depth(aTHX_ a)
#define sv_2num(a) Perl_sv_2num(aTHX_ a)
#define sv_clean_all() Perl_sv_clean_all(aTHX)
@@ -1496,6 +1487,7 @@
# if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
#define print_bytes_for_locale(a,b,c) S_print_bytes_for_locale(aTHX_ a,b,c)
#define print_collxfrm_input_and_return(a,b,c,d)
S_print_collxfrm_input_and_return(aTHX_ a,b,c,d)
+#define setlocale_debug_string S_setlocale_debug_string
# endif
# endif
# if defined(DEBUG_LEAKING_SCALARS_FORK_DUMP)
@@ -1887,7 +1879,13 @@
#define padnamelist_dup(a,b) Perl_padnamelist_dup(aTHX_ a,b)
# endif
# if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
+#define new_collate(a) S_new_collate(aTHX_ a)
+#define new_ctype(a) S_new_ctype(aTHX_ a)
+#define set_numeric_radix() S_set_numeric_radix(aTHX)
#define stdize_locale(a) S_stdize_locale(aTHX_ a)
+# if defined(WIN32)
+#define my_setlocale(a,b) S_my_setlocale(aTHX_ a,b)
+# endif
# endif
# if defined(USE_LOCALE_COLLATE)
#define magic_setcollxfrm(a,b) Perl_magic_setcollxfrm(aTHX_ a,b)
@@ -1936,9 +1934,6 @@
# define perl_get_sv(a,b) get_sv(a,b)
# define perl_init_i18nl10n(a) init_i18nl10n(a)
# define perl_init_i18nl14n(a) init_i18nl14n(a)
-# define perl_new_collate(a) new_collate(a)
-# define perl_new_ctype(a) new_ctype(a)
-# define perl_new_numeric(a) new_numeric(a)
# define perl_require_pv(a) require_pv(a)
/* varargs functions can't be handled with CPP macros. :-(
diff --git a/ext/File-Glob/t/rt131211.t b/ext/File-Glob/t/rt131211.t
index d78556b3dd..40d2027969 100644
--- a/ext/File-Glob/t/rt131211.t
+++ b/ext/File-Glob/t/rt131211.t
@@ -8,7 +8,7 @@ use Time::HiRes qw(time);
use Config;
plan skip_all => 'This platform doesn\'t use File::Glob'
- if $Config{ccflags} =~ /\b-DPERL_EXTERNAL_GLOB\b/;
+ if $Config{ccflags} =~ /\b{wb}-DPERL_EXTERNAL_GLOB\b\{wb}/;
plan tests => 13;
my $path = tempdir uc cleanup => 1;
diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 0bcebb1739..68b8881233 100644
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -2194,116 +2194,16 @@ setlocale(category, locale = 0)
PREINIT:
char * retval;
CODE:
-#ifdef USE_LOCALE_NUMERIC
- /* A 0 (or NULL) locale means only query what the current one is. We
- * have the LC_NUMERIC name saved, because we are normally switched
- * into the C locale for it. Switch back so an LC_ALL query will yield
- * the correct results; all other categories don't require special
- * handling */
- if (locale == 0) {
- if (category == LC_NUMERIC) {
- XSRETURN_PV(PL_numeric_name);
- }
-# ifdef LC_ALL
- else if (category == LC_ALL) {
- SET_NUMERIC_UNDERLYING();
- }
-# endif
- }
-#endif
-#ifdef WIN32 /* Use wrapper on Windows */
- retval = Perl_my_setlocale(aTHX_ category, locale);
-#else
- retval = setlocale(category, locale);
-#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();
- }
+ retval = Perl_setlocale(category, locale);
+ if (! retval) { /* Should never happen that a query would return an
+ * error, but be sure */
XSRETURN_UNDEF;
}
- /* Save retval since subsequent setlocale() calls may overwrite it. */
- retval = savepv(retval);
+ /* Make sure the returned copy gets cleaned up */
SAVEFREEPV(retval);
- /* For locale == 0, we may have switched to NUMERIC_UNDERLYING. Switch
- * back */
- if (locale == 0) {
- SET_NUMERIC_STANDARD();
- XSRETURN_PV(retval);
- }
- else {
- RETVAL = retval;
-#ifdef USE_LOCALE_CTYPE
- if (category == LC_CTYPE
-#ifdef LC_ALL
- || category == LC_ALL
-#endif
- )
- {
- char *newctype;
-#ifdef LC_ALL
- if (category == LC_ALL) {
- newctype = setlocale(LC_CTYPE, NULL);
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(LC_CTYPE, NULL, newctype)));
- }
- else
-#endif
- newctype = RETVAL;
- new_ctype(newctype);
- }
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- if (category == LC_COLLATE
-#ifdef LC_ALL
- || category == LC_ALL
-#endif
- )
- {
- char *newcoll;
-#ifdef LC_ALL
- if (category == LC_ALL) {
- newcoll = setlocale(LC_COLLATE, NULL);
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(LC_COLLATE, NULL, newcoll)));
- }
- else
-#endif
- newcoll = RETVAL;
- new_collate(newcoll);
- }
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- if (category == LC_NUMERIC
-#ifdef LC_ALL
- || category == LC_ALL
-#endif
- )
- {
- char *newnum;
-#ifdef LC_ALL
- if (category == LC_ALL) {
- newnum = setlocale(LC_NUMERIC, NULL);
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(LC_NUMERIC, NULL, newnum)));
- }
- else
-#endif
- newnum = RETVAL;
- new_numeric(newnum);
- }
-#endif /* USE_LOCALE_NUMERIC */
- }
+ RETVAL = retval;
OUTPUT:
RETVAL
diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm
index e187b3b9eb..8b1b65760e 100644
--- a/ext/POSIX/lib/POSIX.pm
+++ b/ext/POSIX/lib/POSIX.pm
@@ -4,7 +4,7 @@ use warnings;
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.76';
+our $VERSION = '1.77';
require XSLoader;
diff --git a/locale.c b/locale.c
index d533e13c89..17022031d2 100644
--- a/locale.c
+++ b/locale.c
@@ -105,8 +105,8 @@ S_stdize_locale(pTHX_ char *locs)
#endif
-void
-Perl_set_numeric_radix(pTHX)
+STATIC void
+S_set_numeric_radix(pTHX)
{
#ifdef USE_LOCALE_NUMERIC
# ifdef HAS_LOCALECONV
@@ -286,8 +286,8 @@ Perl_set_numeric_local(pTHX)
/*
* Set up for a new ctype locale.
*/
-void
-Perl_new_ctype(pTHX_ const char *newctype)
+STATIC void
+S_new_ctype(pTHX_ const char *newctype)
{
#ifdef USE_LOCALE_CTYPE
@@ -484,8 +484,8 @@ Perl__warn_problematic_locale()
}
-void
-Perl_new_collate(pTHX_ const char *newcoll)
+STATIC void
+S_new_collate(pTHX_ const char *newcoll)
{
#ifdef USE_LOCALE_COLLATE
@@ -704,10 +704,14 @@ Perl_new_collate(pTHX_ const char *newcoll)
#endif /* USE_LOCALE_COLLATE */
}
-#ifdef WIN32
+#ifndef WIN32 /* No wrapper except on Windows */
-char *
-Perl_my_setlocale(pTHX_ int category, const char* locale)
+#define my_setlocale(a,b) setlocale(a,b)
+
+#else /* WIN32 */
+
+STATIC char *
+S_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
@@ -783,7 +787,7 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
result = setlocale(category, locale);
DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(category, locale,
result)));
+ setlocale_debug_string(category, locale, result)));
if (! override_LC_ALL) {
return result;
@@ -800,7 +804,7 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
setlocale(LC_TIME, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_TIME, result, "not captured")));
+ setlocale_debug_string(LC_TIME, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_CTYPE
@@ -809,7 +813,7 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
setlocale(LC_CTYPE, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_CTYPE, result, "not
captured")));
+ setlocale_debug_string(LC_CTYPE, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_COLLATE
@@ -818,7 +822,7 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
setlocale(LC_COLLATE, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_COLLATE, result, "not
captured")));
+ setlocale_debug_string(LC_COLLATE, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_MONETARY
@@ -827,7 +831,7 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
setlocale(LC_MONETARY, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_MONETARY, result, "not
captured")));
+ setlocale_debug_string(LC_MONETARY, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_NUMERIC
@@ -836,7 +840,7 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
setlocale(LC_NUMERIC, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_NUMERIC, result, "not captured")));
+ setlocale_debug_string(LC_NUMERIC, result, "not captured")));
}
# endif
# ifdef USE_LOCALE_MESSAGES
@@ -845,20 +849,180 @@ Perl_my_setlocale(pTHX_ int category, const char* locale)
setlocale(LC_MESSAGES, result);
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_MESSAGES, result, "not
captured")));
+ setlocale_debug_string(LC_MESSAGES, result, "not captured")));
}
# endif
result = setlocale(LC_ALL, NULL);
DEBUG_L(PerlIO_printf(Perl_debug_log, "%s:%d: %s\n",
__FILE__, __LINE__,
- _setlocale_debug_string(LC_ALL, NULL, result)));
+ setlocale_debug_string(LC_ALL, NULL, result)));
return result;
}
#endif
+char *
+Perl_setlocale(int category, const char * locale)
+{
+ /* This wraps POSIX::setlocale() */
+
+ char * retval;
+ dTHX;
+
+
+#ifdef USE_LOCALE_NUMERIC
+
+ /* A NULL locale means only query what the current one is. We
+ * have the LC_NUMERIC name saved, because we are normally switched
+ * into the C locale for it. Switch back so an LC_ALL query will yield
+ * the correct results; all other categories don't require special
+ * handling */
+ if (locale == NULL) {
+ if (category == LC_NUMERIC) {
+ return savepv(PL_numeric_name);
+ }
+
+# ifdef LC_ALL
+
+ else if (category == LC_ALL) {
+ SET_NUMERIC_UNDERLYING();
+ }
+
+# endif
+
+ }
+
+#endif
+
+ retval = my_setlocale(category, locale);
+
+ 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();
+ }
+ return NULL;
+ }
+
+ /* Save retval since subsequent setlocale() calls may overwrite it. */
+ retval = savepv(retval);
+
+ /* If locale == NULL, we are just querying the state, but may have switched
+ * to NUMERIC_UNDERLYING. Switch back before returning. */
+ if (locale == NULL) {
+ SET_NUMERIC_STANDARD();
+ return retval;
+ }
+ else { /* Now that have switched locales, we have to update our records to
+ correspond */
+
+#ifdef USE_LOCALE_CTYPE
+
+ if ( category == LC_CTYPE
+
+# ifdef LC_ALL
+
+ || category == LC_ALL
+
+# endif
+
+ )
+ {
+ char *newctype;
+
+# ifdef LC_ALL
+
+ if (category == LC_ALL) {
+ newctype = setlocale(LC_CTYPE, NULL);
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ setlocale_debug_string(LC_CTYPE, NULL, newctype)));
+ }
+ else
+
+# endif
+
+ newctype = retval;
+ new_ctype(newctype);
+ }
+
+#endif /* USE_LOCALE_CTYPE */
+
+#ifdef USE_LOCALE_COLLATE
+
+ if ( category == LC_COLLATE
+
+# ifdef LC_ALL
+
+ || category == LC_ALL
+
+# endif
+
+ )
+ {
+ char *newcoll;
+
+# ifdef LC_ALL
+
+ if (category == LC_ALL) {
+ newcoll = setlocale(LC_COLLATE, NULL);
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ setlocale_debug_string(LC_COLLATE, NULL, newcoll)));
+ }
+ else
+
+# endif
+
+ newcoll = retval;
+ new_collate(newcoll);
+ }
+
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+
+ if ( category == LC_NUMERIC
+
+# ifdef LC_ALL
+
+ || category == LC_ALL
+
+# endif
+
+ )
+ {
+ char *newnum;
+
+# ifdef LC_ALL
+
+ if (category == LC_ALL) {
+ newnum = setlocale(LC_NUMERIC, NULL);
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: %s\n", __FILE__, __LINE__,
+ setlocale_debug_string(LC_NUMERIC, NULL, newnum)));
+ }
+ else
+
+# endif
+
+ newnum = retval;
+ new_numeric(newnum);
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+
+ }
+
+ return retval;
+
+}
/*
* Initialize locale awareness.
@@ -971,7 +1135,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
PerlIO_printf(Perl_debug_log, \
"%s:%d: %s\n", \
__FILE__, __LINE__, \
- _setlocale_debug_string(category, \
+ setlocale_debug_string(category, \
locale, \
result)); \
} \
@@ -2711,8 +2875,8 @@ Perl_sync_locale(pTHX)
#if defined(DEBUGGING) && defined(USE_LOCALE)
-char *
-Perl__setlocale_debug_string(const int category, /* category number,
+STATIC char *
+S_setlocale_debug_string(const int category, /* category number,
like LC_ALL */
const char* const locale, /* locale name */
diff --git a/perl.h b/perl.h
index 88c0a3f24a..07fda9cbc0 100644
--- a/perl.h
+++ b/perl.h
@@ -761,9 +761,6 @@
# if !defined(NO_LOCALE_TIME) && defined(LC_TIME)
# define USE_LOCALE_TIME
# 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>
@@ -5955,7 +5952,7 @@ typedef struct am_table_short AMTS;
# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE \
STMT_START { \
if (UNLIKELY(PL_warn_locale)) { \
- _warn_problematic_locale(); \
+ Perl__warn_problematic_locale(); \
} \
} STMT_END
# else
@@ -6139,7 +6136,7 @@ expression, but with an empty argument list, like this:
#define STORE_LC_NUMERIC_SET_TO_NEEDED() \
if (IN_LC(LC_NUMERIC)) { \
if (_NOT_IN_NUMERIC_UNDERLYING) { \
- set_numeric_local(); \
+ Perl_set_numeric_local(aTHX); \
_restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \
} \
} \
@@ -6158,31 +6155,32 @@ expression, but with an empty argument list, like this:
/* The next two macros set unconditionally. These should be rarely used, and
* only after being sure that this is what is needed */
#define SET_NUMERIC_STANDARD() \
- STMT_START { if (_NOT_IN_NUMERIC_STANDARD) set_numeric_standard(); \
- } STMT_END
+ STMT_START { if (_NOT_IN_NUMERIC_STANDARD) \
+ Perl_set_numeric_standard(aTHX); \
+ } STMT_END
#define SET_NUMERIC_UNDERLYING() \
STMT_START { if (_NOT_IN_NUMERIC_UNDERLYING) \
- set_numeric_local(); } STMT_END
+ Perl_set_numeric_local(aTHX); } STMT_END
/* The rest of these LC_NUMERIC macros toggle to one or the other state, with
* the RESTORE_foo ones called to switch back, but only if need be */
#define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD() \
bool _was_local = _NOT_IN_NUMERIC_STANDARD; \
- if (_was_local) set_numeric_standard();
+ if (_was_local) Perl_set_numeric_standard(aTHX);
/* Doesn't change to underlying locale unless within the scope of some form of
* 'use locale'. This is the usual desired behavior. */
#define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING() \
bool _was_standard = _NOT_IN_NUMERIC_UNDERLYING \
&& IN_LC(LC_NUMERIC); \
- if (_was_standard) set_numeric_local();
+ if (_was_standard) Perl_set_numeric_local(aTHX);
/* Rarely, we want to change to the underlying locale even outside of 'use
* locale'. This is principally in the POSIX:: functions */
#define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \
if (_NOT_IN_NUMERIC_UNDERLYING) { \
- set_numeric_local(); \
+ Perl_set_numeric_local(aTHX); \
_restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \
}
@@ -6202,7 +6200,7 @@ expression, but with an empty argument list, like this:
} STMT_END
#define RESTORE_LC_NUMERIC_UNDERLYING() \
- if (_was_local) set_numeric_local();
+ if (_was_local) Perl_set_numeric_local(aTHX);
#define RESTORE_LC_NUMERIC_STANDARD() \
if (_restore_LC_NUMERIC_function) { \
diff --git a/proto.h b/proto.h
index 3299497f23..d6df7f4274 100644
--- a/proto.h
+++ b/proto.h
@@ -2363,10 +2363,6 @@ PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const
char *name, XSUBADDR_t subaddr,
PERL_CALLCONV CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN
len, XSUBADDR_t subaddr, const char *const filename, const char *const proto,
SV **const_svp, U32 flags);
#define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS \
assert(subaddr)
-PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll);
-PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype);
-#define PERL_ARGS_ASSERT_NEW_CTYPE \
- assert(newctype)
PERL_CALLCONV void Perl_new_numeric(pTHX_ const char* newcoll);
PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
__attribute__warn_unused_result__;
@@ -2915,11 +2911,11 @@ PERL_CALLCONV void Perl_set_context(void *t);
#define PERL_ARGS_ASSERT_SET_CONTEXT \
assert(t)
PERL_CALLCONV void Perl_set_numeric_local(pTHX);
-PERL_CALLCONV void Perl_set_numeric_radix(pTHX);
PERL_CALLCONV void Perl_set_numeric_standard(pTHX);
PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv);
#define PERL_ARGS_ASSERT_SETDEFOUT \
assert(gv)
+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)
@@ -3803,9 +3799,6 @@ PERL_CALLCONV void* Perl_my_cxt_init(pTHX_ int
*index, size_t size);
assert(index)
# endif
#endif
-#if !(defined(WIN32))
-/* PERL_CALLCONV char* my_setlocale(pTHX_ int category, const char* locale); */
-#endif
#if !(defined(_MSC_VER))
PERL_CALLCONV_NO_RET int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
__attribute__noreturn__;
@@ -4176,11 +4169,6 @@ STATIC int S_tokereport(pTHX_ I32 rv, const
YYSTYPE* lvalp);
#define PERL_ARGS_ASSERT_TOKEREPORT \
assert(lvalp)
# endif
-# if defined(USE_LOCALE) && (defined(PERL_IN_LOCALE_C) || defined
(PERL_EXT_POSIX))
-PERL_CALLCONV char * Perl__setlocale_debug_string(const int category, const
char* const locale, const char* const retval)
- __attribute__warn_unused_result__;
-
-# endif
# if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
STATIC void S_print_bytes_for_locale(pTHX_ const char * const s, const char
* const e, const bool is_utf8);
#define PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE \
@@ -4188,6 +4176,9 @@ STATIC void S_print_bytes_for_locale(pTHX_ const
char * const s, const char * co
STATIC void S_print_collxfrm_input_and_return(pTHX_ const char * const s,
const char * const e, const STRLEN * const xlen, const bool is_utf8);
#define PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN \
assert(s); assert(e)
+STATIC char * S_setlocale_debug_string(const int category, const char* const
locale, const char* const retval)
+ __attribute__warn_unused_result__;
+
# endif
#endif
#if defined(DEBUGGING) && defined(ENABLE_REGEX_SETS_DEBUGGING)
@@ -6058,9 +6049,17 @@ PERL_CALLCONV SV* Perl_sv_dup_inc(pTHX_ const SV
*const sstr, CLONE_PARAMS *cons
PERL_CALLCONV bool Perl__is_cur_LC_category_utf8(pTHX_ int category);
#endif
#if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
+STATIC void S_new_collate(pTHX_ const char* newcoll);
+STATIC void S_new_ctype(pTHX_ const char* newctype);
+#define PERL_ARGS_ASSERT_NEW_CTYPE \
+ assert(newctype)
+STATIC void S_set_numeric_radix(pTHX);
STATIC char* S_stdize_locale(pTHX_ char* locs);
#define PERL_ARGS_ASSERT_STDIZE_LOCALE \
assert(locs)
+# if defined(WIN32)
+STATIC char* S_my_setlocale(pTHX_ int category, const char* locale);
+# endif
#endif
#if defined(USE_LOCALE_COLLATE)
PERL_CALLCONV int Perl_magic_setcollxfrm(pTHX_ SV* sv, MAGIC* mg);
@@ -6127,7 +6126,6 @@ PERL_CALLCONV const char*
Perl_quadmath_format_single(const char* format);
assert(format)
#endif
#if defined(WIN32)
-PERL_CALLCONV char* Perl_my_setlocale(pTHX_ int category, const char*
locale);
PERL_CALLCONV_NO_RET void win32_croak_not_implemented(const char * fname)
__attribute__noreturn__;
#define PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED \
--
Perl5 Master Repository
