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
ApM |bool |_is_in_locale_category|const bool compiling|const int category
Apd |void |sync_locale
#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 \
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
#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 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)
#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
#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)
# 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)
#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)
# 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)
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
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.76';
+our $VERSION = '1.77';
require XSLoader;
#endif
-void
-Perl_set_numeric_radix(pTHX)
+STATIC void
+S_set_numeric_radix(pTHX)
{
#ifdef USE_LOCALE_NUMERIC
# ifdef HAS_LOCALECONV
/*
* 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
}
-void
-Perl_new_collate(pTHX_ const char *newcoll)
+STATIC void
+S_new_collate(pTHX_ const char *newcoll)
{
#ifdef USE_LOCALE_COLLATE
#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
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;
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
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
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
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
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
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.
PerlIO_printf(Perl_debug_log, \
"%s:%d: %s\n", \
__FILE__, __LINE__, \
- _setlocale_debug_string(category, \
+ setlocale_debug_string(category, \
locale, \
result)); \
} \
#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 */
# 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>
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__;
#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)
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__;
#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 \
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)
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);
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 \