This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: perldiag.pod entry for "Scalar value @%s{%s} ..."
[perl5.git] / t / lib / locale.t
1 #!./perl -wT
2
3 print "1..67\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 /(\W)/; # taint $&, $`, $', $+, $1.
78 check_taint      22, $&;
79 check_taint      23, $`;
80 check_taint      24, $';
81 check_taint      25, $+;
82 check_taint      26, $1;
83 check_taint_not  27, $2;
84
85 /(\s)/; # 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 $_ = $a;        # untaint $_
102
103 check_taint_not  40, $_;
104
105 /(b)/;          # this must not taint
106 check_taint_not  41, $&;
107 check_taint_not  42, $`;
108 check_taint_not  43, $';
109 check_taint_not  44, $+;
110 check_taint_not  45, $1;
111 check_taint_not  46, $2;
112
113 $_ = $a;        # untaint $_
114
115 check_taint_not  47, $_;
116
117 $b = uc($a);    # taint $b
118 s/(.+)/$b/;     # this must taint only the $_
119
120 check_taint      48, $_;
121 check_taint_not  49, $&;
122 check_taint_not  50, $`;
123 check_taint_not  51, $';
124 check_taint_not  52, $+;
125 check_taint_not  53, $1;
126 check_taint_not  54, $2;
127
128 $_ = $a;        # untaint $_
129
130 s/(.+)/b/;      # this must not taint
131 check_taint_not  55, $_;
132 check_taint_not  56, $&;
133 check_taint_not  57, $`;
134 check_taint_not  58, $';
135 check_taint_not  59, $+;
136 check_taint_not  60, $1;
137 check_taint_not  61, $2;
138
139 check_taint_not  62, $a;
140
141 # I think we've seen quite enough of taint.
142 # Let us do some *real* locale work now.
143
144 sub getalnum {
145     sort grep /\w/, map { chr } 0..255
146 }
147
148 sub locatelocale ($$@) {
149     my ($lcall, $alnum, @try) = @_;
150
151     undef $$lcall;
152
153     for (@try) {
154         local $^W = 0; # suppress "Subroutine LC_ALL redefined"
155         if (setlocale(LC_ALL, $_)) {
156             $$lcall = $_;
157             @$alnum = &getalnum;
158             last;
159         }
160     }
161
162     @$alnum = () unless (defined $$lcall);
163 }
164
165 # Find some default locale
166
167 locatelocale(\$Locale, \@Locale, qw(C POSIX));
168
169 # Find some English locale
170
171 locatelocale(\$English, \@English,
172              qw(en_US.ISO8859-1 en_GB.ISO8859-1
173                 en en_US en_UK en_IE en_CA en_AU en_NZ
174                 english english.iso88591
175                 american american.iso88591
176                 british british.iso88591
177                 ));
178
179 # Find some German locale
180
181 locatelocale(\$German, \@German,
182              qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1
183                 de de_DE de_AT de_CH
184                 german german.iso88591));
185
186 # Find some French locale
187
188 locatelocale(\$French, \@French,
189              qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1
190                 fr fr_FR fr_BE fr_CA fr_CH
191                 french french.iso88591));
192
193 # Find some Spanish locale
194
195 locatelocale(\$Spanish, \@Spanish,
196              qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1
197                 es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1
198                 es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1
199                 es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1
200                 es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1
201                 es es_AR es_BO es_CL
202                 es_CO es_CR es_EC
203                 es_ES es_GT es_MX
204                 es_NI es_PA es_PE
205                 es_PY es_SV es_UY es_VE
206                 spanish spanish.iso88591));
207
208 # Select the largest of the alpha(num)bets.
209
210 ($Locale, @Locale) = ($English, @English)
211     if (length(@English) > length(@Locale));
212 ($Locale, @Locale) = ($German, @German)
213     if (length(@German)  > length(@Locale));
214 ($Locale, @Locale) = ($French, @French)
215     if (length(@French)  > length(@Locale));
216 ($Locale, @Locale) = ($Spanish, @Spanish)
217     if (length(@Spanish) > length(@Locale));
218
219 print "# Locale = $Locale\n";
220 print "# Alnum_ = @Locale\n";
221
222 {
223     local $^W = 0;
224     setlocale(LC_ALL, $Locale);
225 }
226
227 {
228     my $i = 0;
229
230     for (@Locale) {
231         $iLocale{$_} = $i++;
232     }
233 }
234
235 # Sieve the uppercase and the lowercase.
236
237 for (@Locale) {
238     if (/[^\d_]/) { # skip digits and the _
239         if (lc eq $_) {
240             $UPPER{$_} = uc;
241         } else {
242             $lower{$_} = lc;
243         }
244     }
245 }
246
247 # Cross-check the upper and the lower.
248 # Yes, this is broken when the upper<->lower changes the number of
249 # the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature.
250 # But so far all the implementations do this wrong so we can do it wrong too.
251
252 for (keys %UPPER) {
253     if (defined $lower{$UPPER{$_}}) {
254         if ($_ ne $lower{$UPPER{$_}}) {
255             print 'not ';
256             last;
257         }
258     }
259 }
260 print "ok 63\n";
261
262 for (keys %lower) {
263     if (defined $UPPER{$lower{$_}}) {
264         if ($_ ne $UPPER{$lower{$_}}) {
265             print 'not ';
266             last;
267         }
268     }
269 }
270 print "ok 64\n";
271
272 # Find the alphabets that are not alphabets in the default locale.
273
274 {
275     no locale;
276     
277     for (keys %UPPER, keys %lower) {
278         push(@Neoalpha, $_) if (/\W/);
279     }
280 }
281
282 @Neoalpha = sort @Neoalpha;
283
284 # Test \w.
285
286 {
287     my $word = join('', @Neoalpha);
288
289     $word =~ /^(\w*)$/;
290
291     print 'not ' if ($1 ne $word);
292 }
293 print "ok 65\n";
294
295 # Find places where the collation order differs from the default locale.
296
297 {
298     no locale;
299
300     my @k = sort (keys %UPPER, keys %lower); 
301     my ($i, $j, @d);
302
303     for ($i = 0; $i < @k; $i++) {
304         for ($j = $i + 1; $j < @k; $j++) {
305             if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) {
306                 push(@d, [$k[$j], $k[$i]]);
307             }
308         }
309     }
310
311     # Cross-check those places.
312
313     for (@d) {
314         ($i, $j) = @$_;
315         print 'not ' if ($i le $j or not (($i cmp $j) == 1));
316     }
317 }
318 print "ok 66\n";
319
320 # Cross-check whole character set.
321
322 for (map { chr } 0..255) {
323     if (/\w/ and /\W/) { print 'not '; last }
324     if (/\d/ and /\D/) { print 'not '; last }
325     if (/\s/ and /\S/) { print 'not '; last }
326     if (/\w/ and /\D/ and not /_/ and
327         not (exists $UPPER{$_} or exists $lower{$_})) {
328         print 'not '; last
329     }
330 }
331 print "ok 67\n";