home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / locale.t < prev    next >
Text File  |  2000-03-13  |  16KB  |  735 lines
  1. #!./perl -wT
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6.     unshift @INC, '.';
  7.     require Config; import Config;
  8.     if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
  9.     print "1..0\n";
  10.     exit;
  11.     }
  12. }
  13.  
  14. use strict;
  15.  
  16. my $debug = 1;
  17.  
  18. sub debug {
  19.     print @_ if $debug;
  20. }
  21.  
  22. sub debugf {
  23.     printf @_ if $debug;
  24. }
  25.  
  26. my $have_setlocale = 0;
  27. eval {
  28.     require POSIX;
  29.     import POSIX ':locale_h';
  30.     $have_setlocale++;
  31. };
  32.  
  33. # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
  34. # and mingw32 uses said silly CRT
  35. $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
  36.  
  37. print "1..", ($have_setlocale ? 116 : 98), "\n";
  38.  
  39. use vars qw(&LC_ALL);
  40.  
  41. my $a = 'abc %';
  42.  
  43. sub ok {
  44.     my ($n, $result) = @_;
  45.  
  46.     print 'not ' unless ($result);
  47.     print "ok $n\n";
  48. }
  49.  
  50. # First we'll do a lot of taint checking for locales.
  51. # This is the easiest to test, actually, as any locale,
  52. # even the default locale will taint under 'use locale'.
  53.  
  54. sub is_tainted { # hello, camel two.
  55.     no warnings 'uninitialized' ;
  56.     my $dummy;
  57.     not eval { $dummy = join("", @_), kill 0; 1 }
  58. }
  59.  
  60. sub check_taint ($$) {
  61.     ok $_[0], is_tainted($_[1]);
  62. }
  63.  
  64. sub check_taint_not ($$) {
  65.     ok $_[0], not is_tainted($_[1]);
  66. }
  67.  
  68. use locale;    # engage locale and therefore locale taint.
  69.  
  70. check_taint_not   1, $a;
  71.  
  72. check_taint       2, uc($a);
  73. check_taint       3, "\U$a";
  74. check_taint       4, ucfirst($a);
  75. check_taint       5, "\u$a";
  76. check_taint       6, lc($a);
  77. check_taint       7, "\L$a";
  78. check_taint       8, lcfirst($a);
  79. check_taint       9, "\l$a";
  80.  
  81. check_taint_not  10, sprintf('%e', 123.456);
  82. check_taint_not  11, sprintf('%f', 123.456);
  83. check_taint_not  12, sprintf('%g', 123.456);
  84. check_taint_not  13, sprintf('%d', 123.456);
  85. check_taint_not  14, sprintf('%x', 123.456);
  86.  
  87. $_ = $a;    # untaint $_
  88.  
  89. $_ = uc($a);    # taint $_
  90.  
  91. check_taint      15, $_;
  92.  
  93. /(\w)/;    # taint $&, $`, $', $+, $1.
  94. check_taint      16, $&;
  95. check_taint      17, $`;
  96. check_taint      18, $';
  97. check_taint      19, $+;
  98. check_taint      20, $1;
  99. check_taint_not  21, $2;
  100.  
  101. /(.)/;    # untaint $&, $`, $', $+, $1.
  102. check_taint_not  22, $&;
  103. check_taint_not  23, $`;
  104. check_taint_not  24, $';
  105. check_taint_not  25, $+;
  106. check_taint_not  26, $1;
  107. check_taint_not  27, $2;
  108.  
  109. /(\W)/;    # taint $&, $`, $', $+, $1.
  110. check_taint      28, $&;
  111. check_taint      29, $`;
  112. check_taint      30, $';
  113. check_taint      31, $+;
  114. check_taint      32, $1;
  115. check_taint_not  33, $2;
  116.  
  117. /(\s)/;    # taint $&, $`, $', $+, $1.
  118. check_taint      34, $&;
  119. check_taint      35, $`;
  120. check_taint      36, $';
  121. check_taint      37, $+;
  122. check_taint      38, $1;
  123. check_taint_not  39, $2;
  124.  
  125. /(\S)/;    # taint $&, $`, $', $+, $1.
  126. check_taint      40, $&;
  127. check_taint      41, $`;
  128. check_taint      42, $';
  129. check_taint      43, $+;
  130. check_taint      44, $1;
  131. check_taint_not  45, $2;
  132.  
  133. $_ = $a;    # untaint $_
  134.  
  135. check_taint_not  46, $_;
  136.  
  137. /(b)/;        # this must not taint
  138. check_taint_not  47, $&;
  139. check_taint_not  48, $`;
  140. check_taint_not  49, $';
  141. check_taint_not  50, $+;
  142. check_taint_not  51, $1;
  143. check_taint_not  52, $2;
  144.  
  145. $_ = $a;    # untaint $_
  146.  
  147. check_taint_not  53, $_;
  148.  
  149. $b = uc($a);    # taint $b
  150. s/(.+)/$b/;    # this must taint only the $_
  151.  
  152. check_taint      54, $_;
  153. check_taint_not  55, $&;
  154. check_taint_not  56, $`;
  155. check_taint_not  57, $';
  156. check_taint_not  58, $+;
  157. check_taint_not  59, $1;
  158. check_taint_not  60, $2;
  159.  
  160. $_ = $a;    # untaint $_
  161.  
  162. s/(.+)/b/;    # this must not taint
  163. check_taint_not  61, $_;
  164. check_taint_not  62, $&;
  165. check_taint_not  63, $`;
  166. check_taint_not  64, $';
  167. check_taint_not  65, $+;
  168. check_taint_not  66, $1;
  169. check_taint_not  67, $2;
  170.  
  171. $b = $a;    # untaint $b
  172.  
  173. ($b = $a) =~ s/\w/$&/;
  174. check_taint      68, $b;    # $b should be tainted.
  175. check_taint_not  69, $a;    # $a should be not.
  176.  
  177. $_ = $a;    # untaint $_
  178.  
  179. s/(\w)/\l$1/;    # this must taint
  180. check_taint      70, $_;
  181. check_taint      71, $&;
  182. check_taint      72, $`;
  183. check_taint      73, $';
  184. check_taint      74, $+;
  185. check_taint      75, $1;
  186. check_taint_not  76, $2;
  187.  
  188. $_ = $a;    # untaint $_
  189.  
  190. s/(\w)/\L$1/;    # this must taint
  191. check_taint      77, $_;
  192. check_taint      78, $&;
  193. check_taint      79, $`;
  194. check_taint      80, $';
  195. check_taint      81, $+;
  196. check_taint      82, $1;
  197. check_taint_not  83, $2;
  198.  
  199. $_ = $a;    # untaint $_
  200.  
  201. s/(\w)/\u$1/;    # this must taint
  202. check_taint      84, $_;
  203. check_taint      85, $&;
  204. check_taint      86, $`;
  205. check_taint      87, $';
  206. check_taint      88, $+;
  207. check_taint      89, $1;
  208. check_taint_not  90, $2;
  209.  
  210. $_ = $a;    # untaint $_
  211.  
  212. s/(\w)/\U$1/;    # this must taint
  213. check_taint      91, $_;
  214. check_taint      92, $&;
  215. check_taint      93, $`;
  216. check_taint      94, $';
  217. check_taint      95, $+;
  218. check_taint      96, $1;
  219. check_taint_not  97, $2;
  220.  
  221. # After all this tainting $a should be cool.
  222.  
  223. check_taint_not  98, $a;
  224.  
  225. # I think we've seen quite enough of taint.
  226. # Let us do some *real* locale work now,
  227. # unless setlocale() is missing (i.e. minitest).
  228.  
  229. exit unless $have_setlocale;
  230.  
  231. # Find locales.
  232.  
  233. debug "# Scanning for locales...\n";
  234.  
  235. # Note that it's okay that some languages have their native names
  236. # capitalized here even though that's not "right".  They are lowercased
  237. # anyway later during the scanning process (and besides, some clueless
  238. # vendor might have them capitalized errorneously anyway).
  239.  
  240. my $locales = <<EOF;
  241. Afrikaans:af:za:1 15
  242. Arabic:ar:dz eg sa:6 arabic8
  243. Brezhoneg Breton:br:fr:1 15
  244. Bulgarski Bulgarian:bg:bg:5
  245. Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC
  246. Hrvatski Croatian:hr:hr:2
  247. Cymraeg Welsh:cy:cy:1 14 15
  248. Czech:cs:cz:2
  249. Dansk Danish:dk:da:1 15
  250. Nederlands Dutch:nl:be nl:1 15
  251. English American British:en:au ca gb ie nz us uk:1 15 cp850
  252. Esperanto:eo:eo:3
  253. Eesti Estonian:et:ee:4 6 13
  254. Suomi Finnish:fi:fi:1 15
  255. Flamish::fl:1 15
  256. Deutsch German:de:at be ch de lu:1 15
  257. Euskaraz Basque:eu:es fr:1 15
  258. Galego Galician:gl:es:1 15
  259. Ellada Greek:el:gr:7 g8
  260. Frysk:fy:nl:1 15
  261. Greenlandic:kl:gl:4 6
  262. Hebrew:iw:il:8 hebrew8
  263. Hungarian:hu:hu:2
  264. Indonesian:in:id:1 15
  265. Gaeilge Irish:ga:IE:1 14 15
  266. Italiano Italian:it:ch it:1 15
  267. Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
  268. Korean:ko:kr:
  269. Latine Latin:la:va:1 15
  270. Latvian:lv:lv:4 6 13
  271. Lithuanian:lt:lt:4 6 13
  272. Macedonian:mk:mk:1 15
  273. Maltese:mt:mt:3
  274. Norsk Norwegian:no:no:1 15
  275. Occitan:oc:es:1 15
  276. Polski Polish:pl:pl:2
  277. Rumanian:ro:ro:2
  278. Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251
  279. Serbski Serbian:sr:yu:5
  280. Slovak:sk:sk:2
  281. Slovene Slovenian:sl:si:2
  282. Sqhip Albanian:sq:sq:1 15
  283. Svenska Swedish:sv:fi se:1 15
  284. Thai:th:th:11 tis620
  285. Turkish:tr:tr:9 turkish8
  286. Yiddish:::1 15
  287. EOF
  288.  
  289. if ($^O eq 'os390') {
  290.     $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
  291.     $locales =~ s/Thai:th:th:11 tis620\n//;
  292. }
  293.  
  294. sub in_utf8 () { $^H & 0x08 }
  295.  
  296. if (in_utf8) {
  297.     require "pragma/locale/utf8";
  298. } else {
  299.     require "pragma/locale/latin1";
  300. }
  301.  
  302. my @Locale;
  303. my $Locale;
  304. my @Alnum_;
  305.  
  306. sub getalnum_ {
  307.     sort grep /\w/, map { chr } 0..255
  308. }
  309.  
  310. sub trylocale {
  311.     my $locale = shift;
  312.     if (setlocale(LC_ALL, $locale)) {
  313.     push @Locale, $locale;
  314.     }
  315. }
  316.  
  317. sub decode_encodings {
  318.     my @enc;
  319.  
  320.     foreach (split(/ /, shift)) {
  321.     if (/^(\d+)$/) {
  322.         push @enc, "ISO8859-$1";
  323.         push @enc, "iso8859$1";    # HP
  324.         if ($1 eq '1') {
  325.          push @enc, "roman8";    # HP
  326.         }
  327.     } else {
  328.         push @enc, $_;
  329.     }
  330.     }
  331.     if ($^O eq 'os390') {
  332.     push @enc, qw(IBM-037 IBM-819 IBM-1047);
  333.     }
  334.  
  335.     return @enc;
  336. }
  337.  
  338. trylocale("C");
  339. trylocale("POSIX");
  340. foreach (0..15) {
  341.     trylocale("ISO8859-$_");
  342.     trylocale("iso8859$_");
  343.     trylocale("iso8859-$_");
  344.     trylocale("iso_8859_$_");
  345.     trylocale("isolatin$_");
  346.     trylocale("isolatin-$_");
  347.     trylocale("iso_latin_$_");
  348. }
  349.  
  350. foreach my $locale (split(/\n/, $locales)) {
  351.     my ($locale_name, $language_codes, $country_codes, $encodings) =
  352.     split(/:/, $locale);
  353.     my @enc = decode_encodings($encodings);
  354.     foreach my $loc (split(/ /, $locale_name)) {
  355.     trylocale($loc);
  356.     foreach my $enc (@enc) {
  357.         trylocale("$loc.$enc");
  358.     }
  359.     $loc = lc $loc;
  360.     foreach my $enc (@enc) {
  361.         trylocale("$loc.$enc");
  362.     }
  363.     }
  364.     foreach my $lang (split(/ /, $language_codes)) {
  365.     trylocale($lang);
  366.     foreach my $country (split(/ /, $country_codes)) {
  367.         my $lc = "${lang}_${country}";
  368.         trylocale($lc);
  369.         foreach my $enc (@enc) {
  370.         trylocale("$lc.$enc");
  371.         }
  372.         my $lC = "${lang}_\U${country}";
  373.         trylocale($lC);
  374.         foreach my $enc (@enc) {
  375.         trylocale("$lC.$enc");
  376.         }
  377.     }
  378.     }
  379. }
  380.  
  381. setlocale(LC_ALL, "C");
  382.  
  383. @Locale = sort @Locale;
  384.  
  385. debug "# Locales = @Locale\n";
  386.  
  387. my %Problem;
  388. my %Okay;
  389. my %Testing;
  390. my @Neoalpha;
  391. my %Neoalpha;
  392.  
  393. sub tryneoalpha {
  394.     my ($Locale, $i, $test) = @_;
  395.     debug "# testing $i with locale '$Locale'\n"
  396.     unless $Testing{$i}{$Locale}++;
  397.     unless ($test) {
  398.     $Problem{$i}{$Locale} = 1;
  399.     debug "# failed $i with locale '$Locale'\n";
  400.     } else {
  401.     push @{$Okay{$i}}, $Locale;
  402.     }
  403. }
  404.  
  405. foreach $Locale (@Locale) {
  406.     debug "# Locale = $Locale\n";
  407.     @Alnum_ = getalnum_();
  408.     debug "# \\w = @Alnum_\n";
  409.  
  410.     unless (setlocale(LC_ALL, $Locale)) {
  411.     foreach (99..103) {
  412.         $Problem{$_}{$Locale} = -1;
  413.     }
  414.     next;
  415.     }
  416.  
  417.     # Sieve the uppercase and the lowercase.
  418.     
  419.     my %UPPER = ();
  420.     my %lower = ();
  421.     my %BoThCaSe = ();
  422.     for (@Alnum_) {
  423.     if (/[^\d_]/) { # skip digits and the _
  424.         if (uc($_) eq $_) {
  425.         $UPPER{$_} = $_;
  426.         }
  427.         if (lc($_) eq $_) {
  428.         $lower{$_} = $_;
  429.         }
  430.     }
  431.     }
  432.     foreach (keys %UPPER) {
  433.     $BoThCaSe{$_}++ if exists $lower{$_};
  434.     }
  435.     foreach (keys %lower) {
  436.     $BoThCaSe{$_}++ if exists $UPPER{$_};
  437.     }
  438.     foreach (keys %BoThCaSe) {
  439.     delete $UPPER{$_};
  440.     delete $lower{$_};
  441.     }
  442.  
  443.     debug "# UPPER    = ", join(" ", sort keys %UPPER   ), "\n";
  444.     debug "# lower    = ", join(" ", sort keys %lower   ), "\n";
  445.     debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n";
  446.  
  447.     # Find the alphabets that are not alphabets in the default locale.
  448.  
  449.     {
  450.     no locale;
  451.     
  452.     @Neoalpha = ();
  453.     for (keys %UPPER, keys %lower) {
  454.         push(@Neoalpha, $_) if (/\W/);
  455.         $Neoalpha{$_} = $_;
  456.     }
  457.     }
  458.  
  459.     @Neoalpha = sort @Neoalpha;
  460.  
  461.     debug "# Neoalpha = @Neoalpha\n";
  462.  
  463.     if (@Neoalpha == 0) {
  464.     # If we have no Neoalphas the remaining tests are no-ops.
  465.     debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n";
  466.     foreach (99..102) {
  467.         push @{$Okay{$_}}, $Locale;
  468.     }
  469.     } else {
  470.  
  471.     # Test \w.
  472.     
  473.     {
  474.         my $word = join('', @Neoalpha);
  475.  
  476.         $word =~ /^(\w+)$/;
  477.  
  478.         tryneoalpha($Locale, 99, $1 eq $word);
  479.     }
  480.  
  481.     # Cross-check the whole 8-bit character set.
  482.  
  483.     for (map { chr } 0..255) {
  484.         tryneoalpha($Locale, 100,
  485.             (/\w/ xor /\W/) ||
  486.             (/\d/ xor /\D/) ||
  487.             (/\s/ xor /\S/));
  488.     }
  489.  
  490.     # Test for read-only scalars' locale vs non-locale comparisons.
  491.  
  492.     {
  493.         no locale;
  494.         $a = "qwerty";
  495.         {
  496.         use locale;
  497.         tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0);
  498.         }
  499.     }
  500.  
  501.     {
  502.         my ($from, $to, $lesser, $greater,
  503.         @test, %test, $test, $yes, $no, $sign);
  504.  
  505.         for (0..9) {
  506.         # Select a slice.
  507.         $from = int(($_*@Alnum_)/10);
  508.         $to = $from + int(@Alnum_/10);
  509.         $to = $#Alnum_ if ($to > $#Alnum_);
  510.         $lesser  = join('', @Alnum_[$from..$to]);
  511.         # Select a slice one character on.
  512.         $from++; $to++;
  513.         $to = $#Alnum_ if ($to > $#Alnum_);
  514.         $greater = join('', @Alnum_[$from..$to]);
  515.         ($yes, $no, $sign) = ($lesser lt $greater
  516.                       ? ("    ", "not ", 1)
  517.                       : ("not ", "    ", -1));
  518.         # all these tests should FAIL (return 0).
  519.         # Exact lt or gt cannot be tested because
  520.         # in some locales, say, eacute and E may test equal.
  521.         @test = 
  522.             (
  523.              $no.'    ($lesser  le $greater)',  # 1
  524.              'not      ($lesser  ne $greater)', # 2
  525.              '         ($lesser  eq $greater)', # 3
  526.              $yes.'    ($lesser  ge $greater)', # 4
  527.              $yes.'    ($lesser  ge $greater)', # 5
  528.              $yes.'    ($greater le $lesser )', # 7
  529.              'not      ($greater ne $lesser )', # 8
  530.              '         ($greater eq $lesser )', # 9
  531.              $no.'     ($greater ge $lesser )', # 10
  532.              'not (($lesser cmp $greater) == -$sign)' # 12
  533.              );
  534.         @test{@test} = 0 x @test;
  535.         $test = 0;
  536.         for my $ti (@test) {
  537.             $test{$ti} = eval $ti;
  538.             $test ||= $test{$ti}
  539.         }
  540.         tryneoalpha($Locale, 102, $test == 0);
  541.         if ($test) {
  542.             debug "# lesser  = '$lesser'\n";
  543.             debug "# greater = '$greater'\n";
  544.             debug "# lesser cmp greater = ",
  545.                   $lesser cmp $greater, "\n";
  546.             debug "# greater cmp lesser = ",
  547.                   $greater cmp $lesser, "\n";
  548.             debug "# (greater) from = $from, to = $to\n";
  549.             for my $ti (@test) {
  550.             debugf("# %-40s %-4s", $ti,
  551.                    $test{$ti} ? 'FAIL' : 'ok');
  552.             if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
  553.                 debugf("(%s == %4d)", $1, eval $1);
  554.             }
  555.             debug "\n#";
  556.             }
  557.  
  558.             last;
  559.         }
  560.         }
  561.     }
  562.     }
  563.  
  564.     use locale;
  565.  
  566.     my ($x, $y) = (1.23, 1.23);
  567.  
  568.     my $a = "$x";
  569.     printf ''; # printf used to reset locale to "C"
  570.     my $b = "$y";
  571.  
  572.     debug "# 103..107: a = $a, b = $b, Locale = $Locale\n";
  573.  
  574.     tryneoalpha($Locale, 103, $a eq $b);
  575.  
  576.     my $c = "$x";
  577.     my $z = sprintf ''; # sprintf used to reset locale to "C"
  578.     my $d = "$y";
  579.  
  580.     debug "# 104..107: c = $c, d = $d, Locale = $Locale\n";
  581.  
  582.     tryneoalpha($Locale, 104, $c eq $d); 
  583.  
  584.     {
  585.     use warnings;
  586.     my $w = 0;
  587.     local $SIG{__WARN__} = sub { $w++ };
  588.  
  589.     # the == (among other ops) used to warn for locales
  590.     # that had something else than "." as the radix character
  591.  
  592.     tryneoalpha($Locale, 105, $c == 1.23);
  593.  
  594.     tryneoalpha($Locale, 106, $c == $x);
  595.  
  596.     tryneoalpha($Locale, 107, $c == $d);
  597.  
  598.     {
  599.         no locale;
  600.     
  601.         my $e = "$x";
  602.  
  603.         debug "# 108..110: e = $e, Locale = $Locale\n";
  604.  
  605.         tryneoalpha($Locale, 108, $e == 1.23);
  606.  
  607.         tryneoalpha($Locale, 109, $e == $x);
  608.         
  609.         tryneoalpha($Locale, 110, $e == $c);
  610.     }
  611.     
  612.     tryneoalpha($Locale, 111, $w == 0);
  613.  
  614.     my $f = "1.23";
  615.  
  616.     debug "# 112..114: f = $f, locale = $Locale\n";
  617.  
  618.     tryneoalpha($Locale, 112, $f == 1.23);
  619.  
  620.     tryneoalpha($Locale, 113, $f == $x);
  621.     
  622.     tryneoalpha($Locale, 114, $f == $c);
  623.     }
  624.  
  625.     debug "# testing 115 with locale '$Locale'\n";
  626.     {
  627.     use locale;
  628.  
  629.     sub lcA {
  630.         my $lc0 = lc $_[0];
  631.         my $lc1 = lc $_[1];
  632.         return $lc0 cmp $lc1;
  633.     }
  634.  
  635.         sub lcB {
  636.         return lc($_[0]) cmp lc($_[1]);
  637.     }
  638.  
  639.         my $x = "ab";
  640.         my $y = "aa";
  641.         my $z = "AB";
  642.  
  643.         tryneoalpha($Locale, 115,
  644.             lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
  645.             lcA($x, $z) == 0 && lcB($x, $z) == 0);
  646.     }
  647.  
  648.     debug "# testing 116 with locale '$Locale'\n";
  649.     {
  650.     use locale;
  651.  
  652.     my @f = ();
  653.     foreach my $x (keys %UPPER) {
  654.         my $y = lc $x;
  655.         next unless uc $y eq $x;
  656.         push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
  657.     }
  658.     foreach my $x (keys %lower) {
  659.         my $y = uc $x;
  660.         next unless lc $y eq $x;
  661.         push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
  662.     }
  663.     tryneoalpha($Locale, 116, @f == 0);
  664.     print "# testing 116 failed for locale '$Locale' for characters @f\n"
  665.             if @f;
  666.     }
  667. }
  668.  
  669. # Recount the errors.
  670.  
  671. foreach (99..116) {
  672.     if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
  673.     if ($_ == 102) {
  674.         print "# The failure of test 102 is not necessarily fatal.\n";
  675.         print "# It usually indicates a problem in the enviroment,\n";
  676.         print "# not in Perl itself.\n";
  677.     }
  678.     print "not ";
  679.     }
  680.     print "ok $_\n";
  681. }
  682.  
  683. # Give final advice.
  684.  
  685. my $didwarn = 0;
  686.  
  687. foreach (99..116) {
  688.     if ($Problem{$_}) {
  689.     my @f = sort keys %{ $Problem{$_} };
  690.     my $f = join(" ", @f);
  691.     $f =~ s/(.{50,60}) /$1\n#\t/g;
  692.     print
  693.         "#\n",
  694.             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
  695.         "#\t", $f, "\n#\n",
  696.         "# on your system may have errors because the locale test $_\n",
  697.             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
  698.             ".\n";
  699.     print <<EOW;
  700. #
  701. # If your users are not using these locales you are safe for the moment,
  702. # but please report this failure first to perlbug\@perl.com using the
  703. # perlbug script (as described in the INSTALL file) so that the exact
  704. # details of the failures can be sorted out first and then your operating
  705. # system supplier can be alerted about these anomalies.
  706. #
  707. EOW
  708.     $didwarn = 1;
  709.     }
  710. }
  711.  
  712. # Tell which locales ere okay.
  713.  
  714. if ($didwarn) {
  715.     my @s;
  716.     
  717.     foreach my $l (@Locale) {
  718.     my $p = 0;
  719.     foreach my $t (102..102) {
  720.         $p++ if $Problem{$t}{$l};
  721.     }
  722.     push @s, $l if $p == 0;
  723.     }
  724.     
  725.     my $s = join(" ", @s);
  726.     $s =~ s/(.{50,60}) /$1\n#\t/g;
  727.  
  728.     warn
  729.     "# The following locales\n#\n",
  730.         "#\t", $s, "\n#\n",
  731.     "# tested okay.\n#\n",
  732. }
  733.  
  734. # eof
  735.