This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Yet another OS/2 patch
[perl5.git] / t / pragma / locale.t
1 #!./perl -wT
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require Config; import Config;
7     if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
8         print "1..0\n";
9         exit;
10     }
11 }
12
13 use strict;
14
15 my $have_setlocale = 0;
16 eval {
17     require POSIX;
18     import POSIX ':locale_h';
19     $have_setlocale++;
20 };
21
22 # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
23 # and mingw32 uses said silly CRT
24 $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
25
26 # 103 (the last test) may fail but that is okay.
27 # (It indicates something broken in the environment, not Perl)
28 # Therefore .. only until 102, not 103.
29 print "1..", ($have_setlocale ? 102 : 98), "\n";
30
31 use vars qw($a
32             $English $German $French $Spanish
33             @C @English @German @French @Spanish
34             $Locale @Locale %iLocale %UPPER %lower @Neoalpha);
35
36 $a = 'abc %';
37
38 sub ok {
39     my ($n, $result) = @_;
40
41     print 'not ' unless ($result);
42     print "ok $n\n";
43 }
44
45 # First we'll do a lot of taint checking for locales.
46 # This is the easiest to test, actually, as any locale,
47 # even the default locale will taint under 'use locale'.
48
49 sub is_tainted { # hello, camel two.
50     local $^W;  # no warnings 'undef'
51     my $dummy;
52     not eval { $dummy = join("", @_), kill 0; 1 }
53 }
54
55 sub check_taint ($$) {
56     ok $_[0], is_tainted($_[1]);
57 }
58
59 sub check_taint_not ($$) {
60     ok $_[0], not is_tainted($_[1]);
61 }
62
63 use locale;     # engage locale and therefore locale taint.
64
65 check_taint_not   1, $a;
66
67 check_taint       2, uc($a);
68 check_taint       3, "\U$a";
69 check_taint       4, ucfirst($a);
70 check_taint       5, "\u$a";
71 check_taint       6, lc($a);
72 check_taint       7, "\L$a";
73 check_taint       8, lcfirst($a);
74 check_taint       9, "\l$a";
75
76 check_taint      10, sprintf('%e', 123.456);
77 check_taint      11, sprintf('%f', 123.456);
78 check_taint      12, sprintf('%g', 123.456);
79 check_taint_not  13, sprintf('%d', 123.456);
80 check_taint_not  14, sprintf('%x', 123.456);
81
82 $_ = $a;        # untaint $_
83
84 $_ = uc($a);    # taint $_
85
86 check_taint      15, $_;
87
88 /(\w)/; # taint $&, $`, $', $+, $1.
89 check_taint      16, $&;
90 check_taint      17, $`;
91 check_taint      18, $';
92 check_taint      19, $+;
93 check_taint      20, $1;
94 check_taint_not  21, $2;
95
96 /(.)/;  # untaint $&, $`, $', $+, $1.
97 check_taint_not  22, $&;
98 check_taint_not  23, $`;
99 check_taint_not  24, $';
100 check_taint_not  25, $+;
101 check_taint_not  26, $1;
102 check_taint_not  27, $2;
103
104 /(\W)/; # taint $&, $`, $', $+, $1.
105 check_taint      28, $&;
106 check_taint      29, $`;
107 check_taint      30, $';
108 check_taint      31, $+;
109 check_taint      32, $1;
110 check_taint_not  33, $2;
111
112 /(\s)/; # taint $&, $`, $', $+, $1.
113 check_taint      34, $&;
114 check_taint      35, $`;
115 check_taint      36, $';
116 check_taint      37, $+;
117 check_taint      38, $1;
118 check_taint_not  39, $2;
119
120 /(\S)/; # taint $&, $`, $', $+, $1.
121 check_taint      40, $&;
122 check_taint      41, $`;
123 check_taint      42, $';
124 check_taint      43, $+;
125 check_taint      44, $1;
126 check_taint_not  45, $2;
127
128 $_ = $a;        # untaint $_
129
130 check_taint_not  46, $_;
131
132 /(b)/;          # this must not taint
133 check_taint_not  47, $&;
134 check_taint_not  48, $`;
135 check_taint_not  49, $';
136 check_taint_not  50, $+;
137 check_taint_not  51, $1;
138 check_taint_not  52, $2;
139
140 $_ = $a;        # untaint $_
141
142 check_taint_not  53, $_;
143
144 $b = uc($a);    # taint $b
145 s/(.+)/$b/;     # this must taint only the $_
146
147 check_taint      54, $_;
148 check_taint_not  55, $&;
149 check_taint_not  56, $`;
150 check_taint_not  57, $';
151 check_taint_not  58, $+;
152 check_taint_not  59, $1;
153 check_taint_not  60, $2;
154
155 $_ = $a;        # untaint $_
156
157 s/(.+)/b/;      # this must not taint
158 check_taint_not  61, $_;
159 check_taint_not  62, $&;
160 check_taint_not  63, $`;
161 check_taint_not  64, $';
162 check_taint_not  65, $+;
163 check_taint_not  66, $1;
164 check_taint_not  67, $2;
165
166 $b = $a;        # untaint $b
167
168 ($b = $a) =~ s/\w/$&/;
169 check_taint      68, $b;        # $b should be tainted.
170 check_taint_not  69, $a;        # $a should be not.
171
172 $_ = $a;        # untaint $_
173
174 s/(\w)/\l$1/;   # this must taint
175 check_taint      70, $_;
176 check_taint      71, $&;
177 check_taint      72, $`;
178 check_taint      73, $';
179 check_taint      74, $+;
180 check_taint      75, $1;
181 check_taint_not  76, $2;
182
183 $_ = $a;        # untaint $_
184
185 s/(\w)/\L$1/;   # this must taint
186 check_taint      77, $_;
187 check_taint      78, $&;
188 check_taint      79, $`;
189 check_taint      80, $';
190 check_taint      81, $+;
191 check_taint      82, $1;
192 check_taint_not  83, $2;
193
194 $_ = $a;        # untaint $_
195
196 s/(\w)/\u$1/;   # this must taint
197 check_taint      84, $_;
198 check_taint      85, $&;
199 check_taint      86, $`;
200 check_taint      87, $';
201 check_taint      88, $+;
202 check_taint      89, $1;
203 check_taint_not  90, $2;
204
205 $_ = $a;        # untaint $_
206
207 s/(\w)/\U$1/;   # this must taint
208 check_taint      91, $_;
209 check_taint      92, $&;
210 check_taint      93, $`;
211 check_taint      94, $';
212 check_taint      95, $+;
213 check_taint      96, $1;
214 check_taint_not  97, $2;
215
216 # After all this tainting $a should be cool.
217
218 check_taint_not  98, $a;
219
220 # I think we've seen quite enough of taint.
221 # Let us do some *real* locale work now,
222 #  unless setlocale() is missing (i.e. minitest).
223
224 exit unless $have_setlocale;
225
226 sub getalnum {
227     sort grep /\w/, map { chr } 0..255
228 }
229
230 sub locatelocale ($$@) {
231     my ($lcall, $alnum, @try) = @_;
232
233     undef $$lcall;
234
235     for (@try) {
236         local $^W = 0; # suppress "Subroutine LC_ALL redefined"
237         if (setlocale(&LC_ALL, $_)) {
238             $$lcall = $_;
239             @$alnum = &getalnum;
240             last;
241         }
242     }
243
244     @$alnum = () unless (defined $$lcall);
245 }
246
247 # Find some default locale
248
249 locatelocale(\$Locale, \@Locale, qw(C POSIX));
250
251 # Find some English locale
252
253 locatelocale(\$English, \@English,
254              qw(en_US.ISO8859-1 en_GB.ISO8859-1
255                 en en_US en_UK en_IE en_CA en_AU en_NZ
256                 english english.iso88591
257                 american american.iso88591
258                 british british.iso88591
259                 ));
260
261 # Find some German locale
262
263 locatelocale(\$German, \@German,
264              qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1
265                 de de_DE de_AT de_CH
266                 german german.iso88591));
267
268 # Find some French locale
269
270 locatelocale(\$French, \@French,
271              qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1
272                 fr fr_FR fr_BE fr_CA fr_CH
273                 french french.iso88591));
274
275 # Find some Spanish locale
276
277 locatelocale(\$Spanish, \@Spanish,
278              qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1
279                 es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1
280                 es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1
281                 es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1
282                 es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1
283                 es es_AR es_BO es_CL
284                 es_CO es_CR es_EC
285                 es_ES es_GT es_MX
286                 es_NI es_PA es_PE
287                 es_PY es_SV es_UY es_VE
288                 spanish spanish.iso88591));
289
290 # Select the largest of the alpha(num)bets.
291
292 ($Locale, @Locale) = ($English, @English)
293     if (@English > @Locale);
294 ($Locale, @Locale) = ($German, @German)
295     if (@German  > @Locale);
296 ($Locale, @Locale) = ($French, @French)
297     if (@French  > @Locale);
298 ($Locale, @Locale) = ($Spanish, @Spanish)
299     if (@Spanish > @Locale);
300
301 {
302     local $^W = 0;
303     setlocale(&LC_ALL, $Locale);
304 }
305
306 # Sort it now that LC_ALL has been set.
307
308 @Locale = sort @Locale;
309
310 print "# Locale = $Locale\n";
311 print "# Alnum_ = @Locale\n";
312
313 {
314     my $i = 0;
315
316     for (@Locale) {
317         $iLocale{$_} = $i++;
318     }
319 }
320
321 # Sieve the uppercase and the lowercase.
322
323 for (@Locale) {
324     if (/[^\d_]/) { # skip digits and the _
325         if (lc eq $_) {
326             $UPPER{$_} = uc;
327         } else {
328             $lower{$_} = lc;
329         }
330     }
331 }
332
333 # Find the alphabets that are not alphabets in the default locale.
334
335 {
336     no locale;
337     
338     for (keys %UPPER, keys %lower) {
339         push(@Neoalpha, $_) if (/\W/);
340     }
341 }
342
343 @Neoalpha = sort @Neoalpha;
344
345 # Test \w.
346
347 {
348     my $word = join('', @Neoalpha);
349
350     $word =~ /^(\w*)$/;
351
352     print 'not ' if ($1 ne $word);
353 }
354 print "ok 99\n";
355
356 # Find places where the collation order differs from the default locale.
357
358 print "# testing 100\n";
359 {
360     my (@k, $i, $j, @d);
361
362     {
363         no locale;
364
365         @k = sort (keys %UPPER, keys %lower); 
366     }
367
368     for ($i = 0; $i < @k; $i++) {
369         for ($j = $i + 1; $j < @k; $j++) {
370             if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) {
371                 push(@d, [$k[$j], $k[$i]]);
372             }
373         }
374     }
375
376     # Cross-check those places.
377
378     for (@d) {
379         ($i, $j) = @$_;
380         if ($i gt $j) {
381             print "# failed 100 at:\n";
382             print "# i = $i, j = $j, i ",
383                   $i le $j ? 'le' : 'gt', " j\n";
384             print 'not ';
385             last;
386         }
387     }
388 }
389 print "ok 100\n";
390
391 # Cross-check whole character set.
392
393 print "# testing 101\n";
394 for (map { chr } 0..255) {
395     if (/\w/ and /\W/) { print 'not '; last }
396     if (/\d/ and /\D/) { print 'not '; last }
397     if (/\s/ and /\S/) { print 'not '; last }
398     if (/\w/ and /\D/ and not /_/ and
399         not (exists $UPPER{$_} or exists $lower{$_})) {
400         print "# failed 101 at:\n";
401         print "# ", ord($_), " '$_'\n";
402         print 'not ';
403         last;
404     }
405 }
406 print "ok 101\n";
407
408 # Test for read-onlys.
409
410 print "# testing 102\n";
411 {
412     no locale;
413     $a = "qwerty";
414     {
415         use locale;
416         print "not " if $a cmp "qwerty";
417     }
418 }
419 print "ok 102\n";
420
421 # This test must be the last one because its failure is not fatal.
422 # The @Locale should be internally consistent.
423 # Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no>
424 # for inventing a way to test for ordering consistency
425 # without requiring any particular order.
426 # <jhi@iki.fi>
427
428 print "# testing 103\n";
429 {
430     my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign);
431
432     for (0..9) {
433         # Select a slice.
434         $from = int(($_*@Locale)/10);
435         $to = $from + int(@Locale/10);
436         $to = $#Locale if ($to > $#Locale);
437         $lesser  = join('', @Locale[$from..$to]);
438         # Select a slice one character on.
439         $from++; $to++;
440         $to = $#Locale if ($to > $#Locale);
441         $greater = join('', @Locale[$from..$to]);
442         ($yes, $no, $sign) = ($lesser lt $greater
443                                 ? ("    ", "not ", 1)
444                                 : ("not ", "    ", -1));
445         # all these tests should FAIL (return 0).
446         @test = 
447             (
448              $no.'    ($lesser  lt $greater)',  # 0
449              $no.'    ($lesser  le $greater)',  # 1
450              'not      ($lesser  ne $greater)', # 2
451              '         ($lesser  eq $greater)', # 3
452              $yes.'    ($lesser  ge $greater)', # 4
453              $yes.'    ($lesser  gt $greater)', # 5
454              $yes.'    ($greater lt $lesser )', # 6
455              $yes.'    ($greater le $lesser )', # 7
456              'not      ($greater ne $lesser )', # 8
457              '         ($greater eq $lesser )', # 9
458              $no.'     ($greater ge $lesser )', # 10
459              $no.'     ($greater gt $lesser )', # 11
460              'not (($lesser cmp $greater) == -$sign)' # 12
461              );
462         @test{@test} = 0 x @test;
463         $test = 0;
464         for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} }
465         if ($test) {
466             print "# failed 103 at:\n";
467             print "# lesser  = '$lesser'\n";
468             print "# greater = '$greater'\n";
469             print "# lesser cmp greater = ", $lesser cmp $greater, "\n";
470             print "# greater cmp lesser = ", $greater cmp $lesser, "\n";
471             print "# (greater) from = $from, to = $to\n";
472             for my $ti (@test) {
473                 printf("# %-40s %-4s", $ti,
474                        $test{$ti} ? 'FAIL' : 'ok');
475                 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
476                     printf("(%s == %4d)", $1, eval $1);
477                 }
478                 print "\n";
479             }
480
481             warn "The locale definition on your system may have errors.\n";
482             last;
483         }
484     }
485 }
486
487 # eof