In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/9c8a6dc2b06f6e6fe87aaae5c0aeccc13551c2a4?hp=0c880285bc6c49738f19600d07f9c86398cb1f67>
- Log ----------------------------------------------------------------- commit 9c8a6dc2b06f6e6fe87aaae5c0aeccc13551c2a4 Author: Karl Williamson <[email protected]> Date: Fri Jul 14 13:56:44 2017 -0600 Add debugging to locale handling These debug statements have proven useful in the past tracking down problems. I looked them over and kept the ones that I though might be useful in the future. This includes extracting some code into a static function so it can be called from more than one place. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 3 +++ embed.h | 1 + lib/locale.t | 3 +++ locale.c | 51 +++++++++++++++++++++++++++++++++++++++++++++------ proto.h | 3 +++ 5 files changed, 55 insertions(+), 6 deletions(-) diff --git a/embed.fnc b/embed.fnc index 7c6710a4fd..5c0a89e9de 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2728,6 +2728,9 @@ s |void |print_collxfrm_input_and_return \ |NN const char * const e \ |NULLOK const STRLEN * const xlen \ |const bool is_utf8 +s |void |print_bytes_for_locale |NN const char * const s \ + |NN const char * const e \ + |const bool is_utf8 # endif #endif diff --git a/embed.h b/embed.h index 608d252e54..5439de8c0b 100644 --- a/embed.h +++ b/embed.h @@ -1494,6 +1494,7 @@ #define tokereport(a,b) S_tokereport(aTHX_ a,b) # endif # 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) # endif # endif diff --git a/lib/locale.t b/lib/locale.t index da8d10ecb0..06fcfa6f77 100644 --- a/lib/locale.t +++ b/lib/locale.t @@ -755,7 +755,9 @@ debug "Scanning for locales...\n"; require POSIX; import POSIX ':locale_h'; my $categories = [ 'LC_CTYPE', 'LC_NUMERIC', 'LC_ALL' ]; +debug "Scanning for just compatible"; my @Locale = find_locales($categories); +debug "Scanning for even incompatible"; my @include_incompatible_locales = find_locales($categories, 'even incompatible locales'); @@ -783,6 +785,7 @@ if (@Locale < @include_incompatible_locales) { push @warnings, ($warning =~ s/\n/\n# /sgr); }; + debug "Trying incompatible $bad_locale"; my $ret = setlocale(&POSIX::LC_CTYPE, $bad_locale); my $message = "testing of locale '$bad_locale' is skipped"; diff --git a/locale.c b/locale.c index 258542aac7..7628b0cd53 100644 --- a/locale.c +++ b/locale.c @@ -388,6 +388,10 @@ Perl_new_ctype(pTHX_ const char *newctype) /* We only handle single-byte locales (outside of UTF-8 ones; so if * this locale requires more than one byte, there are going to be * problems. */ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: check_for_problems=%d, MB_CUR_MAX=%d\n", + __FILE__, __LINE__, check_for_problems, (int) MB_CUR_MAX)); + if (check_for_problems && MB_CUR_MAX > 1 /* Some platforms return MB_CUR_MAX > 1 for even the "C" @@ -1949,9 +1953,6 @@ S_print_collxfrm_input_and_return(pTHX_ const STRLEN * const xlen, const bool is_utf8) { - const char * t = s; - bool prev_was_printable = TRUE; - bool first_time = TRUE; PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN; @@ -1965,6 +1966,22 @@ S_print_collxfrm_input_and_return(pTHX_ } PerlIO_printf(Perl_debug_log, " for locale '%s', string='", PL_collation_name); + print_bytes_for_locale(s, e, is_utf8); + + PerlIO_printf(Perl_debug_log, "'\n"); +} + +STATIC void +S_print_bytes_for_locale(pTHX_ + const char * const s, + const char * const e, + const bool is_utf8) +{ + const char * t = s; + bool prev_was_printable = TRUE; + bool first_time = TRUE; + + PERL_ARGS_ASSERT_PRINT_BYTES_FOR_LOCALE; while (t < e) { UV cp = (is_utf8) @@ -1987,8 +2004,6 @@ S_print_collxfrm_input_and_return(pTHX_ t += (is_utf8) ? UTF8SKIP(t) : 1; first_time = FALSE; } - - PerlIO_printf(Perl_debug_log, "'\n"); } #endif /* #ifdef DEBUGGING */ @@ -2557,15 +2572,24 @@ Perl_my_strerror(pTHX_ const int errnum) # endif + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "my_strerror called with errnum %d\n", errnum)); if (! within_locale_scope) { errno = 0; # ifdef USE_THREAD_SAFE_LOCALE /* Use the thread-safe locale functions */ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "Not within locale scope, about to call" + " uselocale(0x%p)\n", PL_C_locale_obj)); save_locale = uselocale(PL_C_locale_obj); if (! save_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, - "uselocale failed, errno=%d\n", errno)); + "uselocale failed, errno=%d\n", errno)); + } + else { + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "uselocale returned 0x%p\n", save_locale)); } # else /* Not thread-safe build */ @@ -2591,11 +2615,23 @@ Perl_my_strerror(pTHX_ const int errnum) # endif } /* end of ! within_locale_scope */ + else { + DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: WITHIN locale scope\n", + __FILE__, __LINE__)); + } #endif + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "Any locale change has been done; about to call Strerror\n")); errstr = Strerror(errnum); if (errstr) { + if (DEBUG_Lv_TEST) { + PerlIO_printf(Perl_debug_log, "Strerror returned; saving a copy: '"); + print_bytes_for_locale(errstr, errstr + strlen(errstr), 0); + PerlIO_printf(Perl_debug_log, "'\n"); + } + errstr = savepv(errstr); SAVEFREEPV(errstr); } @@ -2607,6 +2643,9 @@ Perl_my_strerror(pTHX_ const int errnum) # ifdef USE_THREAD_SAFE_LOCALE + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s: %d: not within locale scope, restoring the locale\n", + __FILE__, __LINE__)); if (save_locale && ! uselocale(save_locale)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "uselocale restore failed, errno=%d\n", errno)); diff --git a/proto.h b/proto.h index ea16408398..3299497f23 100644 --- a/proto.h +++ b/proto.h @@ -4182,6 +4182,9 @@ PERL_CALLCONV char * Perl__setlocale_debug_string(const int category, const char # 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 \ + assert(s); assert(e) 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) -- Perl5 Master Repository
