From 261850f296c4637b9bcf7a467d8c61ea39bb8c8e Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Thu, 6 Jul 2023 19:46:48 -0600 Subject: [PATCH] loc_tools: XXX Debug --- t/loc_tools.pl | 63 ++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 59 insertions(+), 4 deletions(-) diff --git a/t/loc_tools.pl b/t/loc_tools.pl index d8bef1a745b6..80bc59a0b65b 100644 --- a/t/loc_tools.pl +++ b/t/loc_tools.pl @@ -1,4 +1,5 @@ # Common tools for test files to find the locales which exist on the +#23456789112345678921234567893123456789412345678951234567896123456789712345678981 # system. Caller should have verified that this isn't miniperl before calling # the functions. @@ -29,7 +30,17 @@ LC_TOD LC_NAME)); my @platform_categories; +my $debug; +BEGIN { $debug = 0; } +#$debug = 1 if $^O =~ / MSWin32 /xi; #| darwin /xi; +#$debug = 1 if $^O =~ /cygwin /xi; #| darwin /xi; # or $^O =~ /MSWin32/i; +my $save_D = $^D; +#local $^D = $save_D if $debug; +#my $d = $^D; +#$d |= (0x04000000|0x00100000) if $debug; + my $has_excluded_category = $Config{ccflags} =~ /\bD?NO_LOCALE_/; + sub category_excluded($) { my $cat_name = shift =~ s/^LC_//r; @@ -153,10 +164,12 @@ ($$$$) # The 4th parameter is true if to accept locales that aren't apparently # fully compatible with Perl. + #print STDERR "#", __FILE__, ": ", __LINE__, ": Entering _trylocale:", Dumper @_ if $debug; my $locale = shift; my $categories = shift; my $list = shift; my $allow_incompatible = shift; + print STDERR "#", __FILE__, ": ", __LINE__, ": Current state=", setlocale(&LC_ALL), "\n" if $debug; my $normalized_locale = lc ($locale =~ s/\W//gr); return if ! $locale || grep { $normalized_locale eq lc ($_ =~ s/\W//gr) } @$list; @@ -193,6 +206,7 @@ ($$$$) /The following characters .* may not have the same meaning as the Perl program expects(?# )|The Perl program will use the expected meanings/i } @_; + print STDERR "#", __FILE__, ": ", __LINE__, ": @_\n" if $debug; }; my $result; @@ -209,18 +223,24 @@ ($$$$) } foreach my $category (@category_list) { + print STDERR "#", __FILE__, ": ", __LINE__, ": Calling setlocale($category) to get save_locale\n" if $debug; my $save_locale = setlocale($category); if (! $save_locale) { _my_fail("Verify could save previous locale"); return; } + print STDERR "#", __FILE__, ": ", __LINE__, ": save_locale='$save_locale'\n" if $debug; # Incompatible locales aren't warned about unless using locales. use locale; + #local $^D = $d; + print STDERR "#", __FILE__, ": ", __LINE__, ": Calling setlocale($category, $locale)\n" if $debug; my $cur_result = setlocale($category, $locale); + print STDERR "#", __FILE__, ": ", __LINE__, ": undef\n" if $debug && ! defined $cur_result; return unless defined $cur_result; + #$^D = $save_D; no locale; if ( $gathering_platform_locales @@ -231,8 +251,11 @@ ($$$$) $seen{$locale}++; } + print STDERR "#", __FILE__, ": ", __LINE__, ": setlocale($category, $locale) yields '$cur_result'\n" if $debug; + # We definitely don't want the locale set to something that is # unsupported + print STDERR "#", __FILE__, ": ", __LINE__, ": Restoring by calling setlocale($category, $save_locale)\n" if $debug; if (! setlocale($category, $save_locale)) { my $error_text = "\$!=$!"; $error_text .= "; \$^E=$^E" if $^E != $!; @@ -254,7 +277,7 @@ ($$$$) return unless $plays_well || $allow_incompatible; if (! defined $result) { # First time - + #print STDERR __FILE__, ": ", __LINE__, ": cat=$category; m=$master_category; LC_ALL=$category_number{'ALL'}\n"; # If the name returned as $cur_result by the setlocale() above is the # same as we requested, there are no complications: use that. if ($locale eq $cur_result) { @@ -286,6 +309,7 @@ ($$$$) if (! ( ($result eq "C" && $cur_result eq "POSIX") || ($result eq "POSIX" && $cur_result eq "C"))) { + print STDERR "#", __FILE__, ": ", __LINE__, ": '$result' ne '$cur_result\n"; # But otherwise if the new result for this category doesn't # match what we already have for a previous category for this # same input locale, it's problematic, so discard this whole @@ -295,6 +319,7 @@ ($$$$) } } + print STDERR '#', __FILE__, ": ", __LINE__, ": Adding $locale (via $result) to list\n" if $debug; push @$list, $result; } @@ -329,13 +354,13 @@ sub _decode_encodings { # For use only by other functions in this file! sub locales_enabled(;$) { # If no parameter is specified, the function returns 1 if there is any # "safe" locale handling available to the caller; otherwise 0. Safeness - # is defined here as the caller operating in the main thread of a program, + # XXX is defined here as the caller operating in the main thread of a program, # or if threaded locales are safe on the platform and Configured to be # used. This sub is used for testing purposes, and for those, this # definition of safety is sufficient, and necessary to get some tests to # run on certain configurations on certain platforms. But beware that the # main thread can change the locale of any subthreads unless - # ${^SAFE_LOCALES} is non-zero. + # XXX ${^SAFE_LOCALES} is non-zero. # # Use the optional parameter to discover if a particular category or # categories are available on the system. 1 is returned if the global @@ -364,6 +389,9 @@ (;$) # normally would be available return 0 if ! defined &DynaLoader::boot_DynaLoader; + # Don't test locales where they aren't at all safe. + #return 0 if $Config{ccflags} =~ /\bD?NO_THREAD_SAFE_LOCALE_EMULATION\b/; + # Don't test locales where they aren't safe. On systems with unsafe # threads, for the purposes of testing, we consider the main thread safe, # and all other threads unsafe. @@ -481,7 +509,6 @@ ($;$) # a list of categories to find valid locales for it (or in the case of # multiple) for all of them. Each category can be a name (like 'LC_ALL' # or simply 'ALL') or the C enum value for the category. - my $input_categories = shift; my $allow_incompatible = shift // 0; @@ -490,7 +517,10 @@ ($;$) my @categories = (ref $input_categories) ? $input_categories->@* : $input_categories; + #print STDERR "#", __FILE__, ": ", __LINE__, ": ", "finding\n", Dumper \@categories if $debug; return unless locales_enabled(\@categories); + print STDERR "#", __FILE__, ": ", __LINE__, ": ", + "enabled, (allow incompat=$allow_incompatible)\n" if $debug; # Note, the subroutine call above converts the $categories into a form # suitable for _trylocale(). @@ -507,6 +537,8 @@ ($;$) my @Locale; if (@platform_locales) { + use Data::Dumper; + #print STDERR __FILE__, ": ", __LINE__, ": ", Dumper \@platform_locales; $gathering_platform_locales = 0; foreach my $locale (@platform_locales) { _trylocale($locale, \@categories, \@Locale, $allow_incompatible); @@ -528,6 +560,7 @@ ($;$) if defined $Config{d_setlocale_accepts_any_locale_name}; foreach (1..16) { + #print STDERR "#", __FILE__, ": ", __LINE__, ": ", "foreach\n"; _trylocale("ISO8859-$_", \@categories, \@Locale, $allow_incompatible); _trylocale("iso8859$_", \@categories, \@Locale, @@ -664,6 +697,7 @@ ($;$) @Locale = sort @Locale; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "returning \n" if $debug; return @Locale; } @@ -676,20 +710,29 @@ ($) return 0 unless locales_enabled('LC_CTYPE'); my $locale = shift; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", + "is_locale_utf8: $locale\n" if $debug; no warnings 'locale'; # We may be trying out a weird locale use locale; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "is_locale_utf8: $locale\n" if $debug; my $save_locale = setlocale(&POSIX::LC_CTYPE()); + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "is_locale_utf8: $locale, saved=$save_locale\n" if $debug; if (! $save_locale) { _my_fail("Verify could save previous locale"); return 0; } + #local $^D = $d; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "is_locale_utf8: $locale\n" if $debug; + if (! setlocale(&POSIX::LC_CTYPE(), $locale)) { _my_fail("Verify could setlocale to $locale"); return 0; } + #$^D = $save_D; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "is_locale_utf8: $locale\n" if $debug; my $ret = 0; @@ -698,6 +741,7 @@ ($) # most platforms with UTF-8 in its name, so if there is a bug in the op # giving a false negative, we should get a failure for those locales as we # go through testing all the locales on the platform. + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "is_locale_utf8: $locale\n" if $debug; if (CORE::fc(chr utf8::unicode_to_native(0xdf)) ne "ss") { if ($locale =~ /UTF-?8/i) { _my_fail("Verify $locale with UTF-8 in name is a UTF-8 locale"); @@ -706,6 +750,7 @@ ($) else { $ret = 1; } + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "is_locale_utf8: $locale\n" if $debug; die "Couldn't restore locale '$save_locale'" unless setlocale(&POSIX::LC_CTYPE(), $save_locale); @@ -745,8 +790,10 @@ (;$) my $locales_ref = shift; if (! defined $locales_ref) { + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_ctype_locales:\n" if $debug; my @locales = find_locales(&POSIX::LC_CTYPE()); $locales_ref = \@locales; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_ctype_locales:\n" if $debug; } my ($utf8_ref, undef) = classify_locales_wrt_utf8ness($locales_ref); @@ -763,6 +810,8 @@ (;$) # platform my $try_locales_ref = shift; + #$debug = 1; + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_ctype_locale:\n" if $debug; my @utf8_locales = find_utf8_ctype_locales($try_locales_ref); my @turkic_locales = find_utf8_turkic_locales($try_locales_ref); @@ -775,6 +824,7 @@ (;$) return $locale unless exists $seen_turkic{$locale}; } + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_ctype_locale:\n" if $debug; return; } @@ -788,15 +838,20 @@ (;$) return unless locales_enabled('LC_CTYPE'); + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_turkic_locales:\n" if $debug; my $save_locale = setlocale(&POSIX::LC_CTYPE()); + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_turkic_locales, saved=$save_locale\n" if $debug; foreach my $locale (find_utf8_ctype_locales(shift)) { use locale; + #local $^D = $d; setlocale(&POSIX::LC_CTYPE(), $locale); + #$^D = $save_D; push @return, $locale if uc('i') eq "\x{130}"; } die "Couldn't restore locale '$save_locale'" unless setlocale(&POSIX::LC_CTYPE(), $save_locale); + print STDERR "#", __FILE__, ": ", __LINE__, ": ", "find_utf8_turkic_locales: save=$save_locale\n" if $debug; return @return; }