Skip to content

Commit

Permalink
35
Browse files Browse the repository at this point in the history
  • Loading branch information
@khwilliamson
khwilliamson committed Apr 20, 2021
1 parent 5eadbf4 commit b8433b9
Show file tree
Hide file tree
Showing 8 changed files with 767 additions and 579 deletions.
86 changes: 76 additions & 10 deletions ext/I18N-Langinfo/t/Langinfo.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,9 @@ my @times = qw( MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7
my @constants = qw(ABDAY_1 DAY_1 ABMON_1 RADIXCHAR AM_STR THOUSEP D_T_FMT
D_FMT T_FMT);
push @constants, @times;
my $debug = ($^O =~ /cygwin | mswin /xi);
local $^D = 0x04000000|0x00100000 if $debug;
my $eval_debug = 'local $^D = 0x04000000|0x00100000;' if $debug;

my %want =
(
Expand All @@ -30,6 +33,65 @@ if ( $Config{osname} !~ / netbsd /ix
$want{MON_1} = "January";
}

sub disp_str ($) {
my $string = shift;

# Displays the string unambiguously. ASCII printables are always output
# as-is, though perhaps separated by blanks from other characters. If
# entirely printable ASCII, just returns the string. Otherwise if valid
# UTF-8 it uses the character names for non-printable-ASCII. Otherwise it
# outputs hex for each non-ASCII-printable byte.

return $string if $string =~ / ^ [[:print:]]* $/xa;

my $result = "";
my $prev_was_punct = 1; # Beginning is considered punct
if (utf8::valid($string) && utf8::is_utf8($string)) {
use charnames ();
foreach my $char (split "", $string) {

# Keep punctuation adjacent to other characters; otherwise
# separate them with a blank
if ($char =~ /[[:punct:]]/a) {
$result .= $char;
$prev_was_punct = 1;
}
elsif ($char =~ /[[:print:]]/a) {
$result .= " " unless $prev_was_punct;
$result .= $char;
$prev_was_punct = 0;
}
else {
$result .= " " unless $prev_was_punct;
my $name = charnames::viacode(ord $char);
$result .= (defined $name) ? $name : ':unknown:';
$prev_was_punct = 0;
}
}
}
else {
use bytes;
foreach my $char (split "", $string) {
if ($char =~ /[[:punct:]]/a) {
$result .= $char;
$prev_was_punct = 1;
}
elsif ($char =~ /[[:print:]]/a) {
$result .= " " unless $prev_was_punct;
$result .= $char;
$prev_was_punct = 0;
}
else {
$result .= " " unless $prev_was_punct;
$result .= sprintf("%02X", ord $char);
$prev_was_punct = 0;
}
}
}

return $result;
}

my @want = sort keys %want;

plan tests => 1 + 3 * @constants + keys(@want) + 1 + 2;
Expand Down Expand Up @@ -86,12 +148,18 @@ SKIP: {
my $found_time = 0;
my $found_monetary = 0;
my @locales = find_locales( [ 'LC_TIME', 'LC_CTYPE', 'LC_MONETARY' ]);
my @utf8_locales = find_utf8_ctype_locales(\@locales);

foreach my $utf8_locale (@utf8_locales) {

while (defined (my $utf8_locale = find_utf8_ctype_locale(\@locales))) {
if (! $found_time) {
setlocale(&LC_TIME, $utf8_locale);
print STDERR __FILE__, ": ", __LINE__, ": calling setlocale(LC_TIME, $utf8_locale)\n" if $debug;
my $set_ret = setlocale(&LC_TIME, $utf8_locale);
print STDERR __FILE__, ": ", __LINE__, ": setlocale returned '$set_ret'\n" if $debug;
foreach my $time_item (@times) {
my $eval_string = "langinfo(&$time_item)";
print STDERR __FILE__, ": ", __LINE__, ": ", setlocale(&LC_TIME), "\n" if $debug;
my $eval_string = "$eval_debug langinfo(&$time_item)";
print STDERR __FILE__, ": ", __LINE__, ": ", setlocale(&LC_TIME), "\n" if $debug;
my $time_name = eval $eval_string;
if ($@) {
fail("'$eval_string' failed: $@");
Expand All @@ -107,16 +175,18 @@ SKIP: {
}

if ($time_name =~ /\P{ASCII}/) {
ok(utf8::is_utf8($time_name), "The name for '$time_item' in $utf8_locale is a UTF8 string");
ok(utf8::is_utf8($time_name), "The name for '$time_item' in $utf8_locale is a UTF8 string. Got:\n" . disp_str($time_name));
$found_time = 1;
last;
}
}
}

if (! $found_monetary) {
print STDERR __FILE__, ": ", __LINE__, ": calling setlocale(LC_MONETARY, $utf8_locale)\n" if $debug;
setlocale(&LC_MONETARY, $utf8_locale);
my $eval_string = "langinfo(&CRNCYSTR)";
print STDERR __FILE__, ": ", __LINE__, ": setlocale returned\n" if $debug;
my $eval_string = "$eval_debug langinfo(&CRNCYSTR)";
my $symbol = eval $eval_string;
if ($@) {
fail("'$eval_string' failed: $@");
Expand All @@ -127,16 +197,12 @@ SKIP: {
last SKIP;
}
if ($symbol =~ /\P{ASCII}/) {
ok(utf8::is_utf8($symbol), "The name for 'CRNCYSTR' in $utf8_locale is a UTF8 string");
ok(utf8::is_utf8($symbol), "The name for 'CRNCYSTR' in $utf8_locale is a UTF8 string. Got:\n" . disp_str($symbol));
$found_monetary = 1;
}
}

last if $found_monetary && $found_time;

# Remove this locale from the list, and loop to find another utf8
# locale
@locales = grep { $_ ne $utf8_locale } @locales;
}

if ($found_time + $found_monetary < 2) {
Expand Down
4 changes: 2 additions & 2 deletions ext/POSIX/POSIX.xs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3181,7 +3181,7 @@ mblen(s, n = ~0)
}
else {
size_t len;
char * string = SvPV(byte_s, len);
char * string = SvPVbyte(byte_s, len);
if (n < len) len = n;
#ifdef USE_MBRLEN
MBRLEN_LOCK_;
Expand Down Expand Up @@ -3223,7 +3223,7 @@ mbtowc(pwc, s, n = ~0)
}
else {
size_t len;
char * string = SvPV(byte_s, len);
char * string = SvPVbyte(byte_s, len);
if (n < len) len = n;
RETVAL = mbtowc_(&wc, string, len);
if (RETVAL >= 0) {
Expand Down
4 changes: 2 additions & 2 deletions lib/locale.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,8 +59,8 @@ use I18N::Langinfo qw(langinfo CODESET CRNCYSTR RADIXCHAR);
# =1 adds debugging output; =2 increases the verbosity somewhat
our $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
if ($^O =~ /cygwin | darwin /xi) {
$debug = 1 ;
$^D = 0x04000000|0x00100000;# if $^O eq 'cygwin';
$debug = 0; # 1 ;
$^D = 0x04000000|0x00100000 if $debug;# if $^O eq 'cygwin';
}

# Certain tests have been shown to be problematical for a few locales. Don't
Expand Down
83 changes: 44 additions & 39 deletions lib/locale_threads.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,11 +25,12 @@ $Data::Dumper::Useqq = 1;
$Data::Dumper::Deepcopy = 1;

plan(2);
my $debug = $^O eq 'cygwin' or $^O =~ /MSWin32/i;
my $debug = 1 if $^O =~ /MSWin32/i;
#$debug = 1;
local $^D = 0x04000000|0x00100000 if $debug;

my $thread_count = $^O =~ /linux/i ? 50 : 3;
$thread_count = 3;
#$thread_count = 3;
my $iterations = 1000;
my $max_result_length = 10000;

Expand Down Expand Up @@ -116,6 +117,24 @@ push @prioritized, shift @utf8_locales if @utf8_locales;
push @prioritized, shift @non_utf8_locales if @non_utf8_locales;
my @valid_locales = sort final_ordering @prioritized, @non_utf8_locales, @utf8_locales;

sub final_ordering
{
for my $i (0 .. @prioritized - 1) {
next unless $a eq $prioritized[$i];
for my $j (0 .. @prioritized - 1) {
return ($i <= $j) ? -1 : 1 if $b eq $prioritized[$i];
}

# $a is priority; $b isn't
return -1;
}

# $a isn't a priority
return 1 if grep { $b eq $_ } @prioritized;

ordering;
}

# This test is fast, and so ignores the limits above that apply to later tests
SKIP: { # perl #127708
my @locales = grep { $_ !~ / ^ C \b | POSIX /x } @valid_locales;
Expand Down Expand Up @@ -344,6 +363,7 @@ SKIP: {

my $case_insensitive_matching_test = <<~'EOT';
#use re qw(Debug ALL);
no warnings "locale";
my $uc = CORE::uc join "", map { chr } (0..255);
my $fc = quotemeta CORE::fc $uc;
$uc =~ / \A $fc \z /xi;
Expand Down Expand Up @@ -372,24 +392,24 @@ SKIP: {
}

if ($category eq 'LC_CTYPE') {
add_trials('LC_CTYPE', 'quotemeta lc join "", map { chr } (0..255)');
add_trials('LC_CTYPE', 'quotemeta uc join "", map { chr } (0..255)');
add_trials('LC_CTYPE', 'quotemeta CORE::fc join "", map { chr } (0..255)');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/\d/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/\s/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/\w/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:alpha:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:alnum:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:ascii:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:blank:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:cntrl:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:graph:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:lower:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:print:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:punct:]]/?1:0|gers');
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:upper:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; quotemeta lc join "", map { chr } (0..255)');
add_trials('LC_CTYPE', 'no warnings "locale"; quotemeta uc join "", map { chr } (0..255)');
add_trials('LC_CTYPE', 'no warnings "locale"; quotemeta CORE::fc join "", map { chr } (0..255)');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/\d/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/\s/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/\w/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:alpha:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:alnum:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:ascii:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:blank:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:cntrl:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:graph:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:lower:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:print:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:punct:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:upper:]]/?1:0|gers');
print STDERR __FILE__, ": ", __LINE__, ": Got here\n" if $debug;
add_trials('LC_CTYPE', 'my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:xdigit:]]/?1:0|gers');
add_trials('LC_CTYPE', 'no warnings "locale"; my $string = join "", map { chr } 0..255; $string =~ s|(.)|$1=~/[[:xdigit:]]/?1:0|gers');
print STDERR __FILE__, ": ", __LINE__, ": Got here\n" if $debug;
add_trials('LC_CTYPE', $langinfo_LC_CTYPE) unless $debug;;
print STDERR __FILE__, ": ", __LINE__, ": Got here\n" if $debug;
Expand Down Expand Up @@ -447,25 +467,8 @@ SKIP: {
}

print STDERR __FILE__, __LINE__, ": ", Dumper \%tests_prep if $debug;
#__END__

sub final_ordering
{
for my $i (0 .. @prioritized - 1) {
next unless $a eq $prioritized[$i];
for my $j (0 .. @prioritized - 1) {
return ($i <= $j) ? -1 : 1 if $b eq $prioritized[$i];
}

# $a is priority; $b isn't
return -1;
}

# $a isn't a priority
return 1 if grep { $b eq $_ } @prioritized;

ordering;
}
#}
#__END__

my @tests;
for my $i (1 .. $thread_count) {
Expand Down Expand Up @@ -526,7 +529,8 @@ SKIP: {
}

print STDERR __FILE__, ": ", __LINE__, ": ", Dumper \@tests;
#__END__
#}
#__END__

my $tests_expanded = Data::Dumper->Dump([ \@tests ], [ 'all_tests_ref' ]);
my $starting_time = sprintf "%.16e", ( time()
Expand Down Expand Up @@ -616,6 +620,7 @@ SKIP: {
\$corrects{\$category_name}++;
}
else {
no locale;
\$|=1;
\$errors++;
my \$locale
Expand Down
Loading

0 comments on commit b8433b9

Please sign in to comment.