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