xref: /openbsd/gnu/usr.bin/perl/lib/locale_threads.t (revision f2a19305) 
1use strict;
2use warnings;
3
4# This file tests interactions with locale and threads
5
6BEGIN {
7    chdir 't' if -d 't';
8    require './test.pl';
9    set_up_inc('../lib');
10    require './loc_tools.pl';
11    skip_all("No locales") unless locales_enabled();
12    skip_all_without_config('useithreads');
13    $| = 1;
14    eval { require POSIX; POSIX->import(qw(locale_h  unistd_h)) };
15    if ($@) {
16	skip_all("could not load the POSIX module"); # running minitest?
17    }
18}
19
20# reset the locale environment
21local @ENV{'LANG', (grep /^LC_/, keys %ENV)};
22
23SKIP: { # perl #127708
24    my @locales = grep { $_ !~ / ^ C \b | POSIX /x } find_locales('LC_MESSAGES');
25    skip("No valid locale to test with", 1) unless @locales;
26
27    local $ENV{LC_MESSAGES} = $locales[0];
28
29    # We're going to try with all possible error numbers on this platform
30    my $error_count = keys(%!) + 1;
31
32    print fresh_perl("
33        use threads;
34        use strict;
35        use warnings;
36
37        my \$errnum = 1;
38
39        my \@threads = map +threads->create(sub {
40            sleep 0.1;
41
42            for (1..5_000) {
43                \$errnum = (\$errnum + 1) % $error_count;
44                \$! = \$errnum;
45
46                # no-op to trigger stringification
47                next if \"\$!\" eq \"\";
48            }
49        }), (0..1);
50        \$_->join for splice \@threads;",
51    {}
52    );
53
54    pass("Didn't segfault");
55}
56
57SKIP: {
58    skip("POSIX version doesn't support thread-safe locale operations", 1)
59                                                unless ${^SAFE_LOCALES};
60
61    my @locales = find_locales( 'LC_NUMERIC' );
62    skip("No LC_NUMERIC locales available", 1) unless @locales;
63
64    my $dot = "";
65    my $comma = "";
66    for (@locales) { # prefer C for the base if available
67        use locale;
68        setlocale(LC_NUMERIC, $_) or next;
69        my $in = 4.2; # avoid any constant folding bugs
70        if ((my $s = sprintf("%g", $in)) eq "4.2")  {
71            $dot ||= $_;
72        } else {
73            use I18N::Langinfo qw(langinfo RADIXCHAR);
74            my $radix = langinfo(RADIXCHAR);
75            $comma ||= $_ if $radix eq ',';
76        }
77
78        last if $dot && $comma;
79    }
80
81    # See if multiple threads can simultaneously change the locale, and give
82    # the expected radix results.  On systems without a comma radix locale,
83    # run this anyway skipping the use of that, to verify that we don't
84    # segfault
85    fresh_perl_is("
86        use threads;
87        use strict;
88        use warnings;
89        use POSIX qw(locale_h);
90
91        my \$result = 1;
92
93        my \@threads = map +threads->create(sub {
94            sleep 0.1;
95            for (1..5_000) {
96                my \$s;
97                my \$in = 4.2; # avoid any constant folding bugs
98
99                if ('$comma') {
100                    setlocale(&LC_NUMERIC, '$comma');
101                    use locale;
102                    \$s = sprintf('%g', \$in);
103                    return 0 if (\$s ne '4,2');
104                }
105
106                setlocale(&LC_NUMERIC, '$dot');
107                \$s = sprintf('%g', \$in);
108                return 0 if (\$s ne '4.2');
109            }
110
111            return 1;
112
113        }), (0..3);
114        \$result &= \$_->join for splice \@threads;
115        print \$result",
116    1, {}, "Verify there were no failures with simultaneous running threads"
117    );
118}
119
120done_testing();
121