lib/locale_threads.t

   1 use strict;
   2 use warnings;
   3
   4 # This file tests interactions with locale and threads
   5
   6 BEGIN {
   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
  21 local @ENV{'LANG', (grep /^LC_/, keys %ENV)};
  22
  23 SKIP: { # 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
  57 SKIP: {
  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             my $radix = localeconv()->{decimal_point};
  74             $comma ||= $_ if $radix eq ',';
  75         }
  76
  77         last if $dot && $comma;
  78     }
  79
  80     # See if multiple threads can simultaneously change the locale, and give
  81     # the expected radix results.  On systems without a comma radix locale,
  82     # run this anyway skipping the use of that, to verify that we don't
  83     # segfault
  84     fresh_perl_is("
  85         use threads;
  86         use strict;
  87         use warnings;
  88         use POSIX qw(locale_h);
  89
  90         my \$result = 1;
  91
  92         my \@threads = map +threads->create(sub {
  93             sleep 0.1;
  94             for (1..5_000) {
  95                 my \$s;
  96                 my \$in = 4.2; # avoid any constant folding bugs
  97
  98                 if ('$comma') {
  99                     setlocale(&LC_NUMERIC, '$comma');
 100                     use locale;
 101                     \$s = sprintf('%g', \$in);
 102                     return 0 if (\$s ne '4,2');
 103                 }
 104
 105                 setlocale(&LC_NUMERIC, '$dot');
 106                 \$s = sprintf('%g', \$in);
 107                 return 0 if (\$s ne '4.2');
 108             }
 109
 110             return 1;
 111
 112         }), (0..3);
 113         \$result &= \$_->join for splice \@threads;
 114         print \$result",
 115     1, {}, "Verify there were no failures with simultaneous running threads"
 116     );
 117 }
 118
 119 done_testing();