This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[differences between cumulative patch application and perl5.003_18]
[perl5.git] / t / lib / locale.t
1 #!./perl -wT
2
3 print "1..104\n";
4
5 BEGIN {
6     chdir 't' if -d 't';
7     @INC = '../lib';
8 }
9
10 use strict;
11 use POSIX qw(locale_h);
12
13 use vars qw($a
14             $English $German $French $Spanish
15             @C @English @German @French @Spanish
16             $Locale @Locale %iLocale %UPPER %lower @Neoalpha);
17
18 $a = 'abc %';
19
20 sub ok {
21     my ($n, $result) = @_;
22
23     print 'not ' unless ($result);
24     print "ok $n\n";
25 }
26
27 # First we'll do a lot of taint checking for locales.
28 # This is the easiest to test, actually, as any locale,
29 # even the default locale will taint under 'use locale'.
30
31 sub is_tainted { # hello, camel two.
32     my $dummy;
33     not eval { $dummy = join("", @_), kill 0; 1 }
34 }
35
36 sub check_taint ($$) {
37     ok $_[0], is_tainted($_[1]);
38 }
39
40 sub check_taint_not ($$) {
41     ok $_[0], not is_tainted($_[1]);
42 }
43
44 use locale;     # engage locale and therefore locale taint.
45
46 check_taint_not   1, $a;
47
48 check_taint       2, uc($a);
49 check_taint       3, "\U$a";
50 check_taint       4, ucfirst($a);
51 check_taint       5, "\u$a";
52 check_taint       6, lc($a);
53 check_taint       7, "\L$a";
54 check_taint       8, lcfirst($a);
55 check_taint       9, "\l$a";
56
57 check_taint      10, sprintf('%e', 123.456);
58 check_taint      11, sprintf('%f', 123.456);
59 check_taint      12, sprintf('%g', 123.456);
60 check_taint_not  13, sprintf('%d', 123.456);
61 check_taint_not  14, sprintf('%x', 123.456);
62
63 $_ = $a;        # untaint $_
64
65 $_ = uc($a);    # taint $_
66
67 check_taint      15, $_;
68
69 /(\w)/; # taint $&, $`, $', $+, $1.
70 check_taint      16, $&;
71 check_taint      17, $`;
72 check_taint      18, $';
73 check_taint      19, $+;
74 check_taint      20, $1;
75 check_taint_not  21, $2;
76
77 /(.)/;  # untaint $&, $`, $', $+, $1.
78 check_taint_not  22, $&;
79 check_taint_not  23, $`;
80 check_taint_not  24, $';
81 check_taint_not  25, $+;
82 check_taint_not  26, $1;
83 check_taint_not  27, $2;
84
85 /(\W)/; # taint $&, $`, $', $+, $1.
86 check_taint      28, $&;
87 check_taint      29, $`;
88 check_taint      30, $';
89 check_taint      31, $+;
90 check_taint      32, $1;
91 check_taint_not  33, $2;
92
93 /(\s)/; # taint $&, $`, $', $+, $1.
94 check_taint      34, $&;
95 check_taint      35, $`;
96 check_taint      36, $';
97 check_taint      37, $+;
98 check_taint      38, $1;
99 check_taint_not  39, $2;
100
101 /(\S)/; # taint $&, $`, $', $+, $1.
102 check_taint      40, $&;
103 check_taint      41, $`;
104 check_taint      42, $';
105 check_taint      43, $+;
106 check_taint      44, $1;
107 check_taint_not  45, $2;
108
109 $_ = $a;        # untaint $_
110
111 check_taint_not  46, $_;
112
113 /(b)/;          # this must not taint
114 check_taint_not  47, $&;
115 check_taint_not  48, $`;
116 check_taint_not  49, $';
117 check_taint_not  50, $+;
118 check_taint_not  51, $1;
119 check_taint_not  52, $2;
120
121 $_ = $a;        # untaint $_
122
123 check_taint_not  53, $_;
124
125 $b = uc($a);    # taint $b
126 s/(.+)/$b/;     # this must taint only the $_
127
128 check_taint      54, $_;
129 check_taint_not  55, $&;
130 check_taint_not  56, $`;
131 check_taint_not  57, $';
132 check_taint_not  58, $+;
133 check_taint_not  59, $1;
134 check_taint_not  60, $2;
135
136 $_ = $a;        # untaint $_
137
138 s/(.+)/b/;      # this must not taint
139 check_taint_not  61, $_;
140 check_taint_not  62, $&;
141 check_taint_not  63, $`;
142 check_taint_not  64, $';
143 check_taint_not  65, $+;
144 check_taint_not  66, $1;
145 check_taint_not  67, $2;
146
147 $b = $a;        # untaint $b
148
149 ($b = $a) =~ s/\w/$&/;
150 check_taint      68, $b;        # $b should be tainted.
151 check_taint_not  69, $a;        # $a should be not.
152
153 $_ = $a;        # untaint $_
154
155 s/(\w)/\l$1/;   # this must taint
156 check_taint      70, $_;
157 check_taint      71, $&;
158 check_taint      72, $`;
159 check_taint      73, $';
160 check_taint      74, $+;
161 check_taint      75, $1;
162 check_taint_not  76, $2;
163
164 $_ = $a;        # untaint $_
165
166 s/(\w)/\L$1/;   # this must taint
167 check_taint      77, $_;
168 check_taint      78, $&;
169 check_taint      79, $`;
170 check_taint      80, $';
171 check_taint      81, $+;
172 check_taint      82, $1;
173 check_taint_not  83, $2;
174
175 $_ = $a;        # untaint $_
176
177 s/(\w)/\u$1/;   # this must taint
178 check_taint      84, $_;
179 check_taint      85, $&;
180 check_taint      86, $`;
181 check_taint      87, $';
182 check_taint      88, $+;
183 check_taint      89, $1;
184 check_taint_not  90, $2;
185
186 $_ = $a;        # untaint $_
187
188 s/(\w)/\U$1/;   # this must taint
189 check_taint      91, $_;
190 check_taint      92, $&;
191 check_taint      93, $`;
192 check_taint      94, $';
193 check_taint      95, $+;
194 check_taint      96, $1;
195 check_taint_not  97, $2;
196
197 # After all this tainting $a should be cool.
198
199 check_taint_not  98, $a;
200
201 # I think we've seen quite enough of taint.
202 # Let us do some *real* locale work now.
203
204 sub getalnum {
205     sort grep /\w/, map { chr } 0..255
206 }
207
208 sub locatelocale ($$@) {
209     my ($lcall, $alnum, @try) = @_;
210
211     undef $$lcall;
212
213     for (@try) {
214         local $^W = 0; # suppress "Subroutine LC_ALL redefined"
215         if (setlocale(LC_ALL, $_)) {
216             $$lcall = $_;
217             @$alnum = &getalnum;
218             last;
219         }
220     }
221
222     @$alnum = () unless (defined $$lcall);
223 }
224
225 # Find some default locale
226
227 locatelocale(\$Locale, \@Locale, qw(C POSIX));
228
229 # Find some English locale
230
231 locatelocale(\$English, \@English,
232              qw(en_US.ISO8859-1 en_GB.ISO8859-1
233                 en en_US en_UK en_IE en_CA en_AU en_NZ
234                 english english.iso88591
235                 american american.iso88591
236                 british british.iso88591
237                 ));
238
239 # Find some German locale
240
241 locatelocale(\$German, \@German,
242              qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1
243                 de de_DE de_AT de_CH
244                 german german.iso88591));
245
246 # Find some French locale
247
248 locatelocale(\$French, \@French,
249              qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1
250                 fr fr_FR fr_BE fr_CA fr_CH
251                 french french.iso88591));
252
253 # Find some Spanish locale
254
255 locatelocale(\$Spanish, \@Spanish,
256              qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1
257                 es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1
258                 es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1
259                 es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1
260                 es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1
261                 es es_AR es_BO es_CL
262                 es_CO es_CR es_EC
263                 es_ES es_GT es_MX
264                 es_NI es_PA es_PE
265                 es_PY es_SV es_UY es_VE
266                 spanish spanish.iso88591));
267
268 # Select the largest of the alpha(num)bets.
269
270 ($Locale, @Locale) = ($English, @English)
271     if (length(@English) > length(@Locale));
272 ($Locale, @Locale) = ($German, @German)
273     if (length(@German)  > length(@Locale));
274 ($Locale, @Locale) = ($French, @French)
275     if (length(@French)  > length(@Locale));
276 ($Locale, @Locale) = ($Spanish, @Spanish)
277     if (length(@Spanish) > length(@Locale));
278
279 print "# Locale = $Locale\n";
280 print "# Alnum_ = @Locale\n";
281
282 {
283     local $^W = 0;
284     setlocale(LC_ALL, $Locale);
285 }
286
287 {
288     my $i = 0;
289
290     for (@Locale) {
291         $iLocale{$_} = $i++;
292     }
293 }
294
295 # Sieve the uppercase and the lowercase.
296
297 for (@Locale) {
298     if (/[^\d_]/) { # skip digits and the _
299         if (lc eq $_) {
300             $UPPER{$_} = uc;
301         } else {
302             $lower{$_} = lc;
303         }
304     }
305 }
306
307 # Cross-check the upper and the lower.
308 # Yes, this is broken when the upper<->lower changes the number of
309 # the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature,
310 # or the Dutch IJ or the Spanish LL or ...)
311 # But so far all the implementations do this wrong so we can do it wrong too.
312
313 for (keys %UPPER) {
314     if (defined $lower{$UPPER{$_}}) {
315         if ($_ ne $lower{$UPPER{$_}}) {
316             print 'not ';
317             last;
318         }
319     }
320 }
321 print "ok 99\n";
322
323 for (keys %lower) {
324     if (defined $UPPER{$lower{$_}}) {
325         if ($_ ne $UPPER{$lower{$_}}) {
326             print 'not ';
327             last;
328         }
329     }
330 }
331 print "ok 100\n";
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 101\n";
355
356 # Find places where the collation order differs from the default locale.
357
358 {
359     my (@k, $i, $j, @d);
360
361     {
362         no locale;
363
364         @k = sort (keys %UPPER, keys %lower); 
365     }
366
367     for ($i = 0; $i < @k; $i++) {
368         for ($j = $i + 1; $j < @k; $j++) {
369             if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) {
370                 push(@d, [$k[$j], $k[$i]]);
371             }
372         }
373     }
374
375     # Cross-check those places.
376
377     for (@d) {
378         ($i, $j) = @$_;
379         if ($i gt $j) {
380             print "# i = $i, j = $j, i ",
381                   $i le $j ? 'le' : 'gt', " j\n";
382             print 'not ';
383             last;
384         }
385     }
386 }
387 print "ok 102\n";
388
389 # Cross-check whole character set.
390
391 for (map { chr } 0..255) {
392     if (/\w/ and /\W/) { print 'not '; last }
393     if (/\d/ and /\D/) { print 'not '; last }
394     if (/\s/ and /\S/) { print 'not '; last }
395     if (/\w/ and /\D/ and not /_/ and
396         not (exists $UPPER{$_} or exists $lower{$_})) {
397         print 'not ';
398         last;
399     }
400 }
401 print "ok 103\n";
402
403 # The @Locale should be internally consistent.
404
405 {
406     my ($from, $to, , $lesser, $greater);
407
408     for (0..9) {
409         # Select a slice.
410         $from = int(($_*@Locale)/10);
411         $to = $from + int(@Locale/10);
412         $to = $#Locale if ($to > $#Locale);
413         $lesser  = join('', @Locale[$from..$to]);
414         # Select a slice one character on.
415         $from++; $to++;
416         $to = $#Locale if ($to > $#Locale);
417         $greater = join('', @Locale[$from..$to]);
418         if (not ($lesser  lt $greater) or
419             not ($lesser  le $greater) or
420             not ($lesser  ne $greater) or
421                 ($lesser  eq $greater) or
422                 ($lesser  ge $greater) or
423                 ($lesser  gt $greater) or
424                 ($greater lt $lesser ) or
425                 ($greater le $lesser ) or
426             not ($greater ne $lesser ) or
427                 ($greater eq $lesser ) or
428             not ($greater ge $lesser ) or
429             not ($greater gt $lesser ) or
430             # Well, these two are sort of redundant because @Locale
431             # was derived using cmp.
432             not (($lesser  cmp $greater) == -1) or
433             not (($greater cmp $lesser ) ==  1)
434            ) {
435             print 'not ';
436             last;
437         }
438     }
439 }
440 print "ok 104\n";