use strict;
use warnings;
# This file tests interactions with locale and threads
BEGIN {
$| = 1;
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
skip_all_without_config('useithreads');
skip_all("Fails on threaded builds on OpenBSD")
if ($^O =~ m/^(openbsd)$/);
require './loc_tools.pl';
eval { require POSIX; POSIX->import(qw(errno_h locale_h unistd_h )) };
if ($@) {
skip_all("could not load the POSIX module"); # running minitest?
}
}
use Time::HiRes qw(time usleep);
use Devel::Peek;
$Devel::Peek::pv_limit = 0; $Devel::Peek::pv_limit = 0;
use Data::Dumper;
$Data::Dumper::Sortkeys=1;
$Data::Dumper::Useqq = 1;
$Data::Dumper::Deepcopy = 1;
my $debug = 0;
my %map_category_name_to_number;
my %map_category_number_to_name;
my @valid_categories = valid_locale_categories();
foreach my $category (@valid_categories) {
my $cat_num = eval "&POSIX::$category";
die "Can't determine ${category}'s number: $@" if $@;
$map_category_name_to_number{$category} = $cat_num;
$map_category_number_to_name{$cat_num} = $category;
}
my $LC_ALL;
my $LC_ALL_string;
if (defined $map_category_name_to_number{LC_ALL}) {
$LC_ALL_string = 'LC_ALL';
$LC_ALL = $map_category_name_to_number{LC_ALL};
}
elsif (defined $map_category_name_to_number{LC_CTYPE}) {
$LC_ALL_string = 'LC_CTYPE';
$LC_ALL = $map_category_name_to_number{LC_CTYPE};
}
else {
skip_all("No LC_ALL nor LC_CTYPE");
}
# reset the locale environment
delete local @ENV{'LANGUAGE', 'LANG', keys %map_category_name_to_number};
my @locales = find_locales($LC_ALL);
skip_all("Couldn't find any locales") if @locales == 0;
plan(2);
my ($utf8_locales_ref, $non_utf8_locales_ref)
= classify_locales_wrt_utf8ness(\@locales);
my $official_ascii_name = 'ansi_x341968';
my %lang_code_to_script = ( # ISO 639.2, but without the many codes that
# are for latin (but the few western European
# ones that are latin1 are included)
am => 'amharic',
amh => 'amharic',
amharic => 'amharic',
ar => 'arabic',
be => 'cyrillic',
bel => 'cyrillic',
ben => 'bengali',
bn => 'bengali',
bg => 'cyrillic',
bul => 'cyrillic',
bulgarski => 'cyrillic',
bulgarian => 'cyrillic',
c => $official_ascii_name,
cnr => 'cyrillic',
de => 'latin_1',
deu => 'latin_1',
deutsch => 'latin_1',
german => 'latin_1',
div => 'thaana',
dv => 'thaana',
dzo => 'tibetan',
dz => 'tibetan',
el => 'greek',
ell => 'greek',
ellada => 'greek',
en => $official_ascii_name,
eng => $official_ascii_name,
american => $official_ascii_name,
british => $official_ascii_name,
es => 'latin_1',
fa => 'arabic',
fas => 'arabic',
flamish => 'latin_1',
fra => 'latin_1',
fr => 'latin_1',
heb => 'hebrew',
he => 'hebrew',
hi => 'hindi',
hin => 'hindi',
hy => 'armenian',
hye => 'armenian',
ita => 'latin_1',
it => 'latin_1',
ja => 'katakana',
jpn => 'katakana',
nihongo => 'katakana',
japanese => 'katakana',
ka => 'georgian',
kat => 'georgian',
kaz => 'cyrillic',
khm => 'khmer',
kir => 'cyrillic',
kk => 'cyrillic',
km => 'khmer',
ko => 'hangul',
kor => 'hangul',
korean => 'hangul',
ku => 'arabic',
kur => 'arabic',
ky => 'cyrillic',
latin1 => 'latin_1',
lao => 'lao',
lo => 'lao',
mk => 'cyrillic',
mkd => 'cyrillic',
macedonian => 'cyrillic',
mn => 'cyrillic',
mon => 'cyrillic',
mya => 'myanmar',
my => 'myanmar',
ne => 'devanagari',
nep => 'devanagari',
nld => 'latin_1',
nl => 'latin_1',
nederlands => 'latin_1',
dutch => 'latin_1',
por => 'latin_1',
posix => $official_ascii_name,
ps => 'arabic',
pt => 'latin_1',
pus => 'arabic',
ru => 'cyrillic',
russki => 'cyrillic',
russian => 'cyrillic',
rus => 'cyrillic',
sin => 'sinhala',
si => 'sinhala',
so => 'arabic',
som => 'arabic',
spa => 'latin_1',
sr => 'cyrillic',
srp => 'cyrillic',
tam => 'tamil',
ta => 'tamil',
tg => 'cyrillic',
tgk => 'cyrillic',
tha => 'thai',
th => 'thai',
thai => 'thai',
ti => 'ethiopian',
tir => 'ethiopian',
uk => 'cyrillic',
ukr => 'cyrillic',
ur => 'arabic',
urd => 'arabic',
zgh => 'arabic',
zh => 'chinese',
zho => 'chinese',
);
my %codeset_to_script = (
88591 => 'latin_1',
88592 => 'latin_2',
88593 => 'latin_3',
88594 => 'latin_4',
88595 => 'cyrillic',
88596 => 'arabic',
88597 => 'greek',
88598 => 'hebrew',
88599 => 'latin_5',
885910 => 'latin_6',
885911 => 'thai',
885912 => 'devanagari',
885913 => 'latin_7',
885914 => 'latin_8',
885915 => 'latin_9',
885916 => 'latin_10',
cp1251 => 'cyrillic',
cp1255 => 'hebrew',
);
my %script_priorities = ( # In trying to make the results as distinct as
# possible, make the ones closest to Unicode,
# and ASCII lowest priority
$official_ascii_name => 15,
latin_1 => 14,
latin_9 => 13,
latin_2 => 12,
latin_4 => 12,
latin_5 => 12,
latin_6 => 12,
latin_7 => 12,
latin_8 => 12,
latin_10 => 12,
latin => 11, # Unknown latin version
);
my %script_instances; # Keys are scripts, values are how many locales use
# this script.
sub analyze_locale_name($) {
# Takes the input name of a locale and creates (and returns) a hash
# containing information about that locale
my %ret;
my $input_locale_name = shift;
my $old_locale = setlocale(LC_CTYPE);
# Often a locale has multiple aliases, and the base one is returned
# by setlocale() when called with an alias. The base is more likely to
# meet the XPG standards than the alias.
my $new_locale = setlocale(LC_CTYPE, $input_locale_name);
if (! $new_locale) {
diag "Unexpectedly can't setlocale(LC_CTYPE, $new_locale);"
. " \$!=$!, \$^E=$^E";
return;
}
$ret{locale_name} = $new_locale;
# XPG standard for locale names:
# language[_territory[.codeset]][@modifier]
# But, there are instances which violate this, where there is a codeset
# without a territory, so instead match:
# language[_territory][.codeset][@modifier]
$ret{locale_name} =~ / ^
( .+? ) # language
(?: _ ( .+? ) )? # territory
(?: \. ( .+? ) )? # codeset
(?: \@ ( .+ ) )? # modifier
$
/x;
$ret{language} = $1 // "";
$ret{territory} = $2 // "";
$ret{codeset} = $3 // "";
$ret{modifier} = $4 // "";
# Normalize all but 'territory' to lowercase
foreach my $key (qw(language codeset modifier)) {
$ret{$key} = lc $ret{$key};
}
# Often, the codeset is omitted from the locale name, but it is still
# discoverable (via langinfo() ) for the current locale on many platforms.
# We already have switched locales
use I18N::Langinfo qw(langinfo CODESET);
my $langinfo_codeset = lc langinfo(CODESET);
# Now can switch back to the locale current on entry to this sub
if (! setlocale(LC_CTYPE, $old_locale)) {
die "Unexpectedly can't restore locale to $old_locale from"
. " $new_locale; \$!=$!, \$^E=$^E";
}
# Normalize the codesets
foreach my $codeset_ref (\$langinfo_codeset, \$ret{codeset}) {
$$codeset_ref =~ s/\W//g;
$$codeset_ref =~ s/iso8859/8859/g;
$$codeset_ref =~ s/\b65001\b/utf8/; # Windows synonym
$$codeset_ref =~ s/\b646\b/$official_ascii_name/;
$$codeset_ref =~ s/\busascii\b/$official_ascii_name/;
}
# The langinfo codeset, if found, is considered more reliable than the one
# in the name. (This is because libc looks into the actual data
# definition.) So use it unconditionally when found. But note any
# discrepancy as an aid for improving this test.
if ($langinfo_codeset) {
if ($ret{codeset} && $ret{codeset} ne $langinfo_codeset) {
diag "In $ret{locale_name}, codeset from langinfo"
. " ($langinfo_codeset) doesn't match codeset in"
. " locale_name ($ret{codeset})";
}
$ret{codeset} = $langinfo_codeset;
}
$ret{is_utf8} = 0 + ($ret{codeset} eq 'utf8');
# If the '@' modifier is a known script, use it as the script.
if ( $ret{modifier}
and grep { $_ eq $ret{modifier} } values %lang_code_to_script)
{
$ret{script} = $ret{nominal_script} = $ret{modifier};
$ret{modifier} = "";
}
elsif ($ret{codeset} && ! $ret{is_utf8}) {
# The codeset determines the script being used, except if we don't
# have the codeset, or it is UTF-8 (which covers a multitude of
# scripts).
#
# We have hard-coded the scripts corresponding to a few of these
# non-UTF-8 codesets. See if this is one of them.
$ret{script} = $codeset_to_script{$ret{codeset}};
if ($ret{script}) {
# For these, the script is likely a combination of ASCII (from
# 0-127), and the script from (128-255). Reflect that in the name
# used (for distinguishing below)
$ret{script} .= '_' . $official_ascii_name;
}
elsif ($ret{codeset} =~ /^koi/) { # Another common set.
$ret{script} = "cyrillic_${official_ascii_name}";
}
else { # Here the codeset name is unknown to us. Just assume it
# means a whole new script. Add the language at the end of
# the name to further make it distinct
$ret{script} = $ret{codeset};
$ret{script} .= "_$ret{language}"
if $ret{codeset} !~ /$official_ascii_name/;
}
}
else { # Here, the codeset is unknown or is UTF-8.
# In these cases look up the script based on the language. The table
# is meant to be pretty complete, but omits the many scripts that are
# ASCII or Latin1. And it omits the fullnames of languages whose
# scripts are themselves. The grep below catches those. Defaulting
# to Latin means that a non-standard language name is considered to be
# latin -- maybe not the best outcome but what else is better?
$ret{script} = $lang_code_to_script{$ret{language}};
if (! $ret{script}) {
$ret{script} = (grep { $ret{language} eq $_ }
values %lang_code_to_script)
? $ret{language}
: 'latin';
}
}
# If we have @euro, and the script is ASCII or latin or latin1, change it
# into latin9, which is closer to what is going on. latin9 has a few
# other differences from latin1, but it's not worth creating a whole new
# script type that differs only in the currency symbol.
if ( ($ret{modifier} && $ret{modifier} eq 'euro')
&& $ret{script} =~ / ^ ($official_ascii_name | latin (_1)? ) $ /x)
{
$ret{script} = 'latin_9';
}
# Look up the priority of this script. All the non-listed ones have
# highest (0 or 1) priority. We arbitrarily make the ones higher
# priority (0) that aren't known to be half-ascii, simply because they
# might be entirely different than most locales.
$ret{priority} = $script_priorities{$ret{script}};
if (! $ret{priority}) {
$ret{priority} = ( $ret{script} ne $official_ascii_name
&& $ret{script} =~ $official_ascii_name)
? 0
: 1;
}
# Script names have been set up so that anything after an underscore is a
# modifier of the main script. We keep a counter of which occurence of
# this script this is. This is used along with the priority to order the
# locales so that the characters are as varied as possible.
my $script_root = ($ret{script} =~ s/_.*//r) . "_$ret{is_utf8}";
$ret{script_instance} = $script_instances{$script_root}++;
return \%ret;
}
# Prioritize locales that are most unlike the standard C/Latin1-ish ones.
# This is to minimize getting passes for tests on a category merely because
# they share many of the same characteristics as the locale of another
# category simultaneously in effect.
sub sort_locales ()
{
my $cmp = $a->{script_instance} <=> $b->{script_instance};
return $cmp if $cmp;
$cmp = $a->{priority} <=> $b->{priority};
return $cmp if $cmp;
$cmp = $a->{script} cmp $b->{script};
return $cmp if $cmp;
$cmp = $a->{modifier} cmp $b->{modifier};
return $cmp if $cmp;
$cmp = $a->{codeset} cmp $b->{codeset};
return $cmp if $cmp;
$cmp = $a->{territory} cmp $b->{territory};
return $cmp if $cmp;
return lc $a cmp lc $b;
}
# Find out extra info about each locale
my @cleaned_up_locales;
for my $locale (@locales) {
my $locale_struct = analyze_locale_name($locale);
next unless $locale_struct;
my $name = $locale_struct->{locale_name};
next if grep { $name eq $_->{locale_name} } @cleaned_up_locales;
push @cleaned_up_locales, $locale_struct;
}
@locales = @cleaned_up_locales;
# Without a proper codeset, we can't really know how to test. This should
# only happen on platforms that lack the ability to determine the codeset.
@locales = grep { $_->{codeset} ne "" } @locales;
# Sort into priority order.
@locales = sort sort_locales @locales;
# First test
SKIP: { # perl #127708
my $locale = $locales[0];
skip("No valid locale to test with", 1) if $locale->{codeset} eq
$official_ascii_name;
local $ENV{LC_MESSAGES} = $locale->{locale_name};
# We're going to try with all possible error numbers on this platform
my $error_count = keys(%!) + 1;
print fresh_perl("
use threads;
use strict;
use warnings;
use Time::HiRes qw(usleep);
my \$errnum = 1;
my \@threads = map +threads->create(sub {
usleep 0.1;
'threads'->yield();
for (1..5_000) {
\$errnum = (\$errnum + 1) % $error_count;
\$! = \$errnum;
# no-op to trigger stringification
next if \"\$!\" eq \"\";
}
}), (0..1);
\$_->join for splice \@threads;",
{}
);
pass("Didn't segfault");
}
# Second test setup
my %locale_name_to_object;
for my $locale (@locales) {
$locale_name_to_object{$locale->{locale_name}} = $locale;
}
sub sort_by_hashed_locale {
local $a = $locale_name_to_object{$a};
local $b = $locale_name_to_object{$b};
return sort_locales;
}
sub min {
my ($a, $b) = @_;
return $a if $a <= $b;
return $b;
}
# Smokes have shown this to be about the maximum numbers some platforms can
# handle. khw has tried 500 threads/1000 iterations on Linux
my $thread_count = 15;
my $iterations = 100;
my $alarm_clock = (1 * 10 * 60); # A long time, just to prevent hanging
# Chunk the iterations, so that every so often the test comes up for air.
my $iterations_per_test_set = min(30, int($iterations / 5));
$iterations_per_test_set = 1 if $iterations_per_test_set == 0;
# Sometimes the test calls setlocale() for each individual locale category.
# But every this many threads, it will be called just once, using LC_ALL to
# specify the categories. This way both setting individual categories and
# LC_ALL get tested. But skip this nicety on platforms where we are restricted from
# using all the available categories, as it would make the code more complex
# for not that much gain.
my @platform_categories = platform_locale_categories();
my $lc_all_frequency = scalar @platform_categories == scalar @valid_categories
? 3
: -1;
# To avoid things getting too big; skip tests whose results are larger than
# this many characters.
my $max_result_length = 10000;
# Estimate as to how long in seconds to allow a thread to be ready to roll
# after creation, so as to try to get all the threads to start as
# simultaneously as possible
my $per_thread_startup = .18;
# For use in experimentally tuning the above value
my $die_on_negative_sleep = 1;
# We don't need to test every possible errno, but you could change this to do
# so by setting it to negative
my $max_message_catalog_entries = 10;
# December 18, 1987
my $strftime_args = "'%c', 0, 0, , 12, 18, 11, 87";
my %distincts; # The distinct 'operation => result' cases
my %op_counts; # So we can bail early if more test cases than threads
my $separator = '____'; # The operation and result are often melded into a
# string separated by this.
sub pack_op_result($$) {
my ($op, $result) = @_;
return $op . $separator
. (0 + utf8::is_utf8($op)) . $separator
. $result . $separator
. (0 + utf8::is_utf8($result));
}
sub fixup_utf8ness($$) {
my ($operand, $utf8ness) = @_;
# Make sure $operand is encoded properly
if ($utf8ness + 0 != 0 + utf8::is_utf8($$operand)) {
if ($utf8ness) {
utf8::upgrade($$operand);
}
else {
utf8::downgrade($$operand);
}
}
}
sub unpack_op_result($) {
my $op_result = shift;
my ($op, $op_utf8ness, $result, $result_utf8ness) =
split $separator, $op_result;
fixup_utf8ness(\$op, $op_utf8ness);
fixup_utf8ness(\$result, $result_utf8ness);
return ($op, $result);
}
sub add_trials($$;$)
{
# Add a test case for category $1.
# $2 is the test case operation to perform
# $3 is a constraint, optional.
my $category_name = shift;
my $input_op = shift; # The eval string to perform
my $locale_constraint = shift // ""; # If defined, the test will be
# created only for locales that
# match this
LOCALE:
foreach my $locale (@locales) {
my $locale_name = $locale->{locale_name};
my $op = $input_op;
# All categories should be set to the same locale to make sure
# this test gets the valid results.
next unless setlocale($LC_ALL, $locale_name);
# As of NetBSD 10, it doesn't implement LC_COLLATE, and setting that
# category to anything but C or POSIX fails. But setting LC_ALL to
# other locales (as we just did) returns success, while leaving
# LC_COLLATE untouched. Therefore, also set the category individually
# to catch such things. This problem may not be confined to NetBSD.
# This also works if the platform lacks LC_ALL. We at least set
# LC_CTYPE (via '$LC_ALL' above) besides the category.
next unless setlocale($map_category_name_to_number{$category_name},
$locale_name);
# Use a placeholder if this test requires a particular constraint,
# which isn't met in this case.
if ($locale_constraint) {
if ($locale_constraint eq 'utf8_only') {
next if ! $locale->{is_utf8};
}
elsif ($locale_constraint eq 'a<b') {
my $result = eval "use locale; 'a' lt 'B'";
die "$category_name: '$op (a lt B)': $@" if $@;
next unless $result;
}
else {
die "Only accepted locale constraints are 'utf8_only' and 'a<b'"
}
}
# Calculate what the expected value of the test should be. We're
# doing this here in the main thread and with all the locales set to
# be the same thing. The test will be that we should get this value
# under stress, with each thread using different locales for each
# category, and multiple threads simultaneously executing with
# disparate locales
my $eval_string = ($op) ? "use locale; $op;" : "";
my $result = eval $eval_string;
die "$category_name: '$op': $@" if $@;
if (! defined $result) {
if ($debug) {
print STDERR __FILE__, ": ", __LINE__,
": Undefined result for $locale_name",
" $category_name: '$op'\n";
}
next;
}
elsif ($debug > 1) {
print STDERR "\n", __FILE__, ": ", __LINE__, ": $category_name:",
" $locale_name: Op = ", Dumper($op), "; Returned ";
Dump $result;
}
if (length $result > $max_result_length) {
diag("For $locale_name, '$op', result is too long; skipped");
next;
}
# It seems best to not include tests with mojibake results, which here
# is checked for by two question marks in a row. (strxfrm is excluded
# from this restriction, as the result is really binary, so '??' could
# and does come up, not meaning mojibake.) A concrete example of this
# is in Mingw the locale Yi_China.1252. CP 1252 is for a Latin
# script; just about anything from an East Asian script is bound to
# fail. It makes no sense to have this locale, but it exists.
if ($eval_string !~ /xfrm/ && $result =~ /\?\?/) {
if ($debug) {
print STDERR __FILE__, ": ", __LINE__,
" For $locale_name, op=$op, result has mojibake: $result\n";
}
next;
}
# Some systems are buggy in that setlocale() gives non-deterministic
# results for some locales. Here we try to exclude those from our
# test by trying the setlocale this many times to see if it varies:
my $deterministic_trial_count = 5;
# To do this, we set the locale to an 'alternate' locale between
# trials. This defeats any attempt by the implementation to skip the
# setlocale if it is already in said locale.
my $alternate;
my @alternate;
# If possible, the alternate is chosen to be of the opposite UTF8ness,
# so as to reset internal states about that.
if (! $utf8_locales_ref || ! $utf8_locales_ref->@*) {
# If no UTF-8 locales, must choose one that is non-UTF-8.
@alternate = grep { $_ ne $locale_name } $non_utf8_locales_ref->@*;
}
elsif (! $non_utf8_locales_ref || ! $non_utf8_locales_ref->@*) {
# If no non-UTF-8 locales, must choose one that is UTF-8.
@alternate = grep { $_ ne $locale_name } $utf8_locales_ref->@*;
}
elsif (grep { $_ eq $locale_name } $utf8_locales_ref->@*) {
@alternate = $non_utf8_locales_ref->@*;
}
else {
@alternate = $utf8_locales_ref->@*;
}
# Now do the trials. For each, we choose the next alternate on the
# list, rotating the list so the following iteration will choose a
# different alternate.
for my $i (1 .. $deterministic_trial_count - 1) {
my $other = shift @alternate;
push @alternate, $other;
# Run the test on the alternate locale
if (! setlocale($LC_ALL, $other)) {
if ( $LC_ALL_string eq 'LC_ALL'
|| ! setlocale($map_category_name_to_number{$category_name},
$other))
{
die "Unexpectedly can't set locale to $other:"
. " \$!=$!, \$^E=$^E";
}
}
eval $eval_string;
# Then run it on the one we are hoping to test
if (! setlocale($LC_ALL, $locale_name)) {
if ( $LC_ALL_string eq 'LC_ALL'
|| ! setlocale($map_category_name_to_number{$category_name},
$locale_name))
{
die "Unexpectedly can't set locale to $locale_name from "
. setlocale($LC_ALL)
. "; \$!=$!, \$^E=$^E";
}
}
my $got = eval $eval_string;
next if $got eq $result
&& utf8::is_utf8($got) == utf8::is_utf8($result);
# If the result varied from the expected value, this is a
# non-deterministic locale, so, don't test it.
diag("For '$eval_string',\nresults in iteration $i differed from"
. " the original\ngot");
Dump($got);
diag("expected");
Dump($result);
next LOCALE;
}
# Here, the setlocale for this locale appears deterministic. Use it.
my $op_result = pack_op_result($op, $result);
push $distincts{$category_name}{$op_result}{locales}->@*, $locale_name;
# No point in looking beyond this if we already have all the tests we
# need. Note this assumes that the same op isn't used in two
# categories.
if (defined $op_counts{$op} && $op_counts{$op} >= $thread_count)
{
last;
}
}
}
use Config;
# Figure out from config how to represent disparate LC_ALL
my @valid_category_numbers = sort { $a <=> $b }
map { $map_category_name_to_number{$_} } @valid_categories;
my $use_name_value_pairs = defined $Config{d_perl_lc_all_uses_name_value_pairs};
my $lc_all_separator = ($use_name_value_pairs)
? ";"
: $Config{perl_lc_all_separator} =~ s/"//gr;
my @position_to_category_number;
if (! $use_name_value_pairs) {
my $positions = $Config{perl_lc_all_category_positions_init} =~ s/[{}]//gr;
$positions =~ s/,//g;
$positions =~ s/^ +//;
$positions =~ s/ +$//;
@position_to_category_number = split / \s+ /x, $positions
}
sub get_next_category() {
use feature 'state';
state $index;
# Called to rotate all the legal locale categories
my $which = ($use_name_value_pairs)
? \@valid_category_numbers
: \@position_to_category_number;
$index = -1 unless defined $index;
$index++;
if (! defined $which->[$index]) {
undef $index;
return;
}
my $category_number = $which->[$index];
return $category_number if $category_number != $LC_ALL;
# If this was LC_ALL, the next one won't be
return &get_next_category();
}
SKIP: {
skip("Unsafe locale threads", 1) unless ${^SAFE_LOCALES};
# The second test is several threads nearly simulataneously executing
# locale-sensitive operations with the categories set to disparate
# locales. This catches cases where the results of a given category is
# related to what the locale is of another category. (As an example, this
# test showed that some platforms require LC_CTYPE to be the same as
# LC_COLLATION, and/or LC_MESSAGES for proper results, so that Perl had to
# change to bring these into congruence under the hood). And it also
# catches where there is interference between multiple threads.
#
# This test tries to exercise every underlying locale-dependent operation
# available in Perl. It doesn't test every use of the operation, but
# includes some Perl construct that uses each. For example, it tests lc
# but not lcfirst. That would be redundant for this test; it wants to
# know if lowercasing works under threads and locales. But if the
# implementations were disjoint at the time this test was written, it
# would try each implementation. So, various things in the POSIX module
# have separate tests from the ones in core.
#
# For each such underlying locale-dependent operation, a Perl-visible
# construct is chosen that uses it. And a typical input or set of inputs
# is passed to that and the results are noted for every available locale
# on the platform. Many locales will have identical results, so the
# duplicates are stored separately.
#
# There will be N simultaneous threads. Each thread is configured to set
# a locale for each category, to run operations whose results depend on
# that locale, then check that the result matches the expected value, and
# to immediately repeat some largish number of iterations. The goal is to
# see if the locales on each thread are truly independent of those on the
# other threads.
#
# To that end, the locales are chosen so that the results differ from
# every other locale. Otherwise, the thread results wouldn't be truly
# independent. But if there are more threads than there are distinct
# results, duplicates are used to fill up what would otherwise be empty
# slots. That is the best we can do on those platforms.
#
# Having lots of locales to continually switch between stresses things so
# as to find potential segfaults where locale changing isn't really thread
# safe.
# There is a bug in older Windows runtimes in which locales in CP1252 and
# similar code pages whose names aren't entirely ASCII aren't recognized
# by later setlocales. Some names that are all ASCII are synonyms for
# such names. Weed those out by doing a setlocale of the original name,
# and then a setlocale of the resulting one. Discard locales which have
# any unacceptable name
if (${^O} eq "MSWin32" && $Config{'libc'} !~ /ucrt/) {
@locales = grep {
my $locale_name = $_->{locale_name};
my $underlying_name = setlocale(&LC_CTYPE, $locale_name);
# Defeat any attempt to skip the setlocale if the same as current,
# by switching to a locale very unlikey to be the current one.
setlocale($LC_ALL, "Albanian");
defined($underlying_name) && setlocale(&LC_CTYPE, $underlying_name)
} @locales;
}
# Create a hash of the errnos:
# "1" => "Operation\\ not\\ permitted",
# "2" => "No\\ such\\ file\\ or\\ directory",
# etc.
my %msg_catalog;
foreach my $error (sort keys %!) {
my $number = eval "Errno::$error";
$! = $number;
my $description = "$!";
next unless "$description";
$msg_catalog{$number} = quotemeta "$description";
}
# Then just the errnos.
my @msg_catalog = sort { $a <=> $b } keys %msg_catalog;
# Remove the excess ones.
splice @msg_catalog, $max_message_catalog_entries
if $max_message_catalog_entries >= 0;
my $msg_catalog = join ',', @msg_catalog;
eval { my $discard = POSIX::localeconv()->{currency_symbol}; };
my $has_localeconv = $@ eq "";
# Now go through and create tests for each locale category on the system.
# These tests were determined by grepping through the code base for
# locale-sensitive operations, and then figuring out something to exercise
# them.
foreach my $category (@valid_categories) {
no warnings 'uninitialized';
next if $category eq 'LC_ALL'; # Tested below as a combination of the
# individual categories
if ($category eq 'LC_COLLATE') {
add_trials('LC_COLLATE',
# 'reverse' causes it to be definitely out of order for
# the 'sort' to correct
'quotemeta join "", sort reverse map { chr } (1..255)');
# We pass an re to exclude testing locales that don't necessarily
# have a lt b.
add_trials('LC_COLLATE', '"a" lt "B"', 'a<b');
add_trials('LC_COLLATE', 'my $a = "a"; my $b = "B";'
. ' POSIX::strcoll($a, $b) < 0;',
'a<b');
# Doesn't include NUL because our memcollxfrm implementation of it
# isn't perfect
add_trials('LC_COLLATE', 'my $string = quotemeta join "",'
. ' map { chr } (1..255);'
. ' POSIX::strxfrm($string)');
next;
}
if ($category eq 'LC_CTYPE') {
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');
add_trials('LC_CTYPE', 'no warnings "locale";'
. ' my $string = join "", map { chr } 0..255;'
. ' $string =~ s|(.)|$1=~/[[:xdigit:]]/?1:0|gers');
add_trials('LC_CTYPE', 'use I18N::Langinfo qw(langinfo CODESET);'
. ' no warnings "uninitialized";'
. ' langinfo(CODESET);');
# In the multibyte functions, the non-reentrant ones can't be made
# thread safe
if ($Config{'d_mbrlen'} eq 'define') {
add_trials('LC_CTYPE', 'my $string = chr 0x100;'
. ' utf8::encode($string);'
. ' no warnings "uninitialized";'
. ' POSIX::mblen(undef);'
. ' POSIX::mblen($string)',
'utf8_only');
}
if ($Config{'d_mbrtowc'} eq 'define') {
add_trials('LC_CTYPE', 'my $value; my $str = "\x{100}";'
. ' utf8::encode($str);'
. ' no warnings "uninitialized";'
. ' POSIX::mbtowc(undef, undef);'
. ' POSIX::mbtowc($value, $str); $value;',
'utf8_only');
}
if ($Config{'d_wcrtomb'} eq 'define') {
add_trials('LC_CTYPE', 'my $value;'
. ' no warnings "uninitialized";'
. ' POSIX::wctomb(undef, undef);'
. ' POSIX::wctomb($value, 0xFF);'
. ' $value;',
'utf8_only');
}
add_trials('LC_CTYPE',
'no warnings "locale";'
. ' my $uc = CORE::uc join "", map { chr } (0..255);'
. ' my $fc = quotemeta CORE::fc $uc;'
. ' $uc =~ / \A $fc \z /xi;');
next;
}
if ($category eq 'LC_MESSAGES') {
add_trials('LC_MESSAGES',
"join \"\n\", map { \$! = \$_; \"\$!\" } ($msg_catalog)");
add_trials('LC_MESSAGES',
'use I18N::Langinfo qw(langinfo YESSTR NOSTR YESEXPR NOEXPR);'
. ' no warnings "uninitialized";'
. ' join ",",'
. ' map { langinfo($_) } YESSTR, NOSTR, YESEXPR, NOEXPR;');
next;
}
if ($category eq 'LC_MONETARY') {
if ($has_localeconv) {
add_trials('LC_MONETARY', "localeconv()->{currency_symbol}");
}
add_trials('LC_MONETARY',
'use I18N::Langinfo qw(langinfo CRNCYSTR);'
. ' no warnings "uninitialized";'
. ' join "|", map { langinfo($_) } CRNCYSTR;');
next;
}
if ($category eq 'LC_NUMERIC') {
if ($has_localeconv) {
add_trials('LC_NUMERIC', "no warnings; 'uninitialised';"
. " join '|',"
. " localeconv()->{decimal_point},"
. " localeconv()->{thousands_sep}");
}
add_trials('LC_NUMERIC',
'use I18N::Langinfo qw(langinfo RADIXCHAR THOUSEP);'
. ' no warnings "uninitialized";'
. ' join "|", map { langinfo($_) } RADIXCHAR, THOUSEP;');
# Use a variable to avoid runtime bugs being hidden by constant
# folding
add_trials('LC_NUMERIC', 'my $in = 4.2; sprintf("%g", $in)');
next;
}
if ($category eq 'LC_TIME') {
add_trials('LC_TIME', "POSIX::strftime($strftime_args)");
add_trials('LC_TIME', <<~'END_OF_CODE');
use I18N::Langinfo qw(langinfo
ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7
ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12
DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7
MON_1 MON_2 MON_3 MON_4 MON_5 MON_6
MON_7 MON_8 MON_9 MON_10 MON_11 MON_12
D_FMT D_T_FMT T_FMT);
no warnings "uninitialized";
join "|",
map { langinfo($_) }
ABDAY_1,ABDAY_2,ABDAY_3,ABDAY_4,ABDAY_5,
ABDAY_6,ABDAY_7,
ABMON_1,ABMON_2,ABMON_3,ABMON_4,ABMON_5,
ABMON_6, ABMON_7,ABMON_8,ABMON_9,ABMON_10,
ABMON_11,ABMON_12,
DAY_1,DAY_2,DAY_3,DAY_4,DAY_5,DAY_6,DAY_7,
MON_1,MON_2,MON_3,MON_4,MON_5,MON_6, MON_7,
MON_8,MON_9,MON_10,MON_11,MON_12,
D_FMT,D_T_FMT,T_FMT;
END_OF_CODE
next;
}
} # End of creating test cases.
# Now analyze the test cases
my %all_tests;
foreach my $category (keys %distincts) {
my %results;
my %distinct_results_count;
# Find just the distinct test operations; sort for repeatibility
my %distinct_ops;
for my $op_result (sort keys $distincts{$category}->%*) {
my ($op, $result) = unpack_op_result($op_result);
$distinct_ops{$op}++;
push $results{$op}->@*, $result;
$distinct_results_count{$result} +=
scalar $distincts{$category}{$op_result}{locales}->@*;
}
# And get a sorted list of all the test operations
my @ops = sort keys %distinct_ops;
sub gen_combinations {
# Generate all the non-empty combinations of operations and
# results (for the current category) possible on this platform.
# That is, if a category has N operations, it will generate a list
# of entries. Each entry will itself have N elements, one for
# each operation, and when all the entries are considered
# together, every possible outcome is represented.
my $op_ref = shift; # Reference to list of operations
my $results_ref = shift; # Reference to hash; key is operation;
# value is an array of all possible
# outcomes of this operation.
my $distincts_ref = shift; # Reference to %distincts of this
# category
# Get the first operation on the list
my $op = shift $op_ref->@*;
# The return starts out as a list of hashes of all possible
# outcomes for executing 'op'. Each hash has two keys:
# 'op_results' is an array of one element: 'op => result',
# packed into a string.
# 'locales' is an array of all the locales which have the
# same result for 'op'
my @return;
foreach my $result ($results_ref->{$op}->@*) {
my $op_result = pack_op_result($op, $result);
push @return, {
op_results => [ $op_result ],
locales => $distincts_ref->{$op_result}{locales},
};
}
# If this is the final element of the list, we are done.
return (\@return) unless $op_ref->@*;
# Otherwise recurse to generate the combinations for the remainder
# of the list.
my $recurse_return = &gen_combinations($op_ref,
$results_ref,
$distincts_ref);
# Now we have to generate the combinations of the current item
# with the ones returned by the recursion. Each element of the
# current item is combined with each element of the recursed.
my @combined;
foreach my $this (@return) {
my @this_locales = $this->{locales}->@*;
foreach my $recursed ($recurse_return->@*) {
my @recursed_locales = $recursed->{locales}->@*;
# @this_locales is a list of locales this op => result is
# valid for. @recursed_locales is similarly a list of the
# valid ones for the recursed return. Their intersection
# is a list of the locales valid for this combination.
my %seen;
$seen{$_}++ foreach @this_locales, @recursed_locales;
my @intersection = grep $seen{$_} == 2, keys %seen;
# An alternative intersection algorithm:
# my (%set1, %set2);
# @set1{@list1} = ();
# @set2{@list2} = ();
# my @intersection = grep exists $set1{$_}, keys %set2;
# If the intersection is empty, this combination can't
# actually happen on this platform.
next unless @intersection;
# Append the recursed list to the current list to form the
# combined list.
my @combined_result = $this->{op_results}->@*;
push @combined_result, $recursed->{op_results}->@*;
# And create the hash for the combined result, including
# the locales it is valid for
push @combined, {
op_results => \@combined_result,
locales => \@intersection,
};
}
}
return \@combined;
} # End of gen_combinations() definition
# The result of calling gen_combinations() will be an array of hashes.
#
# The main value in each hash is an array (whose key is 'op_results')
# containing all the tests for this category for a thread. If there
# were N calls to 'add_trial' for this category, there will be 'N'
# elements in the array. Each element is a string packed with the
# operation to eval in a thread and the operation's expected result.
#
# The other data structure in each hash is an array with the key
# 'locales'. That array is a list of every locale which yields the
# identical results in 'op_results'.
#
# Effectively, each hash gives all the tests for this category for a
# thread. The total array of hashes gives the complete list of
# distinct tests possible on this system. So later, a thread will
# pluck the next available one from the array..
my $combinations_ref = gen_combinations(\@ops, \%results,
$distincts{$category});
# Fix up the entries ...
foreach my $test ($combinations_ref->@*) {
# Sort the locale names; this makes it work for later comparisons
# to look at just the first element of each list.
$test->{locales}->@* =
sort sort_by_hashed_locale $test->{locales}->@*;
# And for each test, calculate and store how many locales have the
# same result (saves recomputation later in a sort). This adds
# another data structure to each hash in the main array.
my @individual_tests = $test->{op_results}->@*;
my @in_common_locale_counts;
foreach my $this_test (@individual_tests) {
# Each test came from %distincts, and there we have stored the
# list of all locales that yield the same result
push @in_common_locale_counts,
scalar $distincts{$category}{$this_test}{locales}->@*;
}
push $test->{in_common_locale_counts}->@*, @in_common_locale_counts;
}
# Make a copy
my @cat_tests = $combinations_ref->@*;
# This sorts the test cases so that the ones with the least overlap
# with other cases are first.
sub sort_test_order {
my $a_tests_count = scalar $a->{in_common_locale_counts}->@*;
my $b_tests_count = scalar $b->{in_common_locale_counts}->@*;
my $tests_count = min($a_tests_count, $b_tests_count);
# Choose the one that is most distinctive (least overlap); that is
# the one that has the most tests whose results are not shared by
# any other locale.
my $a_nondistincts = 0;
my $b_nondistincts = 0;
for my $i (0 .. $tests_count - 1) {
$a_nondistincts += ($a->{in_common_locale_counts}[$i] != 1);
$b_nondistincts += ($b->{in_common_locale_counts}[$i] != 1);
}
my $cmp = $a_nondistincts <=> $b_nondistincts;
return $cmp if $cmp;
# If they have the same number of those, choose the one with the
# fewest total number of locales that have the same result
my $a_count = 0;
my $b_count = 0;
for my $i (0 .. $tests_count - 1) {
$a_count += $a->{in_common_locale_counts}[$i];
$b_count += $b->{in_common_locale_counts}[$i];
}
$cmp = $a_count <=> $b_count;
return $cmp if $cmp;
# If that still doesn't yield a winner, use the general sort order.
local $a = $a->{locales}[0];
local $b = $b->{locales}[0];
return sort_by_hashed_locale;
}
# Actually perform the sort.
@cat_tests = sort sort_test_order @cat_tests;
# This category will now have all the distinct tests possible for it
# on this platform, with the first test being the one with the least
# overlap with other test cases
push $all_tests{$category}->@*, @cat_tests;
} # End of loop through the categories creating and sorting the test
# cases
my %thread_already_used_locales;
# Now generate the tests for each thread.
my @tests_by_thread;
for my $i (0 .. $thread_count - 1) {
foreach my $category (sort keys %all_tests) {
my $skipped = 0; # Used below to not loop infinitely
# Get the next test case
NEXT_CANDIDATE:
my $candidate = shift $all_tests{$category}->@*;
my $locale_name = $candidate->{locales}[0];
# Avoid, if possible, using the same locale name twice (for
# different categories) in the same thread.
if (defined $thread_already_used_locales{$locale_name =~ s/\W.*//r})
{
# Look through the synonyms of this locale for an
# as-yet-unused one
for my $j (1 .. $candidate->{locales}->@* - 1) {
my $synonym = $candidate->{locales}[$j];
next if defined $thread_already_used_locales{$synonym =~
s/\W.*//r};
$locale_name = $synonym;
goto found_synonym;
}
# Here, no synonym was found. If we haven't cycled through
# all the possible tests, try another (putting this one at the
# end as a last resort in the future).
$skipped++;
if ($skipped < scalar $all_tests{$category}->@*) {
push $all_tests{$category}->@*, $candidate;
goto NEXT_CANDIDATE;
}
# Here no synonym was found, this test has already been used,
# but there are no unused ones, so have to re-use it.
found_synonym:
}
# Here, we have found a test case. The thread needs to know what
# locale to use,
$tests_by_thread[$i]->{$category}{locale_name} = $locale_name;
# And it needs to know each test to run, and the expected result.
my @cases;
for my $j (0 .. $candidate->{op_results}->@* - 1) {
my ($op, $result) =
unpack_op_result($candidate->{op_results}[$j]);
push @cases, { op => $op, expected => $result };
}
push $tests_by_thread[$i]->{$category}{locale_tests}->@*, @cases;
# Done with this category in this thread. Setup for subsequent
# categories in this thread, and subsequent threads.
#
# It's best to not have two categories in a thread use the same
# locale. Save this locale name so that later iterations handling
# other categories can avoid using it, if possible.
$thread_already_used_locales{$locale_name =~ s/\W.*//r} = 1;
# In pursuit of using as many different locales as possible, the
# first shall be last in line next time, and eventually the last
# shall be first
push $candidate->{locales}->@*, shift $candidate->{locales}->@*;
# Similarly, this test case is added back at the end of the list,
# so will be used only as a last resort in the next thread, and as
# the penultimate resort in the thread following that, etc. as the
# test cases are cycled through.
push $all_tests{$category}->@*, $candidate;
} # End of looping through the categories for this thread
} # End of generating all threads
# Now reformat the tests to a form convenient for the actual test file
# script to use; minimizing the amount of ancillary work it needs to do.
my @cooked_tests;
for my $i (0 .. $#tests_by_thread) {
my $this_tests = $tests_by_thread[$i];
my @this_cooked_tests;
my (@this_categories, @this_locales); # Parallel arrays
# Every so often we use LC_ALL instead of individual locales, provided
# it is available on the platform
if ( ($i % $lc_all_frequency == $lc_all_frequency - 1)
&& $LC_ALL_string eq 'LC_ALL')
{
my $lc_all= "";
my $category_number;
# Compute the LC_ALL string for the syntax accepted by this
# platform from the locale each category is to be set to.
while (defined($category_number = get_next_category())) {
my $category_name =
$map_category_number_to_name{$category_number};
my $locale = $this_tests->{$category_name}{locale_name};
$locale = "C" unless defined $locale;
$category_name =~ s/\@/\\@/g;
$lc_all .= $lc_all_separator if $lc_all ne "";
if ($use_name_value_pairs) {
$lc_all .= $category_name . "=";
}
$lc_all .= $locale;
}
$this_categories[0] = $LC_ALL;
$this_locales[0] = $lc_all;
}
else { # The other times, just set each category to its locale
# individually
foreach my $category_name (sort keys $this_tests->%*) {
push @this_categories,
$map_category_name_to_number{$category_name};
push @this_locales,
$this_tests->{$category_name}{locale_name};
}
}
while (keys $this_tests->%*) {
foreach my $category_name (sort keys $this_tests->%*) {
my $this_category_tests = $this_tests->{$category_name};
my $test = shift
$this_category_tests->{locale_tests}->@*;
print STDERR __FILE__, ': ', __LINE__, ': ', Dumper $test
if $debug;
if (! $test) {
delete $this_tests->{$category_name};
next;
}
$test->{category_name} = $category_name;
my $locale_name = $this_category_tests->{locale_name};
$test->{locale_name} = $locale_name;
$test->{codeset} =
$locale_name_to_object{$locale_name}{codeset};
push @this_cooked_tests, $test;
}
}
push @cooked_tests, {
thread => $i,
categories => \@this_categories,
locales => \@this_locales,
tests => \@this_cooked_tests,
};
}
my $all_tests_ref = \@cooked_tests;
my $all_tests_file = tempfile();
# Store the tests into a file, retrievable by the subprocess
use Storable;
if (! defined store($all_tests_ref, $all_tests_file)) {
die "Could not save the built-up data structure";
}
my $category_number_to_name = Data::Dumper->Dump(
[ \%map_category_number_to_name ],
[ 'map_category_number_to_name']);
my $switches = "";
$switches = "switches => [ -DLv ]" if $debug > 2;
# Build up the program to run. This stresses locale thread safety. We
# start a bunch of threads. Each sets the locale of each category being
# tested to the value determined in the code above. Then each sleeps to a
# common start time, at which point they awaken and iterate their
# respective loops. Each iteration runs a set of tests and checks that
# the results are as expected. This should catch any instances of other
# threads interfering. Every so often, each thread shifts to instead use
# the locales and tests of another thread. This catches bugs dealing with
# changing the locale on the fly.
#
# The code above has set up things so that each thread has as disparate
# results from the other threads as possible, so to more likely catch any
# bleed-through.
my $program = <<EOT;
BEGIN { \$| = 1; }
my \$debug = $debug;
my \$thread_count = $thread_count;
my \$iterations_per_test_set = $iterations_per_test_set;
my \$iterations = $iterations;
my \$die_on_negative_sleep = $die_on_negative_sleep;
my \$per_thread_startup = $per_thread_startup;
my \$all_tests_file = $all_tests_file;
my \$alarm_clock = $alarm_clock;
EOT
$program .= <<'EOT';
use threads;
use strict;
use warnings;
use POSIX qw(locale_h);
use utf8;
use Time::HiRes qw(time usleep);
$|=1;
use Data::Dumper;
$Data::Dumper::Sortkeys=1;
$Data::Dumper::Useqq = 1;
$Data::Dumper::Deepcopy = 1;
# Get the tests stored for us by the setup process
use Storable;
my $all_tests_ref = retrieve($all_tests_file);
if (! defined $all_tests_ref) {
die "Could not restore the built-up data structure";
}
my %corrects;
sub output_test_failure_prefix {
my ($iteration, $category_name, $test) = @_;
my $tid = threads->tid();
print STDERR "\nthread ", $tid,
" failed in iteration $iteration",
" for locale $test->{locale_name}",
" codeset='$test->{codeset}'",
" $category_name",
"\nop='$test->{op}'",
"\nafter getting ", ($corrects{$category_name}
{$test->{locale_name}}
{all} // 0),
" previous correct results for this category and",
" locale,\nincluding ", ($corrects{$category_name}
{$test->{locale_name}}
{$tid} // 0),
" in this thread\n";
}
sub output_test_result($$$) {
my ($type, $result, $utf8_matches) = @_;
no locale;
print STDERR "$type";
my $copy = $result;
if (! $utf8_matches) {
if (utf8::is_utf8($copy)) {
print STDERR " (result already was in UTF-8)";
}
else {
utf8::upgrade($copy);
print STDERR " (result wasn't in UTF-8; converted for easier",
" comparison)";
}
}
print STDERR ":\n";
use Devel::Peek;
Dump $copy;
}
sub iterate { # Run some chunk of iterations of the tests
my ($tid, # Which thread
$initial_iteration, # The number of the first iteration
$count, # How many
$tests_ref) # The tests
= @_;
my $iteration = $initial_iteration;
$count += $initial_iteration;
# Repeatedly ...
while ($iteration < $count) {
my $errors = 0;
use locale;
# ... execute the tests
foreach my $test ($tests_ref->@*) {
# We know what we are expecting
my $expected = $test->{expected};
my $category_name = $test->{category_name};
# And do the test.
my $got = eval $test->{op};
if (! defined $got) {
output_test_failure_prefix($iteration,
$category_name,
$test);
output_test_result("expected", $expected,
1 # utf8ness matches, since only one
);
$errors++;
next;
}
my $utf8ness_matches = ( utf8::is_utf8($got)
== utf8::is_utf8($expected));
my $matched = ($got eq $expected);
if ($matched) {
if ($utf8ness_matches) {
no warnings 'uninitialized';
$corrects{$category_name}{$test->{locale_name}}{all}++;
$corrects{$category_name}{$test->{locale_name}}{$tid}++;
next; # Complete success!
}
}
$errors++;
output_test_failure_prefix($iteration, $category_name, $test);
if ($matched) {
print STDERR "Only difference is UTF8ness of results\n";
}
output_test_result("expected", $expected, $utf8ness_matches);
output_test_result("got", $got, $utf8ness_matches);
} # Loop to do the remaining tests for this iteration
return 0 if $errors;
$iteration++;
# A way to set a gdb break point pp_study
#study if $iteration % 10 == 0;
threads->yield();
}
return 1;
} # End of iterate() definition
EOT
$program .= "my $category_number_to_name\n";
$program .= <<'EOT';
sub setlocales {
# Set each category to the appropriate locale for this test set
my ($categories, $locales) = @_;
for my $i (0 .. $categories->@* - 1) {
if (! setlocale($categories->[$i], $locales->[$i])) {
my $category_name =
$map_category_number_to_name->{$categories->[$i]};
print STDERR "\nthread ", threads->tid(),
" setlocale($category_name ($categories->[$i]),",
" $locales->[$i]) failed\n";
return 0;
}
}
return 1;
}
my $startup_insurance = 1;
my $future = $startup_insurance + $thread_count * $per_thread_startup;
my $starting_time = time() + $future;
sub wait_until_time {
# Sleep until the time when all the threads are due to wake up, so
# they run as simultaneously as we can make it.
my $sleep_time = ($starting_time - time());
#printf STDERR "thread %d started, sleeping %g sec\n",
# threads->tid, $sleep_time;
if ($sleep_time < 0 && $die_on_negative_sleep) {
# What the start time should have been
my $a_better_future = $future - $sleep_time;
my $better_per_thread =
($a_better_future - $startup_insurance) / $thread_count;
printf STDERR "$per_thread_startup would need to be %g",
" for thread %d to have started\nin sync with",
" the other threads\n",
$better_per_thread, threads->tid;
die "Thread started too late";
}
else {
usleep($sleep_time * 1_000_000) if $sleep_time > 0;
}
}
# Create all the subthreads: 1..n
my @threads = map +threads->create(sub {
$SIG{'KILL'} = sub { threads->exit(); };
my $thread = shift;
# Start out with the set of tests whose number is the same as the
# thread number
my $test_set = $thread;
wait_until_time();
# Loop through all the iterations for this thread
my $this_iteration_start = 1;
do {
# Set up each category with its locale;
my $this_ref = $all_tests_ref->[$test_set];
return 0 unless setlocales($this_ref->{categories},
$this_ref->{locales});
# Then run one batch of iterations
my $result = iterate($thread,
$this_iteration_start,
$iterations_per_test_set,
$this_ref->{tests});
return 0 if $result == 0; # Quit if failed
# Next iteration will shift to use a different set of locales for
# each category
$test_set++;
$test_set = 0 if $test_set >= $thread_count;
$this_iteration_start += $iterations_per_test_set;
} while ($this_iteration_start <= $iterations);
return 1; # Success
}, $_), (1..$thread_count - 1); # For each non-0 thread
# Here is thread 0. We do a smaller chunk of iterations in it; then
# join whatever threads have finished so far, then do another chunk.
# This tests for bugs that arise as a result of joining.
my %thread0_corrects = ();
my $this_iteration_start = 1;
my $result = 1; # So far, everything is ok
my $test_set = -1; # Start with 0th test set
wait_until_time();
alarm($alarm_clock); # Guard against hangs
do {
# Next time, we'll use the next test set
$test_set++;
$test_set = 0 if $test_set >= $thread_count;
my $this_ref = $all_tests_ref->[$test_set];
# set the locales for this test set. Do this even if we
# are going to bail, so that it will be set correctly for the final
# batch after the loop.
$result &= setlocales($this_ref->{categories}, $this_ref->{locales});
if ($debug > 1) {
my @joinable = threads->list(threads::joinable);
if (@joinable) {
print STDERR "In thread 0, before iteration ",
$this_iteration_start,
" these threads are done: ",
join (", ", map { $_->tid() } @joinable),
"\n";
}
}
# Join anything already finished.
for my $thread (threads->list(threads::joinable)) {
my $thread_result = $thread->join;
if ($debug > 1) {
print STDERR "In thread 0, before iteration ",
$this_iteration_start,
" joining thread ", $thread->tid(),
"; result=", ((defined $thread_result)
? $thread_result
: "undef"),
"\n";
}
# If the thread failed badly, stop testing anything else.
if (! defined $thread_result) {
$_->kill('KILL')->detach() for threads->list();
print 0;
exit;
}
# Update the status
$result &= $thread_result;
}
# Do a chunk of iterations on this thread 0.
$result &= iterate(0,
$this_iteration_start,
$iterations_per_test_set,
$this_ref->{tests},
\%thread0_corrects);
$this_iteration_start += $iterations_per_test_set;
# And repeat as long as there are other tests
} while (threads->list(threads::all));
print $result;
EOT
# Finally ready to run the test.
fresh_perl_is($program,
1,
{ eval $switches },
"Verify there were no failures with simultaneous running threads"
);
}