6 require Config; import Config;
7 if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
15 my $have_setlocale = 0;
18 import POSIX ':locale_h';
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;
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";
32 $English $German $French $Spanish
33 @C @English @German @French @Spanish
34 $Locale @Locale %iLocale %UPPER %lower @Neoalpha);
39 my ($n, $result) = @_;
41 print 'not ' unless ($result);
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'.
49 sub is_tainted { # hello, camel two.
50 local $^W; # no warnings 'undef'
52 not eval { $dummy = join("", @_), kill 0; 1 }
55 sub check_taint ($$) {
56 ok $_[0], is_tainted($_[1]);
59 sub check_taint_not ($$) {
60 ok $_[0], not is_tainted($_[1]);
63 use locale; # engage locale and therefore locale taint.
65 check_taint_not 1, $a;
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";
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);
84 $_ = uc($a); # taint $_
88 /(\w)/; # taint $&, $`, $', $+, $1.
94 check_taint_not 21, $2;
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;
104 /(\W)/; # taint $&, $`, $', $+, $1.
110 check_taint_not 33, $2;
112 /(\s)/; # taint $&, $`, $', $+, $1.
118 check_taint_not 39, $2;
120 /(\S)/; # taint $&, $`, $', $+, $1.
126 check_taint_not 45, $2;
128 $_ = $a; # untaint $_
130 check_taint_not 46, $_;
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;
140 $_ = $a; # untaint $_
142 check_taint_not 53, $_;
144 $b = uc($a); # taint $b
145 s/(.+)/$b/; # this must taint only the $_
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;
155 $_ = $a; # untaint $_
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;
166 $b = $a; # untaint $b
168 ($b = $a) =~ s/\w/$&/;
169 check_taint 68, $b; # $b should be tainted.
170 check_taint_not 69, $a; # $a should be not.
172 $_ = $a; # untaint $_
174 s/(\w)/\l$1/; # this must taint
181 check_taint_not 76, $2;
183 $_ = $a; # untaint $_
185 s/(\w)/\L$1/; # this must taint
192 check_taint_not 83, $2;
194 $_ = $a; # untaint $_
196 s/(\w)/\u$1/; # this must taint
203 check_taint_not 90, $2;
205 $_ = $a; # untaint $_
207 s/(\w)/\U$1/; # this must taint
214 check_taint_not 97, $2;
216 # After all this tainting $a should be cool.
218 check_taint_not 98, $a;
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).
224 exit unless $have_setlocale;
227 sort grep /\w/, map { chr } 0..255
230 sub locatelocale ($$@) {
231 my ($lcall, $alnum, @try) = @_;
236 local $^W = 0; # suppress "Subroutine LC_ALL redefined"
237 if (setlocale(&LC_ALL, $_)) {
244 @$alnum = () unless (defined $$lcall);
247 # Find some default locale
249 locatelocale(\$Locale, \@Locale, qw(C POSIX));
251 # Find some English locale
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
261 # Find some German locale
263 locatelocale(\$German, \@German,
264 qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1
266 german german.iso88591));
268 # Find some French locale
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));
275 # Find some Spanish locale
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
287 es_PY es_SV es_UY es_VE
288 spanish spanish.iso88591));
290 # Select the largest of the alpha(num)bets.
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);
303 setlocale(&LC_ALL, $Locale);
306 # Sort it now that LC_ALL has been set.
308 @Locale = sort @Locale;
310 print "# Locale = $Locale\n";
311 print "# Alnum_ = @Locale\n";
321 # Sieve the uppercase and the lowercase.
324 if (/[^\d_]/) { # skip digits and the _
333 # Find the alphabets that are not alphabets in the default locale.
338 for (keys %UPPER, keys %lower) {
339 push(@Neoalpha, $_) if (/\W/);
343 @Neoalpha = sort @Neoalpha;
348 my $word = join('', @Neoalpha);
352 print 'not ' if ($1 ne $word);
356 # Find places where the collation order differs from the default locale.
358 print "# testing 100\n";
365 @k = sort (keys %UPPER, keys %lower);
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]]);
376 # Cross-check those places.
381 print "# failed 100 at:\n";
382 print "# i = $i, j = $j, i ",
383 $i le $j ? 'le' : 'gt', " j\n";
391 # Cross-check whole character set.
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";
408 # Test for read-onlys.
410 print "# testing 102\n";
416 print "not " if $a cmp "qwerty";
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.
428 print "# testing 103\n";
430 my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign);
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.
440 $to = $#Locale if ($to > $#Locale);
441 $greater = join('', @Locale[$from..$to]);
442 ($yes, $no, $sign) = ($lesser lt $greater
444 : ("not ", " ", -1));
445 # all these tests should FAIL (return 0).
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
462 @test{@test} = 0 x @test;
464 for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} }
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";
473 printf("# %-40s %-4s", $ti,
474 $test{$ti} ? 'FAIL' : 'ok');
475 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
476 printf("(%s == %4d)", $1, eval $1);
481 warn "The locale definition on your system may have errors.\n";