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.

diff --git a/embed.fnc b/embed.fnc
index 7c6710a..5c0a89e 100644 (file)
--- 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 608d252..5439de8 100644 (file)
--- 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 da8d10e..06fcfa6 100644 (file)
--- 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 258542a..7628b0c 100644 (file)
--- 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 ea16408..3299497 100644 (file)
--- 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)