t/loc_tools.pl

   1 # Common tools for test files files to find the locales which exist on the
   2 # system.  Caller should have defined ok() for the unlikely event that setup
   3 # here fails, and should have verified that this isn't miniperl before calling
   4 # the functions.
   5
   6 # Note that it's okay that some languages have their native names
   7 # capitalized here even though that's not "right".  They are lowercased
   8 # anyway later during the scanning process (and besides, some clueless
   9 # vendor might have them capitalized erroneously anyway).
  10
  11 # Some of the locales on the system may not play well with Perl.  Since, we
  12 # may be trying every possible locale, we don't want to be warned about the
  13 # weird ones.
  14 no warnings 'locale';
  15
  16 sub _trylocale {    # Adds the locale given by the first parameter to the list
  17                     # given by the 3rd iff the platform supports the locale in
  18                     # each of the categories given by the 2nd parameter, which
  19                     # is either a single category or a reference to a list of
  20                     # categories
  21     my $locale = shift;
  22     my $categories = shift;
  23     my $list = shift;
  24     return if ! $locale || grep { $locale eq $_ } @$list;
  25
  26     $categories = [ $categories ] unless ref $categories;
  27
  28     foreach my $category (@$categories) {
  29         return unless setlocale($category, $locale);
  30     }
  31
  32     my $badutf8;
  33     {
  34         local $SIG{__WARN__} = sub {
  35             $badutf8 = $_[0] =~ /Malformed UTF-8/;
  36         };
  37     }
  38
  39     if ($badutf8) {
  40         ok(0, "Verify locale name doesn't contain malformed utf8");
  41         return;
  42     }
  43     push @$list, $locale;
  44 }
  45
  46 sub _decode_encodings {
  47     my @enc;
  48
  49     foreach (split(/ /, shift)) {
  50         if (/^(\d+)$/) {
  51             push @enc, "ISO8859-$1";
  52             push @enc, "iso8859$1";     # HP
  53             if ($1 eq '1') {
  54                  push @enc, "roman8";   # HP
  55             }
  56             push @enc, $_;
  57             push @enc, "$_.UTF-8";
  58             push @enc, "$_.65001"; # Windows UTF-8
  59             push @enc, "$_.ACP"; # Windows ANSI code page
  60             push @enc, "$_.OCP"; # Windows OEM code page
  61             push @enc, "$_.1252"; # Windows
  62         }
  63     }
  64     if ($^O eq 'os390') {
  65         push @enc, qw(IBM-037 IBM-819 IBM-1047);
  66     }
  67     push @enc, "UTF-8";
  68     push @enc, "65001"; # Windows UTF-8
  69
  70     return @enc;
  71 }
  72
  73 sub find_locales ($) {  # Returns an array of all the locales we found on the
  74                         # system.  The parameter is either a single locale
  75                         # category or a reference to a list of categories to
  76                         # find valid locales for it (or in the case of
  77                         # multiple) for all of them.  Note that currently the
  78                         # array includes even those locales that don't play
  79                         # well with Perl
  80     my $categories = shift;
  81
  82     use Config;;
  83     my $have_setlocale = $Config{d_setlocale};
  84
  85     # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
  86     # and mingw32 uses said silly CRT
  87     # This doesn't seem to be an issue any more, at least on Windows XP,
  88     # so re-enable the tests for Windows XP onwards.
  89     my $winxp = ($^O eq 'MSWin32' && defined &Win32::GetOSVersion &&
  90                     join('.', (Win32::GetOSVersion())[1..2]) >= 5.1);
  91     $have_setlocale = 0 if ((($^O eq 'MSWin32' && !$winxp) || $^O eq 'NetWare') &&
  92                     $Config{cc} =~ /^(cl|gcc|g\+\+|ici)/i);
  93
  94     # UWIN seems to loop after taint tests, just skip for now
  95     $have_setlocale = 0 if ($^O =~ /^uwin/);
  96
  97     return unless $have_setlocale;
  98
  99     # Done this way in case this is 'required' in the caller before seeing if
 100     # this is miniperl.
 101     eval { require POSIX; import POSIX 'locale_h'; };
 102     unless (defined &POSIX::LC_CTYPE) {
 103       return;
 104     }
 105
 106     _trylocale("C", $categories, \@Locale);
 107     _trylocale("POSIX", $categories, \@Locale);
 108     foreach (0..15) {
 109         _trylocale("ISO8859-$_", $categories, \@Locale);
 110         _trylocale("iso8859$_", $categories, \@Locale);
 111         _trylocale("iso8859-$_", $categories, \@Locale);
 112         _trylocale("iso_8859_$_", $categories, \@Locale);
 113         _trylocale("isolatin$_", $categories, \@Locale);
 114         _trylocale("isolatin-$_", $categories, \@Locale);
 115         _trylocale("iso_latin_$_", $categories, \@Locale);
 116     }
 117
 118     # Sanitize the environment so that we can run the external 'locale'
 119     # program without the taint mode getting grumpy.
 120
 121     # $ENV{PATH} is special in VMS.
 122     delete local $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
 123
 124     # Other subversive stuff.
 125     delete local @ENV{qw(IFS CDPATH ENV BASH_ENV)};
 126
 127     if (-x "/usr/bin/locale"
 128         && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|"))
 129     {
 130         while (<LOCALES>) {
 131             # It seems that /usr/bin/locale steadfastly outputs 8 bit data, which
 132             # ain't great when we're running this testPERL_UNICODE= so that utf8
 133             # locales will cause all IO hadles to default to (assume) utf8
 134             next unless utf8::valid($_);
 135             chomp;
 136             _trylocale($_, $categories, \@Locale);
 137         }
 138         close(LOCALES);
 139     } elsif ($^O eq 'VMS'
 140              && defined($ENV{'SYS$I18N_LOCALE'})
 141              && -d 'SYS$I18N_LOCALE')
 142     {
 143     # The SYS$I18N_LOCALE logical name search list was not present on
 144     # VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
 145         opendir(LOCALES, "SYS\$I18N_LOCALE:");
 146         while ($_ = readdir(LOCALES)) {
 147             chomp;
 148             _trylocale($_, $categories, \@Locale);
 149         }
 150         close(LOCALES);
 151     } elsif (($^O eq 'openbsd' || $^O eq 'bitrig' ) && -e '/usr/share/locale') {
 152
 153     # OpenBSD doesn't have a locale executable, so reading /usr/share/locale
 154     # is much easier and faster than the last resort method.
 155
 156         opendir(LOCALES, '/usr/share/locale');
 157         while ($_ = readdir(LOCALES)) {
 158             chomp;
 159             _trylocale($_, $categories, \@Locale);
 160         }
 161         close(LOCALES);
 162     } else { # Final fallback.  Try our list of locales hard-coded here
 163
 164         # This is going to be slow.
 165         my @Data;
 166
 167         # Locales whose name differs if the utf8 bit is on are stored in these two
 168         # files with appropriate encodings.
 169         if ($^H & 0x08 || (${^OPEN} || "") =~ /:utf8/) {
 170             @Data = do "lib/locale/utf8";
 171         } else {
 172             @Data = do "lib/locale/latin1";
 173         }
 174
 175         # The rest of the locales are in this file.
 176         push @Data, <DATA>;
 177
 178         foreach my $line (@Data) {
 179             my ($locale_name, $language_codes, $country_codes, $encodings) =
 180                 split /:/, $line;
 181             my @enc = _decode_encodings($encodings);
 182             foreach my $loc (split(/ /, $locale_name)) {
 183                 _trylocale($loc, $categories, \@Locale);
 184                 foreach my $enc (@enc) {
 185                     _trylocale("$loc.$enc", $categories, \@Locale);
 186                 }
 187                 $loc = lc $loc;
 188                 foreach my $enc (@enc) {
 189                     _trylocale("$loc.$enc", $categories, \@Locale);
 190                 }
 191             }
 192             foreach my $lang (split(/ /, $language_codes)) {
 193                 _trylocale($lang, $categories, \@Locale);
 194                 foreach my $country (split(/ /, $country_codes)) {
 195                     my $lc = "${lang}_${country}";
 196                     _trylocale($lc, $categories, \@Locale);
 197                     foreach my $enc (@enc) {
 198                         _trylocale("$lc.$enc", $categories, \@Locale);
 199                     }
 200                     my $lC = "${lang}_\U${country}";
 201                     _trylocale($lC, $categories, \@Locale);
 202                     foreach my $enc (@enc) {
 203                         _trylocale("$lC.$enc", $categories, \@Locale);
 204                     }
 205                 }
 206             }
 207         }
 208     }
 209
 210     @Locale = sort @Locale;
 211
 212     return @Locale;
 213 }
 214
 215 sub is_locale_utf8 ($) { # Return a boolean as to if core Perl thinks the input
 216                          # is a UTF-8 locale
 217
 218     # On z/OS, even locales marked as UTF-8 aren't.
 219     return 0 if ord "A" != 65;
 220
 221     my $locale = shift;
 222
 223     use locale;
 224
 225     my $save_locale = setlocale(&POSIX::LC_CTYPE());
 226     if (! $save_locale) {
 227         ok(0, "Verify could save previous locale");
 228         return 0;
 229     }
 230
 231     if (! setlocale(&POSIX::LC_CTYPE(), $locale)) {
 232         ok(0, "Verify could setlocale to $locale");
 233         return 0;
 234     }
 235
 236     my $ret = 0;
 237
 238     # Use an op that gives different results for UTF-8 than any other locale.
 239     # If a platform has UTF-8 locales, there should be at least one locale on
 240     # most platforms with UTF-8 in its name, so if there is a bug in the op
 241     # giving a false negative, we should get a failure for those locales as we
 242     # go through testing all the locales on the platform.
 243     if (CORE::fc(chr utf8::unicode_to_native(0xdf)) ne "ss") {
 244         if ($locale =~ /UTF-?8/i) {
 245             ok (0, "Verify $locale with UTF-8 in name is a UTF-8 locale");
 246         }
 247     }
 248     else {
 249         $ret = 1;
 250     }
 251
 252     die "Couldn't restore locale '$save_locale'"
 253         unless setlocale(&POSIX::LC_CTYPE(), $save_locale);
 254
 255     return $ret;
 256 }
 257
 258 sub find_utf8_ctype_locale (;$) { # Return the name of a locale that core Perl
 259                                   # thinks is a UTF-8 LC_CTYPE locale.
 260                                   # Optional parameter is a reference to a
 261                                   # list of locales to try; if omitted, this
 262                                   # tries all locales it can find on the
 263                                   # platform
 264     my $locales_ref = shift;
 265     return if !defined &POSIX::LC_CTYPE;
 266     if (! defined $locales_ref) {
 267         my @locales = find_locales(&POSIX::LC_CTYPE());
 268         $locales_ref = \@locales;
 269     }
 270
 271     foreach my $locale (@$locales_ref) {
 272         return $locale if is_locale_utf8($locale);
 273     }
 274
 275     return;
 276 }
 277
 278 1
 279
 280 # Format of data is: locale_name, language_codes, country_codes, encodings
 281 __DATA__
 282 Afrikaans:af:za:1 15
 283 Arabic:ar:dz eg sa:6 arabic8
 284 Brezhoneg Breton:br:fr:1 15
 285 Bulgarski Bulgarian:bg:bg:5
 286 Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
 287 Hrvatski Croatian:hr:hr:2
 288 Cymraeg Welsh:cy:cy:1 14 15
 289 Czech:cs:cz:2
 290 Dansk Danish:da:dk:1 15
 291 Nederlands Dutch:nl:be nl:1 15
 292 English American British:en:au ca gb ie nz us uk zw:1 15 cp850
 293 Esperanto:eo:eo:3
 294 Eesti Estonian:et:ee:4 6 13
 295 Suomi Finnish:fi:fi:1 15
 296 Flamish::fl:1 15
 297 Deutsch German:de:at be ch de lu:1 15
 298 Euskaraz Basque:eu:es fr:1 15
 299 Galego Galician:gl:es:1 15
 300 Ellada Greek:el:gr:7 g8
 301 Frysk:fy:nl:1 15
 302 Greenlandic:kl:gl:4 6
 303 Hebrew:iw:il:8 hebrew8
 304 Hungarian:hu:hu:2
 305 Indonesian:id:id:1 15
 306 Gaeilge Irish:ga:IE:1 14 15
 307 Italiano Italian:it:ch it:1 15
 308 Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
 309 Korean:ko:kr:
 310 Latine Latin:la:va:1 15
 311 Latvian:lv:lv:4 6 13
 312 Lithuanian:lt:lt:4 6 13
 313 Macedonian:mk:mk:1 15
 314 Maltese:mt:mt:3
 315 Moldovan:mo:mo:2
 316 Norsk Norwegian:no no\@nynorsk nb nn:no:1 15
 317 Occitan:oc:es:1 15
 318 Polski Polish:pl:pl:2
 319 Rumanian:ro:ro:2
 320 Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
 321 Serbski Serbian:sr:yu:5
 322 Slovak:sk:sk:2
 323 Slovene Slovenian:sl:si:2
 324 Sqhip Albanian:sq:sq:1 15
 325 Svenska Swedish:sv:fi se:1 15
 326 Thai:th:th:11 tis620
 327 Turkish:tr:tr:9 turkish8
 328 Yiddish:yi::1 15