Commit | Line | Data |
---|---|---|
f96ec2a2 GS |
1 | #!./perl |
2 | ||
47520729 JH |
3 | my $has_perlio; |
4 | ||
f96ec2a2 GS |
5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
20822f61 | 7 | @INC = '../lib'; |
8ae6c9f9 | 8 | require './test.pl'; |
47520729 JH |
9 | unless ($has_perlio = find PerlIO::Layer 'perlio') { |
10 | print <<EOF; | |
11 | # Since you don't have perlio you might get failures with UTF-8 locales. | |
12 | EOF | |
13 | } | |
f96ec2a2 GS |
14 | } |
15 | ||
e4dc48dc NC |
16 | use strict; |
17 | use warnings; | |
e9f01ab9 JH |
18 | no utf8; # Ironic, no? |
19 | ||
4765795a JH |
20 | # NOTE! |
21 | # | |
22 | # Think carefully before adding tests here. In general this should be | |
23 | # used only for about three categories of tests: | |
24 | # | |
25 | # (1) tests that absolutely require 'use utf8', and since that in general | |
26 | # shouldn't be needed as the utf8 is being obsoleted, this should | |
27 | # have rather few tests. If you want to test Unicode and regexes, | |
28 | # you probably want to go to op/regexp or op/pat; if you want to test | |
29 | # split, go to op/split; pack, op/pack; appending or joining, | |
30 | # op/append or op/join, and so forth | |
31 | # | |
32 | # (2) tests that have to do with Unicode tokenizing (though it's likely | |
33 | # that all the other Unicode tests sprinkled around the t/**/*.t are | |
34 | # going to catch that) | |
35 | # | |
36 | # (3) complicated tests that simultaneously stress so many Unicode features | |
37 | # that deciding into which other test script the tests should go to | |
38 | # is hard -- maybe consider breaking up the complicated test | |
39 | # | |
40 | # | |
41 | ||
7bbb0251 | 42 | { |
da450f52 JH |
43 | # bug id 20001009.001 |
44 | ||
89491803 SC |
45 | my ($a, $b); |
46 | ||
47 | { use bytes; $a = "\xc3\xa4" } | |
4765795a | 48 | { use utf8; $b = "\xe4" } |
89491803 | 49 | |
4765795a | 50 | my $test = 68; |
31067593 | 51 | |
4765795a | 52 | ok($a ne $b); |
da450f52 | 53 | |
4765795a | 54 | { use utf8; ok($a ne $b) } |
da450f52 JH |
55 | } |
56 | ||
60ff4832 JH |
57 | |
58 | { | |
59 | # bug id 20000730.004 | |
60 | ||
60ff4832 JH |
61 | my $smiley = "\x{263a}"; |
62 | ||
4765795a JH |
63 | for my $s ("\x{263a}", |
64 | $smiley, | |
60ff4832 | 65 | |
4765795a JH |
66 | "" . $smiley, |
67 | "" . "\x{263a}", | |
60ff4832 | 68 | |
4765795a JH |
69 | $smiley . "", |
70 | "\x{263a}" . "", | |
60ff4832 JH |
71 | ) { |
72 | my $length_chars = length($s); | |
73 | my $length_bytes; | |
74 | { use bytes; $length_bytes = length($s) } | |
75 | my @regex_chars = $s =~ m/(.)/g; | |
76 | my $regex_chars = @regex_chars; | |
77 | my @split_chars = split //, $s; | |
78 | my $split_chars = @split_chars; | |
4765795a JH |
79 | ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq |
80 | "1/1/1/3"); | |
60ff4832 JH |
81 | } |
82 | ||
4765795a JH |
83 | for my $s ("\x{263a}" . "\x{263a}", |
84 | $smiley . $smiley, | |
60ff4832 | 85 | |
4765795a JH |
86 | "\x{263a}\x{263a}", |
87 | "$smiley$smiley", | |
60ff4832 | 88 | |
4765795a JH |
89 | "\x{263a}" x 2, |
90 | $smiley x 2, | |
60ff4832 JH |
91 | ) { |
92 | my $length_chars = length($s); | |
93 | my $length_bytes; | |
94 | { use bytes; $length_bytes = length($s) } | |
95 | my @regex_chars = $s =~ m/(.)/g; | |
96 | my $regex_chars = @regex_chars; | |
97 | my @split_chars = split //, $s; | |
98 | my $split_chars = @split_chars; | |
4765795a JH |
99 | ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq |
100 | "2/2/2/6"); | |
60ff4832 JH |
101 | } |
102 | } | |
ffc61ed2 | 103 | |
ffc61ed2 JH |
104 | |
105 | { | |
f9a63242 JH |
106 | my $w = 0; |
107 | local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ }; | |
108 | my $x = eval q/"\\/ . "\x{100}" . q/"/;; | |
109 | ||
4765795a | 110 | ok($w == 0 && $x eq "\x{100}"); |
f9a63242 JH |
111 | } |
112 | ||
8ae6c9f9 | 113 | { |
4c26891c NC |
114 | my $show = q( |
115 | sub show { | |
116 | my $result; | |
117 | $result .= '>' . join (',', map {ord} split //, $_) . '<' | |
118 | foreach @_; | |
119 | $result; | |
120 | } | |
121 | 1; | |
122 | ); | |
123 | eval $show or die $@; # We don't expect this sub definition to fail. | |
8ae6c9f9 | 124 | my $progfile = 'utf' . $$; |
435e7af6 NC |
125 | END {unlink_all $progfile} |
126 | ||
127 | # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC | |
128 | # 173 is not punctuation in either ASCII or EBCDIC | |
129 | my (@char); | |
130 | foreach (60, 173, 257, 65532) { | |
131 | my $char = chr $_; | |
132 | utf8::encode($char); | |
133 | # I don't want to use map {ord} and I've no need to hardcode the UTF | |
134 | # version | |
135 | my $charsubst = $char; | |
136 | $charsubst =~ s/(.)/ord ($1) . ','/ge; | |
137 | chop $charsubst; | |
4c26891c NC |
138 | # Not testing this one against map {ord} |
139 | my $char_as_ord | |
140 | = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char; | |
141 | push @char, [$_, $char, $charsubst, $char_as_ord]; | |
435e7af6 | 142 | } |
4c26891c NC |
143 | # Now we've done all the UTF8 munching hopefully we're safe |
144 | my @tests = ( | |
435e7af6 | 145 | ['check our detection program works', |
4c26891c | 146 | 'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/], |
435e7af6 | 147 | ['check literal 8 bit input', |
4c26891c | 148 | '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/], |
435e7af6 | 149 | ['check no utf8; makes no change', |
4c26891c | 150 | 'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/], |
435e7af6 NC |
151 | # Now we do the real byte sequences that are valid UTF8 |
152 | (map { | |
153 | ["the utf8 sequence for chr $_->[0]", | |
347a2837 | 154 | qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/], |
435e7af6 | 155 | ["no utf8; for the utf8 sequence for chr $_->[0]", |
4c26891c | 156 | qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/], |
435e7af6 | 157 | ["use utf8; for the utf8 sequence for chr $_->[0]", |
4c26891c | 158 | qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/], |
435e7af6 NC |
159 | } @char), |
160 | # Interpolation of hex characters needs to take place now, as we're | |
161 | # testing feeding malformed utf8 into perl. Bug now fixed was an | |
162 | # "out of memory" error. We really need the "" [rather than qq() | |
163 | # or q()] to get the best explosion. | |
164 | ["!Feed malformed utf8 into perl.", <<"BANG", | |
8ae6c9f9 | 165 | use utf8; %a = ("\xE1\xA0"=>"sterling"); |
435e7af6 | 166 | print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n"; |
8ae6c9f9 | 167 | BANG |
746b446a | 168 | qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm |
435e7af6 | 169 | ], |
4c26891c NC |
170 | ); |
171 | foreach (@tests) { | |
435e7af6 NC |
172 | my ($why, $prog, $expect) = @$_; |
173 | open P, ">$progfile" or die "Can't open '$progfile': $!"; | |
47520729 | 174 | binmode(P, ":bytes") if $has_perlio; |
4c26891c NC |
175 | print P $show, $prog, '; print $b' |
176 | or die "Print to 'progfile' failed: $!"; | |
435e7af6 NC |
177 | close P or die "Can't close '$progfile': $!"; |
178 | if ($why =~ s/^!//) { | |
179 | print "# Possible delay...\n"; | |
180 | } else { | |
181 | print "# $prog\n"; | |
182 | } | |
183 | my $result = runperl ( stderr => 1, progfile => $progfile ); | |
184 | like ($result, $expect, $why); | |
185 | } | |
4c26891c NC |
186 | |
187 | "# Again! Again! [but this time as eval, and not the explosive one]\n"; | |
188 | # and now we've safely done them all as separate files, check that the | |
a6d05634 | 189 | # evals do the same thing. Hopefully doing it later successfully decouples |
4c26891c NC |
190 | # the previous tests from anything messy that may go wrong with the evals. |
191 | foreach (@tests) { | |
192 | my ($why, $prog, $expect) = @$_; | |
193 | next if $why =~ m/^!/; # Goes bang. | |
194 | my $result = eval $prog; | |
195 | if ($@) { | |
196 | print "# prog is $prog\n"; | |
197 | print "# \$\@=", _qq($@), "\n"; | |
198 | } | |
199 | like ($result, $expect, $why); | |
200 | } | |
201 | ||
202 | # See what the tokeniser does with hash keys. | |
203 | print "# What does the tokeniser do with utf8 hash keys?\n"; | |
204 | @tests = (map { | |
205 | # This is the control - I don't expect it to fail | |
206 | ["assign utf8 for chr $_->[0] to a hash", | |
207 | qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1; | |
208 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
209 | qr/^>$_->[2]<$/], | |
210 | ["no utf8; assign utf8 for chr $_->[0] to a hash", | |
211 | qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1; | |
212 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
213 | qr/^>$_->[2]<$/], | |
214 | ["use utf8; assign utf8 for chr $_->[0] to a hash", | |
215 | qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1; | |
216 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), | |
217 | qr/^>$_->[0]<$/], | |
218 | # Now check literal $h{"x"} constructions. | |
219 | ["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]", | |
220 | qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1; | |
221 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
222 | qr/^>$_->[2]<$/], | |
223 | ["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]", | |
224 | qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1; | |
225 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
226 | qr/^>$_->[2]<$/], | |
227 | ["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]", | |
228 | qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1; | |
229 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), | |
230 | qr/^>$_->[0]<$/], | |
231 | # Now check "x" => constructions. | |
232 | ["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]", | |
233 | qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1); | |
234 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
235 | qr/^>$_->[2]<$/], | |
236 | ["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]", | |
237 | qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1); | |
238 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
239 | qr/^>$_->[2]<$/], | |
240 | ["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]", | |
241 | qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1); | |
242 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), | |
243 | qr/^>$_->[0]<$/], | |
244 | # Check copies of hashes made from literal utf8 keys | |
245 | ["assign utf8 for chr $_->[0] to a hash, then copy it", | |
246 | qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i; | |
247 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
248 | qr/^>$_->[2]<$/], | |
249 | ["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it", | |
250 | qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i; | |
251 | my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b), | |
252 | qr/^>$_->[2]<$/], | |
253 | ["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it", | |
254 | qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i; | |
255 | my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b), | |
256 | qr/^>$_->[0]<$/], | |
257 | } @char); | |
258 | foreach (@tests) { | |
259 | my ($why, $prog, $expect) = @$_; | |
260 | # print "# $prog\n"; | |
261 | my $result = eval $prog; | |
262 | like ($result, $expect, $why); | |
263 | } | |
8ae6c9f9 | 264 | } |
107c2363 MP |
265 | |
266 | # | |
267 | # bug fixed by change #17928 | |
268 | # separate perl used because we rely on 'strict' not yet loaded; | |
269 | # before the patch, the eval died with an error like: | |
270 | # "my" variable $strict::VERSION can't be in a package | |
271 | # | |
a901eef8 JH |
272 | SKIP: { |
273 | skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193; | |
274 | ok('' eq runperl(prog => <<'CODE'), "change #17928"); | |
275 | my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; }; | |
107c2363 MP |
276 | { |
277 | use utf8; | |
278 | eval $code; | |
279 | print $@ if $@; | |
280 | } | |
281 | CODE | |
a901eef8 | 282 | } |
a5b510f2 AE |
283 | |
284 | { | |
285 | use utf8; | |
286 | $a = <<'END'; | |
287 | 0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 ....... | |
288 | END | |
289 | my (@i, $s); | |
290 | ||
291 | @i = (); | |
292 | push @i, $s = index($a, '6'); # 60 | |
293 | push @i, $s = index($a, '.', $s); # next . after 60 is 62 | |
294 | push @i, $s = index($a, '5'); # 50 | |
295 | push @i, $s = index($a, '.', $s); # next . after 52 is 52 | |
296 | push @i, $s = index($a, '7'); # 70 | |
297 | push @i, $s = index($a, '.', $s); # next . after 70 is 72 | |
298 | push @i, $s = index($a, '4'); # 40 | |
299 | push @i, $s = index($a, '.', $s); # next . after 40 is 42 | |
300 | is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index"); | |
301 | ||
302 | @i = (); | |
303 | push @i, $s = rindex($a, '6'); # 60 | |
304 | push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58 | |
305 | push @i, $s = rindex($a, '5'); # 50 | |
306 | push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48 | |
307 | push @i, $s = rindex($a, '7'); # 70 | |
308 | push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68 | |
309 | push @i, $s = rindex($a, '4'); # 40 | |
310 | push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38 | |
311 | is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex"); | |
312 | ||
313 | @i = (); | |
314 | push @i, $s = index($a, '6'); # 60 | |
315 | push @i, index($a, '.', $s); # next . after 60 is 62 | |
316 | push @i, rindex($a, '.', $s); # previous . before 60 is 58 | |
317 | push @i, $s = rindex($a, '5'); # 60 | |
318 | push @i, index($a, '.', $s); # next . after 50 is 52 | |
319 | push @i, rindex($a, '.', $s); # previous . before 50 is 48 | |
320 | push @i, $s = index($a, '7', $s); # 70 | |
321 | push @i, index($a, '.', $s); # next . after 70 is 72 | |
322 | push @i, rindex($a, '.', $s); # previous . before 70 is 68 | |
323 | is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex"); | |
324 | } | |
325 | ||
a901eef8 JH |
326 | SKIP: { |
327 | skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193; | |
220e2d4e | 328 | use utf8; |
ab10b0e5 | 329 | is eval qq{q \xc3\xbc test \xc3\xbc . qq\xc2\xb7 test \xc2\xb7}, |
7b301413 FC |
330 | ' test test ', |
331 | "utf8 quote delimiters [perl #16823]"; | |
220e2d4e | 332 | } |
6e37fd2a JH |
333 | |
334 | # Test the "internals". | |
335 | ||
336 | { | |
337 | my $a = "A"; | |
338 | my $b = chr(0x0FF); | |
339 | my $c = chr(0x100); | |
340 | ||
341 | ok( utf8::valid($a), "utf8::valid basic"); | |
342 | ok( utf8::valid($b), "utf8::valid beyond"); | |
343 | ok( utf8::valid($c), "utf8::valid unicode"); | |
344 | ||
345 | ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); | |
346 | ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); | |
347 | ok( utf8::is_utf8($c), "utf8::is_utf8 unicode"); | |
348 | ||
349 | is(utf8::upgrade($a), 1, "utf8::upgrade basic"); | |
2f3efc97 JH |
350 | if (ord('A') == 193) { # EBCDIC. |
351 | is(utf8::upgrade($b), 1, "utf8::upgrade beyond"); | |
352 | } else { | |
353 | is(utf8::upgrade($b), 2, "utf8::upgrade beyond"); | |
354 | } | |
6e37fd2a JH |
355 | is(utf8::upgrade($c), 2, "utf8::upgrade unicode"); |
356 | ||
357 | is($a, "A", "basic"); | |
358 | is($b, "\xFF", "beyond"); | |
359 | is($c, "\x{100}", "unicode"); | |
360 | ||
361 | ok( utf8::valid($a), "utf8::valid basic"); | |
362 | ok( utf8::valid($b), "utf8::valid beyond"); | |
363 | ok( utf8::valid($c), "utf8::valid unicode"); | |
364 | ||
365 | ok( utf8::is_utf8($a), "utf8::is_utf8 basic"); | |
366 | ok( utf8::is_utf8($b), "utf8::is_utf8 beyond"); | |
367 | ok( utf8::is_utf8($c), "utf8::is_utf8 unicode"); | |
368 | ||
369 | is(utf8::downgrade($a), 1, "utf8::downgrade basic"); | |
370 | is(utf8::downgrade($b), 1, "utf8::downgrade beyond"); | |
371 | ||
372 | is($a, "A", "basic"); | |
373 | is($b, "\xFF", "beyond"); | |
374 | ||
375 | ok( utf8::valid($a), "utf8::valid basic"); | |
376 | ok( utf8::valid($b), "utf8::valid beyond"); | |
377 | ||
378 | ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); | |
379 | ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); | |
380 | ||
381 | utf8::encode($a); | |
382 | utf8::encode($b); | |
383 | utf8::encode($c); | |
384 | ||
385 | is($a, "A", "basic"); | |
2f3efc97 JH |
386 | if (ord('A') == 193) { # EBCDIC. |
387 | is(length($b), 1, "beyond length"); | |
388 | } else { | |
389 | is(length($b), 2, "beyond length"); | |
390 | } | |
6e37fd2a JH |
391 | is(length($c), 2, "unicode length"); |
392 | ||
393 | ok(utf8::valid($a), "utf8::valid basic"); | |
394 | ok(utf8::valid($b), "utf8::valid beyond"); | |
395 | ok(utf8::valid($c), "utf8::valid unicode"); | |
396 | ||
397 | # encode() clears the UTF-8 flag (unlike upgrade()). | |
398 | ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); | |
399 | ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); | |
400 | ok(!utf8::is_utf8($c), "!utf8::is_utf8 unicode"); | |
401 | ||
402 | utf8::decode($a); | |
403 | utf8::decode($b); | |
404 | utf8::decode($c); | |
405 | ||
406 | is($a, "A", "basic"); | |
407 | is($b, "\xFF", "beyond"); | |
408 | is($c, "\x{100}", "unicode"); | |
409 | ||
410 | ok(utf8::valid($a), "!utf8::valid basic"); | |
411 | ok(utf8::valid($b), "!utf8::valid beyond"); | |
412 | ok(utf8::valid($c), " utf8::valid unicode"); | |
413 | ||
414 | ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); | |
2f3efc97 JH |
415 | if (ord('A') == 193) { # EBCDIC. |
416 | ok( utf8::is_utf8(pack('U',0x0ff)), " utf8::is_utf8 beyond"); | |
417 | } else { | |
418 | ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8. | |
419 | } | |
6e37fd2a JH |
420 | ok( utf8::is_utf8($c), " utf8::is_utf8 unicode"); |
421 | } | |
5fec3b1d NC |
422 | |
423 | { | |
424 | eval {utf8::encode("£")}; | |
425 | like($@, qr/^Modification of a read-only value attempted/, | |
426 | "utf8::encode should refuse to touch read-only values"); | |
427 | } | |
06a45632 TS |
428 | |
429 | { | |
b2b7346b FC |
430 | # Make sure utf8::decode respects copy-on-write [perl #91834]. |
431 | # Hash keys are the easiest way to test this. | |
432 | my $name = "\x{c3}\x{b3}"; | |
433 | my ($k1) = keys %{ { $name=>undef } }; | |
434 | my $k2 = $name; | |
435 | utf8::decode($k1); | |
436 | utf8::decode($k2); | |
437 | my $h = { $k1 => 1, $k2 => 2 }; | |
438 | is join('', keys $h), $k2, 'utf8::decode respects copy-on-write'; | |
439 | } | |
440 | ||
441 | { | |
492ebaba FC |
442 | # Make sure utf8::decode does not modify read-only scalars |
443 | # [perl #91850]. | |
444 | ||
445 | my $name = "\x{c3}\x{b3}"; | |
446 | Internals::SvREADONLY($name, 1); | |
447 | eval { utf8::decode($name) }; | |
448 | like $@, qr/^Modification of a read-only/, | |
449 | 'utf8::decode respects readonliness'; | |
450 | } | |
451 | ||
452 | { | |
892522a6 | 453 | # utf8::decode should stringify refs [perl #91852]. |
c7102404 FC |
454 | |
455 | package eieifg { use overload '""' => sub { "\x{c3}\x{b3}" }, | |
456 | fallback => 1 } | |
457 | ||
458 | my $name = bless[], eieifg::; | |
459 | utf8::decode($name); | |
460 | is $name, "\xf3", 'utf8::decode flattens references'; | |
461 | } | |
462 | ||
463 | { | |
ccc73c2d | 464 | my $a = "456\xb6"; |
06a45632 TS |
465 | utf8::upgrade($a); |
466 | ||
ccc73c2d RGS |
467 | my $b = "123456\xb6"; |
468 | $b =~ s/^...//; | |
06a45632 TS |
469 | utf8::upgrade($b); |
470 | is($b, $a, "utf8::upgrade OffsetOK"); | |
471 | } | |
bd7017d3 NC |
472 | |
473 | { | |
474 | fresh_perl_like ('use utf8; utf8::moo()', | |
475 | qr/Undefined subroutine utf8::moo/, {stderr=>1}, | |
476 | "Check Carp is loaded for AUTOLOADing errors") | |
477 | } | |
77263263 TS |
478 | |
479 | { | |
480 | # failure of is_utf8_char() without NATIVE_TO_UTF on EBCDIC (0260..027F) | |
481 | ok(utf8::valid(chr(0x250)), "0x250"); | |
482 | ok(utf8::valid(chr(0x260)), "0x260"); | |
483 | ok(utf8::valid(chr(0x270)), "0x270"); | |
484 | ok(utf8::valid(chr(0x280)), "0x280"); | |
485 | } | |
96d9949f EB |
486 | |
487 | { | |
488 | use utf8; | |
489 | ok( !utf8::is_utf8( "asd" ), "Wasteful format - qq{}" ); | |
490 | ok( !utf8::is_utf8( 'asd' ), "Wasteful format - q{}" ); | |
491 | ok( !utf8::is_utf8( qw(asd) ), "Wasteful format - qw{}" ); | |
492 | ok( !utf8::is_utf8( (asd => 1)[0] ), "Wasteful format - =>" ); | |
96d9949f | 493 | ok( !utf8::is_utf8( -asd ), "Wasteful format - -word" ); |
e4dc48dc | 494 | no warnings 'bareword'; |
96d9949f | 495 | ok( !utf8::is_utf8( asd:: ), "Wasteful format - word::" ); |
e4dc48dc NC |
496 | no warnings 'reserved'; |
497 | no strict 'subs'; | |
498 | ok( !utf8::is_utf8( asd ), "Wasteful format - bareword" ); | |
96d9949f | 499 | } |
a18d6e6e NC |
500 | |
501 | { | |
502 | my @highest = | |
503 | (undef, 0x7F, 0x7FF, 0xFFFF, 0x1FFFFF, 0x3FFFFFF, 0x7FFFFFFF); | |
504 | my @step = | |
505 | (undef, undef, 0x40, 0x1000, 0x40000, 0x1000000, 0x40000000); | |
506 | ||
507 | foreach my $length (6, 5, 4, 3, 2) { | |
508 | my $high = $highest[$length]; | |
509 | while ($high > $highest[$length - 1]) { | |
510 | my $low = $high - $step[$length] + 1; | |
511 | $low = $highest[$length - 1] + 1 if $low <= $highest[$length - 1]; | |
512 | ok(utf8::valid(do {no warnings 'utf8'; chr $low}), | |
513 | sprintf "chr %x, length $length is valid", $low); | |
514 | ok(utf8::valid(do {no warnings 'utf8'; chr $high}), | |
515 | sprintf "chr %x, length $length is valid", $high); | |
516 | $high -= $step[$length]; | |
517 | } | |
518 | } | |
519 | } | |
520 | ||
75da9d4c DM |
521 | # #80190 update pos, and cached length/position-mapping after |
522 | # utf8 upgrade/downgrade, encode/decode | |
523 | ||
524 | for my $pos (0..5) { | |
525 | ||
75da9d4c DM |
526 | my $p; |
527 | my $s = "A\xc8\x81\xe8\xab\x86\x{100}"; | |
528 | chop($s); | |
529 | ||
530 | pos($s) = $pos; | |
531 | # also sets cache | |
532 | is(length($s), 6, "(pos $pos) len before utf8::downgrade"); | |
533 | is(pos($s), $pos, "(pos $pos) pos before utf8::downgrade"); | |
534 | utf8::downgrade($s); | |
535 | is(length($s), 6, "(pos $pos) len after utf8::downgrade"); | |
536 | is(pos($s), $pos, "(pos $pos) pos after utf8::downgrade"); | |
537 | is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after utf8::downgrade"); | |
538 | utf8::decode($s); | |
539 | is(length($s), 3, "(pos $pos) len after D; utf8::decode"); | |
158f7f72 | 540 | is(pos($s), undef, "(pos $pos) pos after D; utf8::decode"); |
75da9d4c DM |
541 | is($s, "A\x{201}\x{8ac6}", "(pos $pos) str after D; utf8::decode"); |
542 | utf8::encode($s); | |
543 | is(length($s), 6, "(pos $pos) len after D; utf8::encode"); | |
158f7f72 | 544 | is(pos($s), undef, "(pos $pos) pos after D; utf8::encode"); |
75da9d4c DM |
545 | is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after D; utf8::encode"); |
546 | ||
547 | $s = "A\xc8\x81\xe8\xab\x86"; | |
548 | ||
549 | pos($s) = $pos; | |
550 | is(length($s), 6, "(pos $pos) len before utf8::upgrade"); | |
551 | is(pos($s), $pos, "(pos $pos) pos before utf8::upgrade"); | |
552 | utf8::upgrade($s); | |
553 | is(length($s), 6, "(pos $pos) len after utf8::upgrade"); | |
554 | is(pos($s), $pos, "(pos $pos) pos after utf8::upgrade"); | |
555 | is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after utf8::upgrade"); | |
556 | utf8::decode($s); | |
557 | is(length($s), 3, "(pos $pos) len after U; utf8::decode"); | |
158f7f72 | 558 | is(pos($s), undef, "(pos $pos) pos after U; utf8::decode"); |
75da9d4c DM |
559 | is($s, "A\x{201}\x{8ac6}", "(pos $pos) str after U; utf8::decode"); |
560 | utf8::encode($s); | |
561 | is(length($s), 6, "(pos $pos) len after U; utf8::encode"); | |
158f7f72 | 562 | is(pos($s), undef, "(pos $pos) pos after U; utf8::encode"); |
75da9d4c DM |
563 | is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after U; utf8::encode"); |
564 | } | |
565 | ||
a18d6e6e | 566 | done_testing(); |