use strict;
use feature 'fc';
+# =1 adds debugging output; =2 increases the verbosity somewhat
my $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
# Certain tests have been shown to be problematical for a few locales. Don't
# (There aren't 1000 locales currently in existence, so 99.9 works)
my $acceptable_fold_failure_percentage = $^O eq 'MSWin32' ? 99.9 : 5;
+# The list of test numbers of the problematic tests.
+my @problematical_tests;
+
+
use Dumpvalue;
my $dumper = Dumpvalue->new(
print $dumper->stringify($mess,1), "\n";
}
+sub debug_more {
+ return unless $debug > 1;
+ return debug(@_);
+}
+
sub debugf {
printf @_ if $debug;
}
check_taint_not $a;
+"a" =~ /([a-z])/;
+check_taint_not $1, '"a" =~ /([a-z])/';
+"foo.bar_baz" =~ /^(.*)[._](.*?)$/; # Bug 120675
+check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
+
+# BE SURE TO COPY ANYTHING YOU ADD to the block below
+
{ # This is just the previous tests copied here with a different
# compile-time pragma.
# After all this tainting $a should be cool.
check_taint_not $a;
+
+ "a" =~ /([a-z])/;
+ check_taint_not $1, '"a" =~ /([a-z])/';
+ "foo.bar_baz" =~ /^(.*)[._](.*?)$/; # Bug 120675
+ check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
}
# Here are in scope of 'use locale'
my @Added_alpha; # Alphas that aren't in the C locale.
my %test_names;
-sub display_characters {
+sub disp_chars {
# This returns a display string denoting the input parameter @_, each
# entry of which is a single character in the range 0-255. The first part
# of the output is a string of the characters in @_ that are ASCII
no locale;
my @chars = sort { ord $a <=> ord $b } @_;
my $output = "";
- my $hex = "";
my $range_start;
my $start_class;
push @chars, chr(258); # This sentinel simplifies the loop termination
elsif ($char =~ /[0-9]/) {
$class = 4;
}
- elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
- $class = -1; # Punct never appears in a range
- }
+ # Uncomment to get literal punctuation displayed instead of hex
+ #elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
+ # $class = -1; # Punct never appears in a range
+ #}
else {
$class = 0; # Output in hex
}
if (! defined $range_start) {
if ($class < 0) {
- $output .= $char;
+ $output .= " " . $char;
}
else {
$range_start = ord $char;
$output .= "-" . chr($range_end) if $range_length > 1;
}
else {
- $hex .= sprintf(" %02X", $range_start);
- $hex .= sprintf("-%02X", $range_end) if $range_length > 1;
+ $output .= sprintf(" %02X", $range_start);
+ $output .= sprintf("-%02X", $range_end) if $range_length > 1;
}
# Handle the new current character, as potentially beginning a new
}
$output =~ s/^ //;
- $hex =~ s/^ // if ! length $output;
- return "$output$hex";
+ return $output;
}
sub report_result {
my $message = "";
if (@$results_ref) {
- $message = join " ", "for", display_characters(@$results_ref);
+ $message = join " ", "for", disp_chars(@$results_ref);
}
report_result($Locale, $i, @$results_ref == 0, $message);
}
my $locales_test_number;
my $not_necessarily_a_problem_test_number;
my $first_casing_test_number;
-my $final_casing_test_number;
my %setlocale_failed; # List of locales that setlocale() didn't work on
foreach $Locale (@Locale) {
$locales_test_number = $first_locales_test_number - 1;
+ debug "#\n";
debug "# Locale = $Locale\n";
unless (setlocale(&POSIX::LC_ALL, $Locale)) {
@{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
@{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
@{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
+ @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
@{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
@{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
@{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
@{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
@{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
@{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
+ @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
@{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
@{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
@{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
# Ordered, where possible, in groups of "this is a subset of the next
# one"
- debug "# :upper: = ", display_characters(@{$posixes{'upper'}}), "\n";
- debug "# :lower: = ", display_characters(@{$posixes{'lower'}}), "\n";
- debug "# :cased: = ", display_characters(@{$posixes{'cased'}}), "\n";
- debug "# :alpha: = ", display_characters(@{$posixes{'alpha'}}), "\n";
- debug "# :alnum: = ", display_characters(@{$posixes{'alnum'}}), "\n";
- debug "# w = ", display_characters(@{$posixes{'word'}}), "\n";
- debug "# :graph: = ", display_characters(@{$posixes{'graph'}}), "\n";
- debug "# :print: = ", display_characters(@{$posixes{'print'}}), "\n";
- debug "# d = ", display_characters(@{$posixes{'digit'}}), "\n";
- debug "# :xdigit: = ", display_characters(@{$posixes{'xdigit'}}), "\n";
- debug "# :blank: = ", display_characters(@{$posixes{'blank'}}), "\n";
- debug "# s = ", display_characters(@{$posixes{'space'}}), "\n";
- debug "# :cntrl: = ", display_characters(@{$posixes{'cntrl'}}), "\n";
- debug "# :ascii: = ", display_characters(@{$posixes{'ascii'}}), "\n";
+ debug "# :upper: = ", disp_chars(@{$posixes{'upper'}}), "\n";
+ debug "# :lower: = ", disp_chars(@{$posixes{'lower'}}), "\n";
+ debug "# :cased: = ", disp_chars(@{$posixes{'cased'}}), "\n";
+ debug "# :alpha: = ", disp_chars(@{$posixes{'alpha'}}), "\n";
+ debug "# :alnum: = ", disp_chars(@{$posixes{'alnum'}}), "\n";
+ debug "# w = ", disp_chars(@{$posixes{'word'}}), "\n";
+ debug "# :graph: = ", disp_chars(@{$posixes{'graph'}}), "\n";
+ debug "# :print: = ", disp_chars(@{$posixes{'print'}}), "\n";
+ debug "# d = ", disp_chars(@{$posixes{'digit'}}), "\n";
+ debug "# :xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
+ debug "# :blank: = ", disp_chars(@{$posixes{'blank'}}), "\n";
+ debug "# s = ", disp_chars(@{$posixes{'space'}}), "\n";
+ debug "# :punct: = ", disp_chars(@{$posixes{'punct'}}), "\n";
+ debug "# :cntrl: = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
+ debug "# :ascii: = ", disp_chars(@{$posixes{'ascii'}}), "\n";
foreach (keys %UPPER) {
delete $lower{$_};
}
- debug "# UPPER = ", display_characters(keys %UPPER), "\n";
- debug "# lower = ", display_characters(keys %lower), "\n";
- debug "# BoThCaSe = ", display_characters(keys %BoThCaSe), "\n";
+ my %Unassigned;
+ foreach my $ord ( 0 .. 255 ) {
+ $Unassigned{chr $ord} = 1;
+ }
+ foreach my $class (keys %posixes) {
+ foreach my $char (@{$posixes{$class}}) {
+ delete $Unassigned{$char};
+ }
+ }
+
+ debug "# UPPER = ", disp_chars(keys %UPPER), "\n";
+ debug "# lower = ", disp_chars(keys %lower), "\n";
+ debug "# BoThCaSe = ", disp_chars(keys %BoThCaSe), "\n";
+ debug "# Unassigned = ", disp_chars(sort { ord $a <=> ord $b } keys %Unassigned), "\n";
my @failures;
my @fold_failures;
@Added_alpha = sort @Added_alpha;
- debug "# Added_alpha = ", display_characters(@Added_alpha), "\n";
+ debug "# Added_alpha = ", disp_chars(@Added_alpha), "\n";
# Cross-check the whole 8-bit character set.
# The rules for the relationships are given in:
# http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
+
+ ++$locales_test_number;
+ undef @f;
+ $test_names{$locales_test_number} = 'Verify that [:lower:] contains at least a-z';
+ for ('a' .. 'z') {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ unless /[[:lower:]]/;
+ }
+ else {
+ push @f, $_ unless /[[:lower:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
++$locales_test_number;
undef @f;
$test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
++$locales_test_number;
undef @f;
+ $test_names{$locales_test_number} = 'Verify that [:upper:] contains at least A-Z';
+ for ('A' .. 'Z') {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ unless /[[:upper:]]/;
+ }
+ else {
+ push @f, $_ unless /[[:upper:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
$test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
for (map { chr } 0..255) {
if ($is_utf8_locale) {
++$locales_test_number;
undef @f;
+ $test_names{$locales_test_number} = 'Verify that [:digit:] contains at least 0-9';
+ for ('0' .. '9') {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ unless /[[:digit:]]/;
+ }
+ else {
+ push @f, $_ unless /[[:digit:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
$test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
for (map { chr } 0..255) {
if ($is_utf8_locale) {
++$locales_test_number;
undef @f;
- $test_names{$locales_test_number} = 'Verify that [:digit:] (if is 10 code points) is a subset of [:xdigit:]';
- if (@{$posixes{'digit'}} == 10) {
+ $test_names{$locales_test_number} = 'Verify that if there is a second set of digits in [:digit:], they are consecutive';
+ if (@{$posixes{'digit'}} == 20) {
+ my $previous_ord;
for (map { chr } 0..255) {
- if ($is_utf8_locale) {
- use locale ':not_characters';
- push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
- }
- else {
- push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
+ next unless /[[:digit:]]/;
+ next if /[0-9]/;
+ if (defined $previous_ord) {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ if ord $_ != $previous_ord + 1;
+ }
+ else {
+ push @f, $_ if ord $_ != $previous_ord + 1;
+ }
}
+ $previous_ord = ord $_;
}
}
report_multi_result($Locale, $locales_test_number, \@f);
++$locales_test_number;
undef @f;
- $test_names{$locales_test_number} = 'Verify that [:alnum:] is a subset of [:graph:]';
+ $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:xdigit:]';
for (map { chr } 0..255) {
if ($is_utf8_locale) {
use locale ':not_characters';
- push @f, $_ if /[[:alnum:]]/ and ! /[[:graph:]]/;
+ push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
}
else {
- push @f, $_ if /[[:alnum:]]/ and ! /[[:graph:]]/;
+ push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
}
}
report_multi_result($Locale, $locales_test_number, \@f);
- # Note that xdigit doesn't have to be a subset of alnum
+ ++$locales_test_number;
+ undef @f;
+ $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains at least A-F, a-f';
+ for ('A' .. 'F', 'a' .. 'f') {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ unless /[[:xdigit:]]/;
+ }
+ else {
+ push @f, $_ unless /[[:xdigit:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
+ $test_names{$locales_test_number} = 'Verify that any additional members of [:xdigit:], are in groups of 6 consecutive code points';
+ my $previous_ord;
+ my $count = 0;
+ for (map { chr } 0..255) {
+ next unless /[[:xdigit:]]/;
+ next if /[[:digit:]]/;
+ next if /[A-Fa-f]/;
+ if (defined $previous_ord) {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ if ord $_ != $previous_ord + 1;
+ }
+ else {
+ push @f, $_ if ord $_ != $previous_ord + 1;
+ }
+ }
+ $count++;
+ if ($count == 6) {
+ undef $previous_ord;
+ }
+ else {
+ $previous_ord = ord $_;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
++$locales_test_number;
undef @f;
}
report_multi_result($Locale, $locales_test_number, \@f);
+ # Note that xdigit doesn't have to be a subset of alnum
+
++$locales_test_number;
undef @f;
$test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
++$locales_test_number;
undef @f;
+ $test_names{$locales_test_number} = 'Verify that the space character is not in [:graph:]';
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, " " if " " =~ /[[:graph:]]/;
+ }
+ else {
+ push @f, " " if " " =~ /[[:graph:]]/;
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
+ $test_names{$locales_test_number} = 'Verify that [:space:] contains at least [\f\n\r\t\cK ]';
+ for (' ', "\f", "\n", "\r", "\t", "\cK") {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ unless /[[:space:]]/;
+ }
+ else {
+ push @f, $_ unless /[[:space:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
+ $test_names{$locales_test_number} = 'Verify that [:blank:] contains at least [\t ]';
+ for (' ', "\t") {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ unless /[[:blank:]]/;
+ }
+ else {
+ push @f, $_ unless /[[:blank:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
$test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
for (map { chr } 0..255) {
if ($is_utf8_locale) {
++$locales_test_number;
undef @f;
+ $test_names{$locales_test_number} = 'Verify that the space character is in [:print:]';
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, " " if " " !~ /[[:print:]]/;
+ }
+ else {
+ push @f, " " if " " !~ /[[:print:]]/;
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
$test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
for (map { chr } 0..255) {
if ($is_utf8_locale) {
++$locales_test_number;
undef @f;
+ $test_names{$locales_test_number} = 'Verify that isn\'t both [:alpha:] and [:digit:]';
+ for (map { chr } 0..255) {
+ if ($is_utf8_locale) {
+ use locale ':not_characters';
+ push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
+ }
+ else {
+ push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
+ }
+ }
+ report_multi_result($Locale, $locales_test_number, \@f);
+
+ ++$locales_test_number;
+ undef @f;
$test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
for (map { chr } 0..255) {
if ($is_utf8_locale) {
}
report_multi_result($Locale, $locales_test_number, \@f);
- $final_casing_test_number = $locales_test_number;
+ foreach ($first_casing_test_number..$locales_test_number) {
+ push @problematical_tests, $_;
+ }
+
# Test for read-only scalars' locale vs non-locale comparisons.
my $ok14;
my $ok15;
my $ok16;
+ my $ok17;
+ my $ok18;
my $c;
my $d;
my $e;
my $f;
my $g;
+ my $h;
+ my $i;
+ my $j;
if (! $is_utf8_locale) {
use locale;
$f = "1.23";
$g = 2.34;
+ $h = 1.5;
+ $i = 1.25;
+ $j = "$h:$i";
$ok9 = $f == 1.23;
$ok10 = $f == $x;
$ok13 = $w == 0;
$ok14 = $ok15 = $ok16 = 1; # Skip for non-utf8 locales
}
+ {
+ no locale;
+ $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
+ }
+ $ok18 = $j eq sprintf("%g:%g", $h, $i);
}
else {
use locale ':not_characters';
$f = "1.23";
$g = 2.34;
+ $h = 1.5;
+ $i = 1.25;
+ $j = "$h:$i";
$ok9 = $f == 1.23;
$ok10 = $f == $x;
$! = eval "&Errno::$err"; # Convert to strerror() output
my $strerror = "$!";
if ("$strerror" =~ /\P{ASCII}/) {
- my $utf8_strerror = $strerror;
- utf8::upgrade($utf8_strerror);
-
- # If $! was already in UTF-8, the upgrade was a no-op;
- # otherwise they will be different byte strings.
- use bytes;
- $ok14 = $utf8_strerror eq $strerror;
+ $ok14 = utf8::is_utf8($strerror);
last;
}
}
# stringification.
my $string_g = "$g";
+ my $sprintf_g = sprintf("%g", $g);
- my $utf8_string_g = "$g";
- utf8::upgrade($utf8_string_g);
-
- my $utf8_sprintf_g = sprintf("%g", $g);
- utf8::upgrade($utf8_sprintf_g);
- use bytes;
- $ok15 = $utf8_string_g eq $string_g;
- $ok16 = $utf8_sprintf_g eq $string_g;
+ $ok15 = $string_g =~ / ^ \p{ASCII}+ $ /x || utf8::is_utf8($string_g);
+ $ok16 = $sprintf_g eq $string_g;
+ }
+ {
+ no locale;
+ $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
}
+ $ok18 = $j eq sprintf("%g:%g", $h, $i);
}
report_result($Locale, ++$locales_test_number, $ok1);
report_result($Locale, ++$locales_test_number, $ok16);
$test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
+ report_result($Locale, ++$locales_test_number, $ok17);
+ $test_names{$locales_test_number} = 'Verify that a sprintf of a number outside locale scope uses a dot radix';
+
+ report_result($Locale, ++$locales_test_number, $ok18);
+ $test_names{$locales_test_number} = 'Verify that a sprintf of a number back within locale scope uses locale radix';
+
debug "# $first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
# Does taking lc separately differ from taking
if (! $is_utf8_locale) {
my $y = lc $x;
next unless uc $y eq $x;
- print "# UPPER $x lc $y ",
- $x =~ /$y/i ? 1 : 0, " ",
- $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ debug_more( "# UPPER=", disp_chars(($x)),
+ "; lc=", disp_chars(($y)), "; ",
+ "; fc=", disp_chars((fc $x)), "; ",
+ disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
+ $x =~ /$y/i ? 1 : 0,
+ "; ",
+ disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
+ $y =~ /$x/i ? 1 : 0,
+ "\n");
#
# If $x and $y contain regular expression characters
# AND THEY lowercase (/i) to regular expression characters,
print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
next;
}
- # With utf8 both will fail since the locale concept
- # of upper/lower does not work well in Unicode.
- push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
+ push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
# fc is not a locale concept, so Perl uses lc for it.
push @f, $x unless lc $x eq fc $x;
use locale ':not_characters';
my $y = lc $x;
next unless uc $y eq $x;
- print "# UPPER $x lc $y ",
- $x =~ /$y/i ? 1 : 0, " ",
- $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ debug_more( "# UPPER=", disp_chars(($x)),
+ "; lc=", disp_chars(($y)), "; ",
+ "; fc=", disp_chars((fc $x)), "; ",
+ disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
+ $x =~ /$y/i ? 1 : 0,
+ "; ",
+ disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
+ $y =~ /$x/i ? 1 : 0,
+ "\n");
- # Here, we can fully test things, unlike plain 'use locale',
- # because this form does work well with Unicode
push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
# The places where Unicode's lc is different from fc are
if (! $is_utf8_locale) {
my $y = uc $x;
next unless lc $y eq $x;
- print "# lower $x uc $y ",
- $x =~ /$y/i ? 1 : 0, " ",
- $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ debug_more( "# lower=", disp_chars(($x)),
+ "; uc=", disp_chars(($y)), "; ",
+ "; fc=", disp_chars((fc $x)), "; ",
+ disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
+ $x =~ /$y/i ? 1 : 0,
+ "; ",
+ disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
+ $y =~ /$x/i ? 1 : 0,
+ "\n");
if ($x =~ $re || $y =~ $re) { # See above.
print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
next;
}
- # With utf8 both will fail since the locale concept
- # of upper/lower does not work well in Unicode.
- push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
+ push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
push @f, $x unless lc $x eq fc $x;
}
use locale ':not_characters';
my $y = uc $x;
next unless lc $y eq $x;
- print "# lower $x uc $y ",
- $x =~ /$y/i ? 1 : 0, " ",
- $y =~ /$x/i ? 1 : 0, "\n" if 0;
+ debug_more( "# lower=", disp_chars(($x)),
+ "; uc=", disp_chars(($y)), "; ",
+ "; fc=", disp_chars((fc $x)), "; ",
+ disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
+ $x =~ /$y/i ? 1 : 0,
+ "; ",
+ disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
+ $y =~ /$x/i ? 1 : 0,
+ "\n");
push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
push @f, $x unless lc $x eq fc $x;
}
}
report_multi_result($Locale, $locales_test_number, \@f);
+ push @problematical_tests, $locales_test_number;
}
# [perl #109318]
# Recount the errors.
-foreach ($first_locales_test_number..$final_locales_test_number) {
+foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
if (%setlocale_failed) {
print "not ";
}
- elsif ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
+ elsif ($Problem{$test_num} || !defined $Okay{$test_num} || !@{$Okay{$test_num}}) {
if (defined $not_necessarily_a_problem_test_number
- && $_ == $not_necessarily_a_problem_test_number)
+ && $test_num == $not_necessarily_a_problem_test_number)
{
print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
print "# It usually indicates a problem in the environment,\n";
print "# not in Perl itself.\n";
}
- if ($Okay{$_} && ($_ >= $first_casing_test_number
- && $_ <= $final_casing_test_number))
- {
+ if ($Okay{$test_num} && grep { $_ == $test_num } @problematical_tests) {
# Round to nearest .1%
- my $percent_fail = (int(.5 + (1000 * scalar(keys $Problem{$_})
+ my $percent_fail = (int(.5 + (1000 * scalar(keys $Problem{$test_num})
/ scalar(@Locale))))
/ 10;
if (! $debug && $percent_fail < $acceptable_fold_failure_percentage)
{
- $test_names{$_} .= 'TODO';
+ $test_names{$test_num} .= 'TODO';
print "# ", 100 - $percent_fail, "% of locales pass the following test, so it is likely that the failures\n";
print "# are errors in the locale definitions. The test is marked TODO, as the\n";
print "# problem is not likely to be Perl's\n";
print "#\n";
if ($debug) {
print "# The code points that had this failure are given above. Look for lines\n";
- print "# that match 'failed $_'\n";
+ print "# that match 'failed $test_num'\n";
}
else {
print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
- print "# Then look at that output for lines that match 'failed $_'\n";
+ print "# Then look at that output for lines that match 'failed $test_num'\n";
}
print "not ";
}
- print "ok $_";
- if (defined $test_names{$_}) {
+ print "ok $test_num";
+ if (defined $test_names{$test_num}) {
# If TODO is in the test name, make it thus
- my $todo = $test_names{$_} =~ s/TODO\s*//;
- print " $test_names{$_}";
+ my $todo = $test_names{$test_num} =~ s/TODO\s*//;
+ print " $test_names{$test_num}";
print " # TODO" if $todo;
}
print "\n";
$test_num = $final_locales_test_number;
-{ # perl #115808
+unless ( $^O eq 'dragonfly' ) {
+ # perl #115808
use warnings;
my $warned = 0;
local $SIG{__WARN__} = sub {
my $F = join(" ", @F);
$F =~ s/(.{50,60}) /$1\n#\t/g;
+ my $details = "";
+ unless ($debug) {
+ $details = "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
+ }
+ elsif ($debug == 1) {
+ $details = "# For even more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=2.\n";
+ }
+
warn
"# The following locales\n#\n",
"#\t", $F, "\n#\n",
"# had problems.\n#\n",
- "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
+ $details;
} else {
warn "# None of your locales were broken.\n";
}
https://perl5.git.perl.org / perl5.git / blobdiff