This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert lib/utf8.t to strict and warnings throughout.
[perl5.git] / lib / utf8.t
CommitLineData
f96ec2a2
GS
1#!./perl
2
47520729
JH
3my $has_perlio;
4
f96ec2a2
GS
5BEGIN {
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.
12EOF
13 }
f96ec2a2
GS
14}
15
e4dc48dc
NC
16use strict;
17use warnings;
e9f01ab9
JH
18no 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
96d9949f 42plan tests => 157;
31067593 43
7bbb0251 44{
da450f52
JH
45 # bug id 20001009.001
46
89491803
SC
47 my ($a, $b);
48
49 { use bytes; $a = "\xc3\xa4" }
4765795a 50 { use utf8; $b = "\xe4" }
89491803 51
4765795a 52 my $test = 68;
31067593 53
4765795a 54 ok($a ne $b);
da450f52 55
4765795a 56 { use utf8; ok($a ne $b) }
da450f52
JH
57}
58
60ff4832
JH
59
60{
61 # bug id 20000730.004
62
60ff4832
JH
63 my $smiley = "\x{263a}";
64
4765795a
JH
65 for my $s ("\x{263a}",
66 $smiley,
60ff4832 67
4765795a
JH
68 "" . $smiley,
69 "" . "\x{263a}",
60ff4832 70
4765795a
JH
71 $smiley . "",
72 "\x{263a}" . "",
60ff4832
JH
73 ) {
74 my $length_chars = length($s);
75 my $length_bytes;
76 { use bytes; $length_bytes = length($s) }
77 my @regex_chars = $s =~ m/(.)/g;
78 my $regex_chars = @regex_chars;
79 my @split_chars = split //, $s;
80 my $split_chars = @split_chars;
4765795a
JH
81 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
82 "1/1/1/3");
60ff4832
JH
83 }
84
4765795a
JH
85 for my $s ("\x{263a}" . "\x{263a}",
86 $smiley . $smiley,
60ff4832 87
4765795a
JH
88 "\x{263a}\x{263a}",
89 "$smiley$smiley",
60ff4832 90
4765795a
JH
91 "\x{263a}" x 2,
92 $smiley x 2,
60ff4832
JH
93 ) {
94 my $length_chars = length($s);
95 my $length_bytes;
96 { use bytes; $length_bytes = length($s) }
97 my @regex_chars = $s =~ m/(.)/g;
98 my $regex_chars = @regex_chars;
99 my @split_chars = split //, $s;
100 my $split_chars = @split_chars;
4765795a
JH
101 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
102 "2/2/2/6");
60ff4832
JH
103 }
104}
ffc61ed2 105
ffc61ed2
JH
106
107{
f9a63242
JH
108 my $w = 0;
109 local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
110 my $x = eval q/"\\/ . "\x{100}" . q/"/;;
111
4765795a 112 ok($w == 0 && $x eq "\x{100}");
f9a63242
JH
113}
114
8ae6c9f9 115{
4c26891c
NC
116 my $show = q(
117 sub show {
118 my $result;
119 $result .= '>' . join (',', map {ord} split //, $_) . '<'
120 foreach @_;
121 $result;
122 }
123 1;
124 );
125 eval $show or die $@; # We don't expect this sub definition to fail.
8ae6c9f9 126 my $progfile = 'utf' . $$;
435e7af6
NC
127 END {unlink_all $progfile}
128
129 # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC
130 # 173 is not punctuation in either ASCII or EBCDIC
131 my (@char);
132 foreach (60, 173, 257, 65532) {
133 my $char = chr $_;
134 utf8::encode($char);
135 # I don't want to use map {ord} and I've no need to hardcode the UTF
136 # version
137 my $charsubst = $char;
138 $charsubst =~ s/(.)/ord ($1) . ','/ge;
139 chop $charsubst;
4c26891c
NC
140 # Not testing this one against map {ord}
141 my $char_as_ord
142 = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
143 push @char, [$_, $char, $charsubst, $char_as_ord];
435e7af6 144 }
4c26891c
NC
145 # Now we've done all the UTF8 munching hopefully we're safe
146 my @tests = (
435e7af6 147 ['check our detection program works',
4c26891c 148 'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
435e7af6 149 ['check literal 8 bit input',
4c26891c 150 '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
435e7af6 151 ['check no utf8; makes no change',
4c26891c 152 'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
435e7af6
NC
153 # Now we do the real byte sequences that are valid UTF8
154 (map {
155 ["the utf8 sequence for chr $_->[0]",
347a2837 156 qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
435e7af6 157 ["no utf8; for the utf8 sequence for chr $_->[0]",
4c26891c 158 qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
435e7af6 159 ["use utf8; for the utf8 sequence for chr $_->[0]",
4c26891c 160 qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
435e7af6
NC
161 } @char),
162 # Interpolation of hex characters needs to take place now, as we're
163 # testing feeding malformed utf8 into perl. Bug now fixed was an
164 # "out of memory" error. We really need the "" [rather than qq()
165 # or q()] to get the best explosion.
166 ["!Feed malformed utf8 into perl.", <<"BANG",
8ae6c9f9 167 use utf8; %a = ("\xE1\xA0"=>"sterling");
435e7af6 168 print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
8ae6c9f9 169BANG
746b446a 170 qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm
435e7af6 171 ],
4c26891c
NC
172 );
173 foreach (@tests) {
435e7af6
NC
174 my ($why, $prog, $expect) = @$_;
175 open P, ">$progfile" or die "Can't open '$progfile': $!";
47520729 176 binmode(P, ":bytes") if $has_perlio;
4c26891c
NC
177 print P $show, $prog, '; print $b'
178 or die "Print to 'progfile' failed: $!";
435e7af6
NC
179 close P or die "Can't close '$progfile': $!";
180 if ($why =~ s/^!//) {
181 print "# Possible delay...\n";
182 } else {
183 print "# $prog\n";
184 }
185 my $result = runperl ( stderr => 1, progfile => $progfile );
186 like ($result, $expect, $why);
187 }
4c26891c
NC
188 print
189 "# Again! Again! [but this time as eval, and not the explosive one]\n";
190 # and now we've safely done them all as separate files, check that the
a6d05634 191 # evals do the same thing. Hopefully doing it later successfully decouples
4c26891c
NC
192 # the previous tests from anything messy that may go wrong with the evals.
193 foreach (@tests) {
194 my ($why, $prog, $expect) = @$_;
195 next if $why =~ m/^!/; # Goes bang.
196 my $result = eval $prog;
197 if ($@) {
198 print "# prog is $prog\n";
199 print "# \$\@=", _qq($@), "\n";
200 }
201 like ($result, $expect, $why);
202 }
203
204 # See what the tokeniser does with hash keys.
205 print "# What does the tokeniser do with utf8 hash keys?\n";
206 @tests = (map {
207 # This is the control - I don't expect it to fail
208 ["assign utf8 for chr $_->[0] to a hash",
209 qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
210 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
211 qr/^>$_->[2]<$/],
212 ["no utf8; assign utf8 for chr $_->[0] to a hash",
213 qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
214 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
215 qr/^>$_->[2]<$/],
216 ["use utf8; assign utf8 for chr $_->[0] to a hash",
217 qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
218 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
219 qr/^>$_->[0]<$/],
220 # Now check literal $h{"x"} constructions.
221 ["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
222 qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
223 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
224 qr/^>$_->[2]<$/],
225 ["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
226 qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
227 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
228 qr/^>$_->[2]<$/],
229 ["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
230 qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
231 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
232 qr/^>$_->[0]<$/],
233 # Now check "x" => constructions.
234 ["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
235 qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
236 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
237 qr/^>$_->[2]<$/],
238 ["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
239 qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
240 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
241 qr/^>$_->[2]<$/],
242 ["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
243 qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
244 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
245 qr/^>$_->[0]<$/],
246 # Check copies of hashes made from literal utf8 keys
247 ["assign utf8 for chr $_->[0] to a hash, then copy it",
248 qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
249 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
250 qr/^>$_->[2]<$/],
251 ["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
252 qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i;
253 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
254 qr/^>$_->[2]<$/],
255 ["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
256 qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
257 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
258 qr/^>$_->[0]<$/],
259 } @char);
260 foreach (@tests) {
261 my ($why, $prog, $expect) = @$_;
262 # print "# $prog\n";
263 my $result = eval $prog;
264 like ($result, $expect, $why);
265 }
8ae6c9f9 266}
107c2363
MP
267
268#
269# bug fixed by change #17928
270# separate perl used because we rely on 'strict' not yet loaded;
271# before the patch, the eval died with an error like:
272# "my" variable $strict::VERSION can't be in a package
273#
a901eef8
JH
274SKIP: {
275 skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
276 ok('' eq runperl(prog => <<'CODE'), "change #17928");
277 my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
107c2363
MP
278 {
279 use utf8;
280 eval $code;
281 print $@ if $@;
282 }
283CODE
a901eef8 284}
a5b510f2
AE
285
286{
287 use utf8;
288 $a = <<'END';
2890 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
290END
291 my (@i, $s);
292
293 @i = ();
294 push @i, $s = index($a, '6'); # 60
295 push @i, $s = index($a, '.', $s); # next . after 60 is 62
296 push @i, $s = index($a, '5'); # 50
297 push @i, $s = index($a, '.', $s); # next . after 52 is 52
298 push @i, $s = index($a, '7'); # 70
299 push @i, $s = index($a, '.', $s); # next . after 70 is 72
300 push @i, $s = index($a, '4'); # 40
301 push @i, $s = index($a, '.', $s); # next . after 40 is 42
302 is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
303
304 @i = ();
305 push @i, $s = rindex($a, '6'); # 60
306 push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
307 push @i, $s = rindex($a, '5'); # 50
308 push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
309 push @i, $s = rindex($a, '7'); # 70
310 push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
311 push @i, $s = rindex($a, '4'); # 40
312 push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
313 is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
314
315 @i = ();
316 push @i, $s = index($a, '6'); # 60
317 push @i, index($a, '.', $s); # next . after 60 is 62
318 push @i, rindex($a, '.', $s); # previous . before 60 is 58
319 push @i, $s = rindex($a, '5'); # 60
320 push @i, index($a, '.', $s); # next . after 50 is 52
321 push @i, rindex($a, '.', $s); # previous . before 50 is 48
322 push @i, $s = index($a, '7', $s); # 70
323 push @i, index($a, '.', $s); # next . after 70 is 72
324 push @i, rindex($a, '.', $s); # previous . before 70 is 68
325 is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
326}
327
a901eef8
JH
328SKIP: {
329 skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
220e2d4e 330 use utf8;
ab10b0e5 331 is eval qq{q \xc3\xbc test \xc3\xbc . qq\xc2\xb7 test \xc2\xb7},
7b301413
FC
332 ' test test ',
333 "utf8 quote delimiters [perl #16823]";
220e2d4e 334}
6e37fd2a
JH
335
336# Test the "internals".
337
338{
339 my $a = "A";
340 my $b = chr(0x0FF);
341 my $c = chr(0x100);
342
343 ok( utf8::valid($a), "utf8::valid basic");
344 ok( utf8::valid($b), "utf8::valid beyond");
345 ok( utf8::valid($c), "utf8::valid unicode");
346
347 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
348 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
349 ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
350
351 is(utf8::upgrade($a), 1, "utf8::upgrade basic");
2f3efc97
JH
352 if (ord('A') == 193) { # EBCDIC.
353 is(utf8::upgrade($b), 1, "utf8::upgrade beyond");
354 } else {
355 is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
356 }
6e37fd2a
JH
357 is(utf8::upgrade($c), 2, "utf8::upgrade unicode");
358
359 is($a, "A", "basic");
360 is($b, "\xFF", "beyond");
361 is($c, "\x{100}", "unicode");
362
363 ok( utf8::valid($a), "utf8::valid basic");
364 ok( utf8::valid($b), "utf8::valid beyond");
365 ok( utf8::valid($c), "utf8::valid unicode");
366
367 ok( utf8::is_utf8($a), "utf8::is_utf8 basic");
368 ok( utf8::is_utf8($b), "utf8::is_utf8 beyond");
369 ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
370
371 is(utf8::downgrade($a), 1, "utf8::downgrade basic");
372 is(utf8::downgrade($b), 1, "utf8::downgrade beyond");
373
374 is($a, "A", "basic");
375 is($b, "\xFF", "beyond");
376
377 ok( utf8::valid($a), "utf8::valid basic");
378 ok( utf8::valid($b), "utf8::valid beyond");
379
380 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
381 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
382
383 utf8::encode($a);
384 utf8::encode($b);
385 utf8::encode($c);
386
387 is($a, "A", "basic");
2f3efc97
JH
388 if (ord('A') == 193) { # EBCDIC.
389 is(length($b), 1, "beyond length");
390 } else {
391 is(length($b), 2, "beyond length");
392 }
6e37fd2a
JH
393 is(length($c), 2, "unicode length");
394
395 ok(utf8::valid($a), "utf8::valid basic");
396 ok(utf8::valid($b), "utf8::valid beyond");
397 ok(utf8::valid($c), "utf8::valid unicode");
398
399 # encode() clears the UTF-8 flag (unlike upgrade()).
400 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
401 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
402 ok(!utf8::is_utf8($c), "!utf8::is_utf8 unicode");
403
404 utf8::decode($a);
405 utf8::decode($b);
406 utf8::decode($c);
407
408 is($a, "A", "basic");
409 is($b, "\xFF", "beyond");
410 is($c, "\x{100}", "unicode");
411
412 ok(utf8::valid($a), "!utf8::valid basic");
413 ok(utf8::valid($b), "!utf8::valid beyond");
414 ok(utf8::valid($c), " utf8::valid unicode");
415
416 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
2f3efc97
JH
417 if (ord('A') == 193) { # EBCDIC.
418 ok( utf8::is_utf8(pack('U',0x0ff)), " utf8::is_utf8 beyond");
419 } else {
420 ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
421 }
6e37fd2a
JH
422 ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
423}
5fec3b1d
NC
424
425{
426 eval {utf8::encode("£")};
427 like($@, qr/^Modification of a read-only value attempted/,
428 "utf8::encode should refuse to touch read-only values");
429}
06a45632
ST
430
431{
ccc73c2d 432 my $a = "456\xb6";
06a45632
ST
433 utf8::upgrade($a);
434
ccc73c2d
RGS
435 my $b = "123456\xb6";
436 $b =~ s/^...//;
06a45632
ST
437 utf8::upgrade($b);
438 is($b, $a, "utf8::upgrade OffsetOK");
439}
bd7017d3
NC
440
441{
442 fresh_perl_like ('use utf8; utf8::moo()',
443 qr/Undefined subroutine utf8::moo/, {stderr=>1},
444 "Check Carp is loaded for AUTOLOADing errors")
445}
77263263
ST
446
447{
448 # failure of is_utf8_char() without NATIVE_TO_UTF on EBCDIC (0260..027F)
449 ok(utf8::valid(chr(0x250)), "0x250");
450 ok(utf8::valid(chr(0x260)), "0x260");
451 ok(utf8::valid(chr(0x270)), "0x270");
452 ok(utf8::valid(chr(0x280)), "0x280");
453}
96d9949f
EB
454
455{
456 use utf8;
457 ok( !utf8::is_utf8( "asd" ), "Wasteful format - qq{}" );
458 ok( !utf8::is_utf8( 'asd' ), "Wasteful format - q{}" );
459 ok( !utf8::is_utf8( qw(asd) ), "Wasteful format - qw{}" );
460 ok( !utf8::is_utf8( (asd => 1)[0] ), "Wasteful format - =>" );
96d9949f 461 ok( !utf8::is_utf8( -asd ), "Wasteful format - -word" );
e4dc48dc 462 no warnings 'bareword';
96d9949f 463 ok( !utf8::is_utf8( asd:: ), "Wasteful format - word::" );
e4dc48dc
NC
464 no warnings 'reserved';
465 no strict 'subs';
466 ok( !utf8::is_utf8( asd ), "Wasteful format - bareword" );
96d9949f 467}