Commit | Line | Data |
---|---|---|
b0f2b690 JH |
1 | #!./perl |
2 | ||
838f2281 BF |
3 | # This file is intentionally encoded in latin-1. |
4 | ||
3a2263fe RGS |
5 | BEGIN { |
6 | chdir 't'; | |
3ffecb73 FC |
7 | require './test.pl'; |
8 | @INC = () unless is_miniperl(); | |
9 | unshift @INC, '../lib'; | |
31f05a37 | 10 | require Config; import Config; |
3ffecb73 | 11 | require './charset_tools.pl'; |
9b0711ee | 12 | require './loc_tools.pl'; # Contains find_utf8_ctype_locale() |
983ffd37 | 13 | } |
b0f2b690 | 14 | |
838f2281 BF |
15 | use feature qw( fc ); |
16 | ||
31f05a37 | 17 | plan tests => 134 + 4 * 256; |
c6502f5c RGS |
18 | |
19 | is(lc(undef), "", "lc(undef) is ''"); | |
20 | is(lcfirst(undef), "", "lcfirst(undef) is ''"); | |
21 | is(uc(undef), "", "uc(undef) is ''"); | |
22 | is(ucfirst(undef), "", "ucfirst(undef) is ''"); | |
3a2263fe | 23 | |
838f2281 BF |
24 | { |
25 | no feature 'fc'; | |
26 | is(CORE::fc(undef), "", "fc(undef) is ''"); | |
27 | is(CORE::fc(''), "", "fc('') is ''"); | |
28 | ||
29 | local $@; | |
30 | eval { fc("eeyup") }; | |
31 | like($@, qr/Undefined subroutine &main::fc/, "fc() throws an exception,"); | |
32 | ||
33 | { | |
34 | use feature 'fc'; | |
35 | local $@; | |
36 | eval { fc("eeyup") }; | |
37 | ok(!$@, "...but works after requesting the feature"); | |
38 | } | |
39 | } | |
40 | ||
b0f2b690 JH |
41 | $a = "HELLO.* world"; |
42 | $b = "hello.* WORLD"; | |
43 | ||
3a2263fe RGS |
44 | is("\Q$a\E." , "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world'); |
45 | is("\u$a" , "HELLO\.\* world", '\u'); | |
46 | is("\l$a" , "hELLO\.\* world", '\l'); | |
47 | is("\U$a" , "HELLO\.\* WORLD", '\U'); | |
48 | is("\L$a" , "hello\.\* world", '\L'); | |
838f2281 | 49 | is("\F$a" , "hello\.\* world", '\F'); |
3a2263fe RGS |
50 | |
51 | is(quotemeta($a) , "HELLO\\.\\*\\ world", 'quotemeta'); | |
52 | is(ucfirst($a) , "HELLO\.\* world", 'ucfirst'); | |
53 | is(lcfirst($a) , "hELLO\.\* world", 'lcfirst'); | |
54 | is(uc($a) , "HELLO\.\* WORLD", 'uc'); | |
55 | is(lc($a) , "hello\.\* world", 'lc'); | |
838f2281 | 56 | is(fc($a) , "hello\.\* world", 'fc'); |
3a2263fe RGS |
57 | |
58 | is("\Q$b\E." , "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD'); | |
59 | is("\u$b" , "Hello\.\* WORLD", '\u'); | |
60 | is("\l$b" , "hello\.\* WORLD", '\l'); | |
61 | is("\U$b" , "HELLO\.\* WORLD", '\U'); | |
62 | is("\L$b" , "hello\.\* world", '\L'); | |
838f2281 | 63 | is("\F$b" , "hello\.\* world", '\F'); |
3a2263fe RGS |
64 | |
65 | is(quotemeta($b) , "hello\\.\\*\\ WORLD", 'quotemeta'); | |
66 | is(ucfirst($b) , "Hello\.\* WORLD", 'ucfirst'); | |
67 | is(lcfirst($b) , "hello\.\* WORLD", 'lcfirst'); | |
68 | is(uc($b) , "HELLO\.\* WORLD", 'uc'); | |
69 | is(lc($b) , "hello\.\* world", 'lc'); | |
838f2281 | 70 | is(fc($b) , "hello\.\* world", 'fc'); |
983ffd37 JH |
71 | |
72 | # \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is | |
7e965bc5 | 73 | # \x{101}, LATIN SMALL LETTER A WITH MACRON. |
838f2281 | 74 | # Which is also its foldcase. |
b0f2b690 | 75 | |
2533d950 JH |
76 | $a = "\x{100}\x{101}Aa"; |
77 | $b = "\x{101}\x{100}aA"; | |
b0f2b690 | 78 | |
3a2263fe RGS |
79 | is("\Q$a\E." , "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa'); |
80 | is("\u$a" , "\x{100}\x{101}Aa", '\u'); | |
81 | is("\l$a" , "\x{101}\x{101}Aa", '\l'); | |
82 | is("\U$a" , "\x{100}\x{100}AA", '\U'); | |
83 | is("\L$a" , "\x{101}\x{101}aa", '\L'); | |
838f2281 | 84 | is("\F$a" , "\x{101}\x{101}aa", '\F'); |
3a2263fe RGS |
85 | |
86 | is(quotemeta($a) , "\x{100}\x{101}Aa", 'quotemeta'); | |
87 | is(ucfirst($a) , "\x{100}\x{101}Aa", 'ucfirst'); | |
88 | is(lcfirst($a) , "\x{101}\x{101}Aa", 'lcfirst'); | |
89 | is(uc($a) , "\x{100}\x{100}AA", 'uc'); | |
90 | is(lc($a) , "\x{101}\x{101}aa", 'lc'); | |
838f2281 | 91 | is(fc($a) , "\x{101}\x{101}aa", 'fc'); |
3a2263fe RGS |
92 | |
93 | is("\Q$b\E." , "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA'); | |
94 | is("\u$b" , "\x{100}\x{100}aA", '\u'); | |
95 | is("\l$b" , "\x{101}\x{100}aA", '\l'); | |
96 | is("\U$b" , "\x{100}\x{100}AA", '\U'); | |
97 | is("\L$b" , "\x{101}\x{101}aa", '\L'); | |
838f2281 | 98 | is("\F$b" , "\x{101}\x{101}aa", '\F'); |
3a2263fe RGS |
99 | |
100 | is(quotemeta($b) , "\x{101}\x{100}aA", 'quotemeta'); | |
101 | is(ucfirst($b) , "\x{100}\x{100}aA", 'ucfirst'); | |
102 | is(lcfirst($b) , "\x{101}\x{100}aA", 'lcfirst'); | |
103 | is(uc($b) , "\x{100}\x{100}AA", 'uc'); | |
104 | is(lc($b) , "\x{101}\x{101}aa", 'lc'); | |
838f2281 | 105 | is(fc($b) , "\x{101}\x{101}aa", 'fc'); |
983ffd37 JH |
106 | |
107 | # \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53}; | |
108 | # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is | |
109 | # \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N. | |
110 | ||
8a38a836 | 111 | is(latin1_to_native("\U\x{DF}aB\x{149}cD"), latin1_to_native("SSAB\x{2BC}NCD"), |
c811e616 | 112 | "multicharacter uppercase"); |
983ffd37 JH |
113 | |
114 | # The \x{DF} is its own lowercase, ditto for \x{149}. | |
115 | # There are no single character -> multiple characters lowercase mappings. | |
b0f2b690 | 116 | |
8a38a836 | 117 | is(latin1_to_native("\L\x{DF}aB\x{149}cD"), latin1_to_native("\x{DF}ab\x{149}cd"), |
c811e616 | 118 | "multicharacter lowercase"); |
b0f2b690 | 119 | |
838f2281 BF |
120 | # \x{DF} is LATIN SMALL LETTER SHARP S, its foldcase is ss or \x{73}\x{73}; |
121 | # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its foldcase is | |
122 | # \x{2BC}\x{6E} or MODIFIER LETTER APOSTROPHE and n. | |
123 | # Note that is this further tested in t/uni/fold.t | |
124 | ||
125 | is(latin1_to_native("\F\x{DF}aB\x{149}cD"), latin1_to_native("ssab\x{2BC}ncd"), | |
126 | "multicharacter foldcase"); | |
127 | ||
128 | ||
44bc797b JH |
129 | # titlecase is used for \u / ucfirst. |
130 | ||
131 | # \x{587} is ARMENIAN SMALL LIGATURE ECH YIWN and its titlecase is | |
132 | # \x{535}\x{582} ARMENIAN CAPITAL LETTER ECH + ARMENIAN SMALL LETTER YIWN | |
133 | # while its lowercase is | |
134 | # \x{587} itself | |
135 | # and its uppercase is | |
136 | # \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN | |
838f2281 | 137 | # The foldcase is \x{565}\x{582} ARMENIAN SMALL LETTER ECH + ARMENIAN SMALL LETTER YIWN |
44bc797b JH |
138 | |
139 | $a = "\x{587}"; | |
140 | ||
3a2263fe RGS |
141 | is("\L\x{587}" , "\x{587}", "ligature lowercase"); |
142 | is("\u\x{587}" , "\x{535}\x{582}", "ligature titlecase"); | |
143 | is("\U\x{587}" , "\x{535}\x{552}", "ligature uppercase"); | |
838f2281 | 144 | is("\F\x{587}" , "\x{565}\x{582}", "ligature foldcase"); |
44bc797b | 145 | |
2e3dedfe | 146 | # mktables had problems where many-to-one case mappings didn't work right. |
89ebb4a3 | 147 | # The lib/uni/fold.t should give the fourth folding, "casefolding", a good |
838f2281 | 148 | # workout. |
83171573 JH |
149 | # \x{01C4} is LATIN CAPITAL LETTER DZ WITH CARON |
150 | # \x{01C5} is LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON | |
151 | # \x{01C6} is LATIN SMALL LETTER DZ WITH CARON | |
152 | # \x{03A3} is GREEK CAPITAL LETTER SIGMA | |
153 | # \x{03C2} is GREEK SMALL LETTER FINAL SIGMA | |
154 | # \x{03C3} is GREEK SMALL LETTER SIGMA | |
2e3dedfe | 155 | |
3a2263fe RGS |
156 | is(lc("\x{1C4}") , "\x{1C6}", "U+01C4 lc is U+01C6"); |
157 | is(lc("\x{1C5}") , "\x{1C6}", "U+01C5 lc is U+01C6, too"); | |
2e3dedfe | 158 | |
3a2263fe RGS |
159 | is(ucfirst("\x{3C2}") , "\x{3A3}", "U+03C2 ucfirst is U+03A3"); |
160 | is(ucfirst("\x{3C3}") , "\x{3A3}", "U+03C3 ucfirst is U+03A3, too"); | |
2e3dedfe | 161 | |
3a2263fe RGS |
162 | is(uc("\x{1C5}") , "\x{1C4}", "U+01C5 uc is U+01C4"); |
163 | is(uc("\x{1C6}") , "\x{1C4}", "U+01C6 uc is U+01C4, too"); | |
2e3dedfe | 164 | |
ada6e8a9 AMS |
165 | # #18107: A host of bugs involving [ul]c{,first}. AMS 20021106 |
166 | $a = "\x{3c3}foo.bar"; # \x{3c3} == GREEK SMALL LETTER SIGMA. | |
167 | $b = "\x{3a3}FOO.BAR"; # \x{3a3} == GREEK CAPITAL LETTER SIGMA. | |
168 | ||
169 | ($c = $b) =~ s/(\w+)/lc($1)/ge; | |
3a2263fe | 170 | is($c , $a, "Using s///e to change case."); |
ada6e8a9 | 171 | |
d1eb3177 | 172 | ($c = $a) =~ s/(\p{IsWord}+)/uc($1)/ge; |
3a2263fe | 173 | is($c , $b, "Using s///e to change case."); |
ada6e8a9 | 174 | |
838f2281 BF |
175 | ($c = $a) =~ s/(\p{IsWord}+)/fc($1)/ge; |
176 | is($c , $a, "Using s///e to foldcase."); | |
177 | ||
d1eb3177 | 178 | ($c = $b) =~ s/(\p{IsWord}+)/lcfirst($1)/ge; |
3a2263fe | 179 | is($c , "\x{3c3}FOO.bAR", "Using s///e to change case."); |
ada6e8a9 | 180 | |
d1eb3177 | 181 | ($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge; |
3a2263fe RGS |
182 | is($c , "\x{3a3}foo.Bar", "Using s///e to change case."); |
183 | ||
184 | # #18931: perl5.8.0 bug in \U..\E processing | |
04d26ece | 185 | # Test case from Nicholas Clark. |
3a2263fe RGS |
186 | for my $a (0,1) { |
187 | $_ = 'abcdefgh'; | |
188 | $_ .= chr 256; | |
189 | chop; | |
190 | /(.*)/; | |
191 | is(uc($1), "ABCDEFGH", "[perl #18931]"); | |
192 | } | |
193 | ||
194 | { | |
195 | foreach (0, 1) { | |
196 | $a = v10.v257; | |
197 | chop $a; | |
198 | $a =~ s/^(\s*)(\w*)/$1\u$2/; | |
199 | is($a, v10, "[perl #18857]"); | |
3a2263fe RGS |
200 | } |
201 | } | |
6818a357 TS |
202 | |
203 | ||
204 | # [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc) | |
205 | ||
206 | for ("a\x{100}", "xyz\x{100}") { | |
207 | is(substr(uc($_), 0), uc($_), "[perl #38619] uc"); | |
208 | } | |
209 | for ("A\x{100}", "XYZ\x{100}") { | |
210 | is(substr(lc($_), 0), lc($_), "[perl #38619] lc"); | |
211 | } | |
212 | for ("a\x{100}", "ßyz\x{100}") { # ß to Ss (different length) | |
213 | is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst"); | |
214 | } | |
215 | ||
838f2281 BF |
216 | #fc() didn't exist back then, but coverage is coverage. |
217 | for ("a\x{100}", "ßyz\x{100}", "xyz\x{100}", "XYZ\x{100}") { # ß to Ss (different length) | |
218 | is(substr(fc($_), 0), fc($_), "[perl #38619] fc"); | |
219 | } | |
220 | ||
6818a357 TS |
221 | # Related to [perl #38619] |
222 | # the original report concerns PERL_MAGIC_utf8. | |
223 | # these cases concern PERL_MAGIC_regex_global. | |
224 | ||
225 | for (map { $_ } "a\x{100}", "abc\x{100}", "\x{100}") { | |
226 | chop; # get ("a", "abc", "") in utf8 | |
227 | my $return = uc($_) =~ /\G(.?)/g; | |
228 | my $result = $return ? $1 : "not"; | |
229 | my $expect = (uc($_) =~ /(.?)/g)[0]; | |
230 | is($return, 1, "[perl #38619]"); | |
231 | is($result, $expect, "[perl #38619]"); | |
232 | } | |
233 | ||
234 | for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") { | |
235 | chop; # get ("A", "ABC", "") in utf8 | |
236 | my $return = lc($_) =~ /\G(.?)/g; | |
237 | my $result = $return ? $1 : "not"; | |
238 | my $expect = (lc($_) =~ /(.?)/g)[0]; | |
239 | is($return, 1, "[perl #38619]"); | |
240 | is($result, $expect, "[perl #38619]"); | |
241 | } | |
242 | ||
838f2281 BF |
243 | for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") { |
244 | chop; # get ("A", "ABC", "") in utf8 | |
245 | my $return = fc($_) =~ /\G(.?)/g; | |
246 | my $result = $return ? $1 : "not"; | |
247 | my $expect = (fc($_) =~ /(.?)/g)[0]; | |
248 | is($return, 1, "[perl #38619]"); | |
249 | is($result, $expect, "[perl #38619]"); | |
250 | } | |
251 | ||
c2955298 NC |
252 | for (1, 4, 9, 16, 25) { |
253 | is(uc "\x{03B0}" x $_, "\x{3a5}\x{308}\x{301}" x $_, | |
254 | 'uc U+03B0 grows threefold'); | |
255 | ||
256 | is(lc "\x{0130}" x $_, "i\x{307}" x $_, 'lc U+0130 grows'); | |
838f2281 BF |
257 | |
258 | is(fc "\x{03B0}" x $_, "\x{3C5}\x{308}\x{301}" x $_, | |
259 | 'fc U+03B0 grows threefold'); | |
c2955298 | 260 | } |
17fa0776 RGS |
261 | |
262 | # bug #43207 | |
4b342708 | 263 | my $temp = "HellO"; |
17fa0776 RGS |
264 | for ("$temp") { |
265 | lc $_; | |
4b342708 | 266 | is($_, "HellO", '[perl #43207] lc($_) modifying $_'); |
17fa0776 | 267 | } |
838f2281 BF |
268 | for ("$temp") { |
269 | fc $_; | |
4b342708 FC |
270 | is($_, "HellO", '[perl #43207] fc($_) modifying $_'); |
271 | } | |
272 | for ("$temp") { | |
273 | uc $_; | |
274 | is($_, "HellO", '[perl #43207] uc($_) modifying $_'); | |
275 | } | |
276 | for ("$temp") { | |
277 | ucfirst $_; | |
278 | is($_, "HellO", '[perl #43207] ucfirst($_) modifying $_'); | |
279 | } | |
280 | for ("$temp") { | |
281 | lcfirst $_; | |
282 | is($_, "HellO", '[perl #43207] lcfirst($_) modifying $_'); | |
838f2281 BF |
283 | } |
284 | ||
aa4af542 RGS |
285 | # new in Unicode 5.1.0 |
286 | is(lc("\x{1E9E}"), "\x{df}", "lc(LATIN CAPITAL LETTER SHARP S)"); | |
b7cc4340 KW |
287 | |
288 | { | |
289 | use feature 'unicode_strings'; | |
290 | use bytes; | |
291 | is(lc("\xc0"), "\xc0", "lc of above-ASCII Latin1 is itself under use bytes"); | |
292 | is(lcfirst("\xc0"), "\xc0", "lcfirst of above-ASCII Latin1 is itself under use bytes"); | |
293 | is(uc("\xe0"), "\xe0", "uc of above-ASCII Latin1 is itself under use bytes"); | |
294 | is(ucfirst("\xe0"), "\xe0", "ucfirst of above-ASCII Latin1 is itself under use bytes"); | |
295 | } | |
a547fd21 FC |
296 | |
297 | # Brought up in ticket #117855: Constant folding applied to uc() should use | |
298 | # the right set of hints. | |
299 | fresh_perl_like(<<'constantfolding', qr/^(\d+),\1\z/, {}, | |
300 | my $function = "uc"; | |
301 | my $char = "\xff"; | |
302 | { | |
303 | use feature 'unicode_strings'; | |
304 | print ord uc($char), ",", | |
305 | ord eval "$function('$char')", "\n"; | |
306 | } | |
307 | constantfolding | |
308 | 'folded uc() in string eval uses the right hints'); | |
5cd5e2d6 FC |
309 | |
310 | # In-place lc/uc should not corrupt string buffers when given a non-utf8- | |
311 | # flagged thingy that stringifies to utf8 | |
312 | $h{k} = bless[], "\x{3b0}\x{3b0}\x{3b0}bcde"; # U+03B0 grows with uc() | |
313 | # using delete marks it as TEMP, so uc-in-place is permitted | |
314 | like uc delete $h{k}, qr "^(?:\x{3a5}\x{308}\x{301}){3}BCDE=ARRAY\(.*\)", | |
315 | 'uc(TEMP ref) does not produce a corrupt string'; | |
316 | $h{k} = bless[], "\x{130}bcde"; # U+0130 grows with lc() | |
317 | # using delete marks it as TEMP, so uc-in-place is permitted | |
318 | like lc delete $h{k}, qr "^i\x{307}bcde=array\(.*\)", | |
319 | 'lc(TEMP ref) does not produce a corrupt string'; | |
31f05a37 KW |
320 | |
321 | ||
9b0711ee | 322 | my $utf8_locale = find_utf8_ctype_locale(); |
31f05a37 KW |
323 | |
324 | SKIP: { | |
325 | skip 'Can\'t find a UTF-8 locale', 4*256 unless defined $utf8_locale; | |
326 | ||
baacc348 JH |
327 | eval { require POSIX; import POSIX 'locale_h'; }; |
328 | unless (defined &POSIX::LC_CTYPE) { | |
329 | skip "no POSIX (maybe no Fcntl, or no dynamic loading)", 4*256; | |
330 | } | |
331 | ||
31f05a37 KW |
332 | use feature qw( unicode_strings ); |
333 | ||
334 | no locale; | |
335 | ||
336 | my @unicode_lc; | |
337 | my @unicode_uc; | |
338 | my @unicode_lcfirst; | |
339 | my @unicode_ucfirst; | |
340 | ||
341 | # Get all the values outside of 'locale' | |
342 | for my $i (0 .. 255) { | |
343 | push @unicode_lc, lc(chr $i); | |
344 | push @unicode_uc, uc(chr $i); | |
345 | push @unicode_lcfirst, lcfirst(chr $i); | |
346 | push @unicode_ucfirst, ucfirst(chr $i); | |
347 | } | |
348 | ||
31f05a37 KW |
349 | use locale; |
350 | setlocale(LC_CTYPE, $utf8_locale); | |
351 | ||
352 | for my $i (0 .. 255) { | |
353 | is(lc(chr $i), $unicode_lc[$i], "In a UTF-8 locale, lc(chr $i) is the same as official Unicode"); | |
354 | is(uc(chr $i), $unicode_uc[$i], "In a UTF-8 locale, uc(chr $i) is the same as official Unicode"); | |
355 | is(lcfirst(chr $i), $unicode_lcfirst[$i], "In a UTF-8 locale, lcfirst(chr $i) is the same as official Unicode"); | |
356 | is(ucfirst(chr $i), $unicode_ucfirst[$i], "In a UTF-8 locale, ucfirst(chr $i) is the same as official Unicode"); | |
357 | } | |
358 | } |