10 my $have_setlocale = 0;
13 import POSIX ':locale_h';
17 print "1..", ($have_setlocale ? 102 : 98), "\n";
20 $English $German $French $Spanish
21 @C @English @German @French @Spanish
22 $Locale @Locale %iLocale %UPPER %lower @Neoalpha);
27 my ($n, $result) = @_;
29 print 'not ' unless ($result);
33 # First we'll do a lot of taint checking for locales.
34 # This is the easiest to test, actually, as any locale,
35 # even the default locale will taint under 'use locale'.
37 sub is_tainted { # hello, camel two.
39 not eval { $dummy = join("", @_), kill 0; 1 }
42 sub check_taint ($$) {
43 ok $_[0], is_tainted($_[1]);
46 sub check_taint_not ($$) {
47 ok $_[0], not is_tainted($_[1]);
50 use locale; # engage locale and therefore locale taint.
52 check_taint_not 1, $a;
54 check_taint 2, uc($a);
55 check_taint 3, "\U$a";
56 check_taint 4, ucfirst($a);
57 check_taint 5, "\u$a";
58 check_taint 6, lc($a);
59 check_taint 7, "\L$a";
60 check_taint 8, lcfirst($a);
61 check_taint 9, "\l$a";
63 check_taint 10, sprintf('%e', 123.456);
64 check_taint 11, sprintf('%f', 123.456);
65 check_taint 12, sprintf('%g', 123.456);
66 check_taint_not 13, sprintf('%d', 123.456);
67 check_taint_not 14, sprintf('%x', 123.456);
71 $_ = uc($a); # taint $_
75 /(\w)/; # taint $&, $`, $', $+, $1.
81 check_taint_not 21, $2;
83 /(.)/; # untaint $&, $`, $', $+, $1.
84 check_taint_not 22, $&;
85 check_taint_not 23, $`;
86 check_taint_not 24, $';
87 check_taint_not 25, $+;
88 check_taint_not 26, $1;
89 check_taint_not 27, $2;
91 /(\W)/; # taint $&, $`, $', $+, $1.
97 check_taint_not 33, $2;
99 /(\s)/; # taint $&, $`, $', $+, $1.
105 check_taint_not 39, $2;
107 /(\S)/; # taint $&, $`, $', $+, $1.
113 check_taint_not 45, $2;
115 $_ = $a; # untaint $_
117 check_taint_not 46, $_;
119 /(b)/; # this must not taint
120 check_taint_not 47, $&;
121 check_taint_not 48, $`;
122 check_taint_not 49, $';
123 check_taint_not 50, $+;
124 check_taint_not 51, $1;
125 check_taint_not 52, $2;
127 $_ = $a; # untaint $_
129 check_taint_not 53, $_;
131 $b = uc($a); # taint $b
132 s/(.+)/$b/; # this must taint only the $_
135 check_taint_not 55, $&;
136 check_taint_not 56, $`;
137 check_taint_not 57, $';
138 check_taint_not 58, $+;
139 check_taint_not 59, $1;
140 check_taint_not 60, $2;
142 $_ = $a; # untaint $_
144 s/(.+)/b/; # this must not taint
145 check_taint_not 61, $_;
146 check_taint_not 62, $&;
147 check_taint_not 63, $`;
148 check_taint_not 64, $';
149 check_taint_not 65, $+;
150 check_taint_not 66, $1;
151 check_taint_not 67, $2;
153 $b = $a; # untaint $b
155 ($b = $a) =~ s/\w/$&/;
156 check_taint 68, $b; # $b should be tainted.
157 check_taint_not 69, $a; # $a should be not.
159 $_ = $a; # untaint $_
161 s/(\w)/\l$1/; # this must taint
168 check_taint_not 76, $2;
170 $_ = $a; # untaint $_
172 s/(\w)/\L$1/; # this must taint
179 check_taint_not 83, $2;
181 $_ = $a; # untaint $_
183 s/(\w)/\u$1/; # this must taint
190 check_taint_not 90, $2;
192 $_ = $a; # untaint $_
194 s/(\w)/\U$1/; # this must taint
201 check_taint_not 97, $2;
203 # After all this tainting $a should be cool.
205 check_taint_not 98, $a;
207 # I think we've seen quite enough of taint.
208 # Let us do some *real* locale work now,
209 # unless setlocale() is missing (i.e. minitest).
211 exit unless $have_setlocale;
214 sort grep /\w/, map { chr } 0..255
217 sub locatelocale ($$@) {
218 my ($lcall, $alnum, @try) = @_;
223 local $^W = 0; # suppress "Subroutine LC_ALL redefined"
224 if (setlocale(&LC_ALL, $_)) {
231 @$alnum = () unless (defined $$lcall);
234 # Find some default locale
236 locatelocale(\$Locale, \@Locale, qw(C POSIX));
238 # Find some English locale
240 locatelocale(\$English, \@English,
241 qw(en_US.ISO8859-1 en_GB.ISO8859-1
242 en en_US en_UK en_IE en_CA en_AU en_NZ
243 english english.iso88591
244 american american.iso88591
245 british british.iso88591
248 # Find some German locale
250 locatelocale(\$German, \@German,
251 qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1
253 german german.iso88591));
255 # Find some French locale
257 locatelocale(\$French, \@French,
258 qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1
259 fr fr_FR fr_BE fr_CA fr_CH
260 french french.iso88591));
262 # Find some Spanish locale
264 locatelocale(\$Spanish, \@Spanish,
265 qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1
266 es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1
267 es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1
268 es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1
269 es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1
274 es_PY es_SV es_UY es_VE
275 spanish spanish.iso88591));
277 # Select the largest of the alpha(num)bets.
279 ($Locale, @Locale) = ($English, @English)
280 if (length(@English) > length(@Locale));
281 ($Locale, @Locale) = ($German, @German)
282 if (length(@German) > length(@Locale));
283 ($Locale, @Locale) = ($French, @French)
284 if (length(@French) > length(@Locale));
285 ($Locale, @Locale) = ($Spanish, @Spanish)
286 if (length(@Spanish) > length(@Locale));
288 print "# Locale = $Locale\n";
289 print "# Alnum_ = @Locale\n";
293 setlocale(&LC_ALL, $Locale);
304 # Sieve the uppercase and the lowercase.
307 if (/[^\d_]/) { # skip digits and the _
316 # Find the alphabets that are not alphabets in the default locale.
321 for (keys %UPPER, keys %lower) {
322 push(@Neoalpha, $_) if (/\W/);
326 @Neoalpha = sort @Neoalpha;
331 my $word = join('', @Neoalpha);
335 print 'not ' if ($1 ne $word);
339 # Find places where the collation order differs from the default locale.
341 print "# testing 100\n";
348 @k = sort (keys %UPPER, keys %lower);
351 for ($i = 0; $i < @k; $i++) {
352 for ($j = $i + 1; $j < @k; $j++) {
353 if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) {
354 push(@d, [$k[$j], $k[$i]]);
359 # Cross-check those places.
364 print "# failed 100 at:\n";
365 print "# i = $i, j = $j, i ",
366 $i le $j ? 'le' : 'gt', " j\n";
374 # Cross-check whole character set.
376 print "# testing 101\n";
377 for (map { chr } 0..255) {
378 if (/\w/ and /\W/) { print 'not '; last }
379 if (/\d/ and /\D/) { print 'not '; last }
380 if (/\s/ and /\S/) { print 'not '; last }
381 if (/\w/ and /\D/ and not /_/ and
382 not (exists $UPPER{$_} or exists $lower{$_})) {
383 print "# failed 101 at:\n";
384 print "# ", ord($_), " '$_'\n";
391 # The @Locale should be internally consistent.
393 print "# testing 102\n";
395 my ($from, $to, $lesser, $greater, @test, %test, $test);
399 $from = int(($_*@Locale)/10);
400 $to = $from + int(@Locale/10);
401 $to = $#Locale if ($to > $#Locale);
402 $lesser = join('', @Locale[$from..$to]);
403 # Select a slice one character on.
405 $to = $#Locale if ($to > $#Locale);
406 $greater = join('', @Locale[$from..$to]);
409 'not ($lesser lt $greater)', # 0
410 'not ($lesser le $greater)', # 1
411 'not ($lesser ne $greater)', # 2
412 ' ($lesser eq $greater)', # 3
413 ' ($lesser ge $greater)', # 4
414 ' ($lesser gt $greater)', # 5
415 ' ($greater lt $lesser )', # 6
416 ' ($greater le $lesser )', # 7
417 'not ($greater ne $lesser )', # 8
418 ' ($greater eq $lesser )', # 9
419 'not ($greater ge $lesser )', # 10
420 'not ($greater gt $lesser )', # 11
421 # Well, these two are sort of redundant
422 # because @Locale was derived using cmp.
423 'not (($lesser cmp $greater) == -1)', # 12
424 'not (($greater cmp $lesser ) == 1)' # 13
426 @test{@test} = 0 x @test;
428 for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} }
430 print "# failed 102 at:\n";
431 print "# lesser = '$lesser'\n";
432 print "# greater = '$greater'\n";
433 print "# (greater) from = $from, to = $to\n";
435 printf("# %-40s %-4s", $ti,
436 $test{$ti} ? 'FAIL' : 'ok');
437 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
438 printf("(%s == %4d)", $1, eval $1);