This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
allow $fh->autoflush on globrefs, and thence autovivified filehandles
[perl5.git] / t / pragma / locale.t
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 ? 115 : 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     local $^W;  # no warnings 'undef'
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
392 sub tryneoalpha {
393     my ($Locale, $i, $test) = @_;
394     debug "# testing $i with locale '$Locale'\n"
395         unless $Testing{$i}{$Locale}++;
396     unless ($test) {
397         $Problem{$i}{$Locale} = 1;
398         debug "# failed $i with locale '$Locale'\n";
399     } else {
400         push @{$Okay{$i}}, $Locale;
401     }
402 }
403
404 foreach $Locale (@Locale) {
405     debug "# Locale = $Locale\n";
406     @Alnum_ = getalnum_();
407     debug "# \\w = @Alnum_\n";
408
409     unless (setlocale(LC_ALL, $Locale)) {
410         foreach (99..103) {
411             $Problem{$_}{$Locale} = -1;
412         }
413         next;
414     }
415
416     # Sieve the uppercase and the lowercase.
417     
418     my %UPPER = ();
419     my %lower = ();
420     my %BoThCaSe = ();
421     for (@Alnum_) {
422         if (/[^\d_]/) { # skip digits and the _
423             if (uc($_) eq $_) {
424                 $UPPER{$_} = $_;
425             }
426             if (lc($_) eq $_) {
427                 $lower{$_} = $_;
428             }
429         }
430     }
431     foreach (keys %UPPER) {
432         $BoThCaSe{$_}++ if exists $lower{$_};
433     }
434     foreach (keys %lower) {
435         $BoThCaSe{$_}++ if exists $UPPER{$_};
436     }
437     foreach (keys %BoThCaSe) {
438         delete $UPPER{$_};
439         delete $lower{$_};
440     }
441
442     debug "# UPPER    = ", join(" ", sort keys %UPPER   ), "\n";
443     debug "# lower    = ", join(" ", sort keys %lower   ), "\n";
444     debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n";
445
446     # Find the alphabets that are not alphabets in the default locale.
447
448     {
449         no locale;
450     
451         @Neoalpha = ();
452         for (keys %UPPER, keys %lower) {
453             push(@Neoalpha, $_) if (/\W/);
454         }
455     }
456
457     @Neoalpha = sort @Neoalpha;
458
459     debug "# Neoalpha = @Neoalpha\n";
460
461     if (@Neoalpha == 0) {
462         # If we have no Neoalphas the remaining tests are no-ops.
463         debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n";
464         foreach (99..102) {
465             push @{$Okay{$_}}, $Locale;
466         }
467     } else {
468
469         # Test \w.
470     
471         {
472             my $word = join('', @Neoalpha);
473
474             $word =~ /^(\w+)$/;
475
476             tryneoalpha($Locale, 99, $1 eq $word);
477         }
478
479         # Cross-check the whole 8-bit character set.
480
481         for (map { chr } 0..255) {
482             tryneoalpha($Locale, 100,
483                         (/\w/ xor /\W/) ||
484                         (/\d/ xor /\D/) ||
485                         (/\s/ xor /\S/));
486         }
487
488         # Test for read-only scalars' locale vs non-locale comparisons.
489
490         {
491             no locale;
492             $a = "qwerty";
493             {
494                 use locale;
495                 tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0);
496             }
497         }
498
499         {
500             my ($from, $to, $lesser, $greater,
501                 @test, %test, $test, $yes, $no, $sign);
502
503             for (0..9) {
504                 # Select a slice.
505                 $from = int(($_*@Alnum_)/10);
506                 $to = $from + int(@Alnum_/10);
507                 $to = $#Alnum_ if ($to > $#Alnum_);
508                 $lesser  = join('', @Alnum_[$from..$to]);
509                 # Select a slice one character on.
510                 $from++; $to++;
511                 $to = $#Alnum_ if ($to > $#Alnum_);
512                 $greater = join('', @Alnum_[$from..$to]);
513                 ($yes, $no, $sign) = ($lesser lt $greater
514                                       ? ("    ", "not ", 1)
515                                       : ("not ", "    ", -1));
516                 # all these tests should FAIL (return 0).
517                 # Exact lt or gt cannot be tested because
518                 # in some locales, say, eacute and E may test equal.
519                 @test = 
520                     (
521                      $no.'    ($lesser  le $greater)',  # 1
522                      'not      ($lesser  ne $greater)', # 2
523                      '         ($lesser  eq $greater)', # 3
524                      $yes.'    ($lesser  ge $greater)', # 4
525                      $yes.'    ($lesser  ge $greater)', # 5
526                      $yes.'    ($greater le $lesser )', # 7
527                      'not      ($greater ne $lesser )', # 8
528                      '         ($greater eq $lesser )', # 9
529                      $no.'     ($greater ge $lesser )', # 10
530                      'not (($lesser cmp $greater) == -$sign)' # 12
531                      );
532                 @test{@test} = 0 x @test;
533                 $test = 0;
534                 for my $ti (@test) {
535                     $test{$ti} = eval $ti;
536                     $test ||= $test{$ti}
537                 }
538                 tryneoalpha($Locale, 102, $test == 0);
539                 if ($test) {
540                     debug "# lesser  = '$lesser'\n";
541                     debug "# greater = '$greater'\n";
542                     debug "# lesser cmp greater = ",
543                           $lesser cmp $greater, "\n";
544                     debug "# greater cmp lesser = ",
545                           $greater cmp $lesser, "\n";
546                     debug "# (greater) from = $from, to = $to\n";
547                     for my $ti (@test) {
548                         debugf("# %-40s %-4s", $ti,
549                                $test{$ti} ? 'FAIL' : 'ok');
550                         if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
551                             debugf("(%s == %4d)", $1, eval $1);
552                         }
553                         debug "\n#";
554                     }
555
556                     last;
557                 }
558             }
559         }
560     }
561
562     use locale;
563
564     my ($x, $y) = (1.23, 1.23);
565
566     my $a = "$x";
567     printf ''; # printf used to reset locale to "C"
568     my $b = "$y";
569
570     debug "# 103..107: a = $a, b = $b, Locale = $Locale\n";
571
572     tryneoalpha($Locale, 103, $a eq $b);
573
574     my $c = "$x";
575     my $z = sprintf ''; # sprintf used to reset locale to "C"
576     my $d = "$y";
577
578     debug "# 104..107: c = $c, d = $d, Locale = $Locale\n";
579
580     tryneoalpha($Locale, 104, $c eq $d); 
581
582     {
583         my $w = 0;
584         local $SIG{__WARN__} = sub { $w++ };
585         local $^W = 1;
586
587         # the == (among other ops) used to warn for locales
588         # that had something else than "." as the radix character
589
590         tryneoalpha($Locale, 105, $c == 1.23);
591
592         tryneoalpha($Locale, 106, $c == $x);
593
594         tryneoalpha($Locale, 107, $c == $d);
595
596         {
597             no locale;
598         
599             my $e = "$x";
600
601             debug "# 108..110: e = $e, Locale = $Locale\n";
602
603             tryneoalpha($Locale, 108, $e == 1.23);
604
605             tryneoalpha($Locale, 109, $e == $x);
606             
607             tryneoalpha($Locale, 110, $e == $c);
608         }
609         
610         tryneoalpha($Locale, 111, $w == 0);
611
612         my $f = "1.23";
613
614         debug "# 112..114: f = $f, locale = $Locale\n";
615
616         tryneoalpha($Locale, 112, $f == 1.23);
617
618         tryneoalpha($Locale, 113, $f == $x);
619         
620         tryneoalpha($Locale, 114, $f == $c);
621     }
622
623     debug "# testing 115 with locale '$Locale'\n";
624     {
625         use locale;
626
627         sub lcA {
628             my $lc0 = lc $_[0];
629             my $lc1 = lc $_[1];
630             return $lc0 cmp $lc1;
631         }
632
633         sub lcB {
634             return lc($_[0]) cmp lc($_[1]);
635         }
636
637         my $x = "ab";
638         my $y = "aa";
639         my $z = "AB";
640
641         tryneoalpha($Locale, 115,
642                     lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
643                     lcA($x, $z) == 0 && lcB($x, $z) == 0);
644     }
645 }
646
647 # Recount the errors.
648
649 foreach (99..115) {
650     if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
651         if ($_ == 102) {
652             print "# The failure of test 102 is not necessarily fatal.\n";
653             print "# It usually indicates a problem in the enviroment,\n";
654             print "# not in Perl itself.\n";
655         }
656         print "not ";
657     }
658     print "ok $_\n";
659 }
660
661 # Give final advice.
662
663 my $didwarn = 0;
664
665 foreach (99..115) {
666     if ($Problem{$_}) {
667         my @f = sort keys %{ $Problem{$_} };
668         my $f = join(" ", @f);
669         $f =~ s/(.{50,60}) /$1\n#\t/g;
670         print
671             "#\n",
672             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
673             "#\t", $f, "\n#\n",
674             "# on your system may have errors because the locale test $_\n",
675             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
676             ".\n";
677         print <<EOW;
678 #
679 # If your users are not using these locales you are safe for the moment,
680 # but please report this failure first to perlbug\@perl.com using the
681 # perlbug script (as described in the INSTALL file) so that the exact
682 # details of the failures can be sorted out first and then your operating
683 # system supplier can be alerted about these anomalies.
684 #
685 EOW
686         $didwarn = 1;
687     }
688 }
689
690 # Tell which locales ere okay.
691
692 if ($didwarn) {
693     my @s;
694     
695     foreach my $l (@Locale) {
696         my $p = 0;
697         foreach my $t (102..102) {
698             $p++ if $Problem{$t}{$l};
699         }
700         push @s, $l if $p == 0;
701     }
702     
703     my $s = join(" ", @s);
704     $s =~ s/(.{50,60}) /$1\n#\t/g;
705
706     warn
707         "# The following locales\n#\n",
708         "#\t", $s, "\n#\n",
709         "# tested okay.\n#\n",
710 }
711
712 # eof