This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
lib/utf8.t: Generalize for EBCDIC
[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';
d591e493 8 require './test.pl'; require './charset_tools.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
7bbb0251 42{
126fe723 43 # bug id 20001009.001 (#4409)
da450f52 44
89491803
SC
45 my ($a, $b);
46
d591e493
KW
47 { use bytes; $a = byte_utf8a_to_utf8n("\xc3\xa4") }
48 { use utf8; $b = uni_to_native("\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{
126fe723 59 # bug id 20000730.004 (#3599)
60ff4832 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
679f623f
KW
127 # 64 is '@' in ASCII, ' ' in EBCDIC
128 # 193 is not punctuation in either ASCII nor EBCDIC
435e7af6 129 my (@char);
679f623f 130 foreach (64, 193, 257, 65532) {
435e7af6
NC
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 }
8ff713d9
KW
143 my $malformed = $::IS_ASCII
144 ? "\xE1\xA0"
145 : I8_to_native("\xE6\xA0");
4c26891c
NC
146 # Now we've done all the UTF8 munching hopefully we're safe
147 my @tests = (
435e7af6 148 ['check our detection program works',
679f623f 149 'my @a = ("'.chr(64).'\x2A", ""); $b = show @a', qr/^>64,42<><$/],
435e7af6 150 ['check literal 8 bit input',
679f623f 151 '$a = "' . chr (193) . '"; $b = show $a', qr/^>193<$/],
435e7af6 152 ['check no utf8; makes no change',
679f623f 153 'no utf8; $a = "' . chr (193) . '"; $b = show $a', qr/^>193<$/],
435e7af6
NC
154 # Now we do the real byte sequences that are valid UTF8
155 (map {
156 ["the utf8 sequence for chr $_->[0]",
347a2837 157 qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
435e7af6 158 ["no utf8; for the utf8 sequence for chr $_->[0]",
4c26891c 159 qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
435e7af6 160 ["use utf8; for the utf8 sequence for chr $_->[0]",
4c26891c 161 qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
435e7af6
NC
162 } @char),
163 # Interpolation of hex characters needs to take place now, as we're
164 # testing feeding malformed utf8 into perl. Bug now fixed was an
165 # "out of memory" error. We really need the "" [rather than qq()
166 # or q()] to get the best explosion.
167 ["!Feed malformed utf8 into perl.", <<"BANG",
8ff713d9 168 use utf8; %a = ("$malformed" =>"sterling");
435e7af6 169 print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
8ae6c9f9 170BANG
9a6c9c81 171 qr/^Malformed UTF-8 character: .*? \(too short; \d bytes? available, need \d\).*start\d+,end$/sm
435e7af6 172 ],
4c26891c
NC
173 );
174 foreach (@tests) {
435e7af6 175 my ($why, $prog, $expect) = @$_;
1ae6ead9 176 open P, ">", $progfile or die "Can't open '$progfile': $!";
47520729 177 binmode(P, ":bytes") if $has_perlio;
4c26891c
NC
178 print P $show, $prog, '; print $b'
179 or die "Print to 'progfile' failed: $!";
435e7af6
NC
180 close P or die "Can't close '$progfile': $!";
181 if ($why =~ s/^!//) {
182 print "# Possible delay...\n";
183 } else {
184 print "# $prog\n";
185 }
186 my $result = runperl ( stderr => 1, progfile => $progfile );
187 like ($result, $expect, $why);
188 }
4c26891c
NC
189 print
190 "# Again! Again! [but this time as eval, and not the explosive one]\n";
191 # and now we've safely done them all as separate files, check that the
a6d05634 192 # evals do the same thing. Hopefully doing it later successfully decouples
4c26891c
NC
193 # the previous tests from anything messy that may go wrong with the evals.
194 foreach (@tests) {
195 my ($why, $prog, $expect) = @$_;
196 next if $why =~ m/^!/; # Goes bang.
197 my $result = eval $prog;
198 if ($@) {
199 print "# prog is $prog\n";
200 print "# \$\@=", _qq($@), "\n";
201 }
202 like ($result, $expect, $why);
203 }
204
205 # See what the tokeniser does with hash keys.
206 print "# What does the tokeniser do with utf8 hash keys?\n";
207 @tests = (map {
208 # This is the control - I don't expect it to fail
209 ["assign utf8 for chr $_->[0] to a hash",
210 qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
211 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
212 qr/^>$_->[2]<$/],
213 ["no utf8; assign utf8 for chr $_->[0] to a hash",
214 qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
215 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
216 qr/^>$_->[2]<$/],
217 ["use utf8; assign utf8 for chr $_->[0] to a hash",
218 qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
219 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
220 qr/^>$_->[0]<$/],
221 # Now check literal $h{"x"} constructions.
222 ["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
223 qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
224 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
225 qr/^>$_->[2]<$/],
226 ["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
227 qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
228 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
229 qr/^>$_->[2]<$/],
230 ["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
231 qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
232 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
233 qr/^>$_->[0]<$/],
234 # Now check "x" => constructions.
235 ["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
236 qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
237 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
238 qr/^>$_->[2]<$/],
239 ["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
240 qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
241 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
242 qr/^>$_->[2]<$/],
243 ["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
244 qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
245 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
246 qr/^>$_->[0]<$/],
247 # Check copies of hashes made from literal utf8 keys
248 ["assign utf8 for chr $_->[0] to a hash, then copy it",
249 qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
250 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
251 qr/^>$_->[2]<$/],
252 ["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
253 qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i;
254 my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
255 qr/^>$_->[2]<$/],
256 ["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
257 qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
258 my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
259 qr/^>$_->[0]<$/],
260 } @char);
261 foreach (@tests) {
262 my ($why, $prog, $expect) = @$_;
263 # print "# $prog\n";
264 my $result = eval $prog;
265 like ($result, $expect, $why);
266 }
8ae6c9f9 267}
107c2363
MP
268
269#
270# bug fixed by change #17928
271# separate perl used because we rely on 'strict' not yet loaded;
272# before the patch, the eval died with an error like:
273# "my" variable $strict::VERSION can't be in a package
274#
a901eef8 275SKIP: {
679f623f
KW
276 skip("Haven't bothered to port this to EBCDIC non-1047", 1) if $::IS_EBCDIC
277 && ord '^' != 95;
278 if ($::IS_ASCII) {
279 ok('' eq runperl(prog => <<'CODE'), "change #17928");
280 my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
281 {
282 use utf8;
283 eval $code;
284 print $@ if $@;
285 }
286CODE
107c2363 287 }
679f623f
KW
288 else {
289 ok('' eq runperl(prog => <<'CODE'), "change #17928");
290 my $code = qq{ my \$\xCE\x47\x64\xCE\x48\x70 = 5; };
291 {
292 use utf8;
293 eval $code;
294 print $@ if $@;
295 }
107c2363 296CODE
679f623f 297 }
a901eef8 298}
a5b510f2
AE
299
300{
301 use utf8;
302 $a = <<'END';
3030 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
304END
305 my (@i, $s);
306
307 @i = ();
308 push @i, $s = index($a, '6'); # 60
309 push @i, $s = index($a, '.', $s); # next . after 60 is 62
310 push @i, $s = index($a, '5'); # 50
311 push @i, $s = index($a, '.', $s); # next . after 52 is 52
312 push @i, $s = index($a, '7'); # 70
313 push @i, $s = index($a, '.', $s); # next . after 70 is 72
314 push @i, $s = index($a, '4'); # 40
315 push @i, $s = index($a, '.', $s); # next . after 40 is 42
316 is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
317
318 @i = ();
319 push @i, $s = rindex($a, '6'); # 60
320 push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
321 push @i, $s = rindex($a, '5'); # 50
322 push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
323 push @i, $s = rindex($a, '7'); # 70
324 push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
325 push @i, $s = rindex($a, '4'); # 40
326 push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
327 is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
328
329 @i = ();
330 push @i, $s = index($a, '6'); # 60
331 push @i, index($a, '.', $s); # next . after 60 is 62
332 push @i, rindex($a, '.', $s); # previous . before 60 is 58
333 push @i, $s = rindex($a, '5'); # 60
334 push @i, index($a, '.', $s); # next . after 50 is 52
335 push @i, rindex($a, '.', $s); # previous . before 50 is 48
336 push @i, $s = index($a, '7', $s); # 70
337 push @i, index($a, '.', $s); # next . after 70 is 72
338 push @i, rindex($a, '.', $s); # previous . before 70 is 68
339 is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
340}
341
a901eef8 342SKIP: {
679f623f
KW
343 skip("Haven't bothered to port this to EBCDIC non-1047", 1) if $::IS_EBCDIC
344 && ord '^' != 95;
220e2d4e 345 use utf8;
679f623f
KW
346 if ($::IS_ASCII) {
347 is eval qq{q \xc3\xbc test \xc3\xbc . qq\xc2\xb7 test \xc2\xb7},
348 ' test test ',
349 "utf8 quote delimiters [perl #16823]";
350 }
351 else {
352 is eval qq{q \x8B\x70 test \x8B\x70 . qq\x80\x66 test \x80\x66},
353 ' test test ',
354 "utf8 quote delimiters [perl #16823]";
355 }
220e2d4e 356}
6e37fd2a
JH
357
358# Test the "internals".
359
360{
361 my $a = "A";
362 my $b = chr(0x0FF);
7adaf5b2
KW
363 my $c = chr(0x0DF); # FF is invariant in many EBCDIC pages, so is not a
364 # fair test of 'beyond'; but DF is variant (in all
365 # supported EBCDIC pages so far), so make 2 'beyond'
366 # tests
367 my $d = chr(0x100);
6e37fd2a
JH
368
369 ok( utf8::valid($a), "utf8::valid basic");
370 ok( utf8::valid($b), "utf8::valid beyond");
7adaf5b2
KW
371 ok( utf8::valid($c), "utf8::valid beyond");
372 ok( utf8::valid($d), "utf8::valid unicode");
6e37fd2a
JH
373
374 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
375 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
7adaf5b2
KW
376 ok(!utf8::is_utf8($c), "!utf8::is_utf8 beyond");
377 ok( utf8::is_utf8($d), "utf8::is_utf8 unicode");
6e37fd2a
JH
378
379 is(utf8::upgrade($a), 1, "utf8::upgrade basic");
83bcbc61 380 if ($::IS_EBCDIC) { # EBCDIC.
2f3efc97
JH
381 is(utf8::upgrade($b), 1, "utf8::upgrade beyond");
382 } else {
383 is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
384 }
7adaf5b2
KW
385 is(utf8::upgrade($c), 2, "utf8::upgrade beyond");
386 is(utf8::upgrade($d), 2, "utf8::upgrade unicode");
6e37fd2a
JH
387
388 is($a, "A", "basic");
389 is($b, "\xFF", "beyond");
7adaf5b2
KW
390 is($c, "\xDF", "beyond");
391 is($d, "\x{100}", "unicode");
6e37fd2a
JH
392
393 ok( utf8::valid($a), "utf8::valid basic");
394 ok( utf8::valid($b), "utf8::valid beyond");
7adaf5b2
KW
395 ok( utf8::valid($c), "utf8::valid beyond");
396 ok( utf8::valid($d), "utf8::valid unicode");
6e37fd2a
JH
397
398 ok( utf8::is_utf8($a), "utf8::is_utf8 basic");
399 ok( utf8::is_utf8($b), "utf8::is_utf8 beyond");
7adaf5b2
KW
400 ok( utf8::is_utf8($c), "utf8::is_utf8 beyond");
401 ok( utf8::is_utf8($d), "utf8::is_utf8 unicode");
6e37fd2a
JH
402
403 is(utf8::downgrade($a), 1, "utf8::downgrade basic");
404 is(utf8::downgrade($b), 1, "utf8::downgrade beyond");
7adaf5b2 405 is(utf8::downgrade($c), 1, "utf8::downgrade beyond");
6e37fd2a
JH
406
407 is($a, "A", "basic");
408 is($b, "\xFF", "beyond");
7adaf5b2 409 is($c, "\xDF", "beyond");
6e37fd2a
JH
410
411 ok( utf8::valid($a), "utf8::valid basic");
412 ok( utf8::valid($b), "utf8::valid beyond");
7adaf5b2 413 ok( utf8::valid($c), "utf8::valid beyond");
6e37fd2a
JH
414
415 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
416 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
7adaf5b2 417 ok(!utf8::is_utf8($c), "!utf8::is_utf8 beyond");
6e37fd2a
JH
418
419 utf8::encode($a);
420 utf8::encode($b);
421 utf8::encode($c);
7adaf5b2 422 utf8::encode($d);
6e37fd2a
JH
423
424 is($a, "A", "basic");
83bcbc61 425 if ($::IS_EBCDIC) { # EBCDIC.
2f3efc97
JH
426 is(length($b), 1, "beyond length");
427 } else {
428 is(length($b), 2, "beyond length");
429 }
7adaf5b2
KW
430 is(length($c), 2, "beyond length");
431 is(length($d), 2, "unicode length");
6e37fd2a
JH
432
433 ok(utf8::valid($a), "utf8::valid basic");
434 ok(utf8::valid($b), "utf8::valid beyond");
7adaf5b2
KW
435 ok(utf8::valid($c), "utf8::valid beyond");
436 ok(utf8::valid($d), "utf8::valid unicode");
6e37fd2a
JH
437
438 # encode() clears the UTF-8 flag (unlike upgrade()).
439 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
440 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
7adaf5b2
KW
441 ok(!utf8::is_utf8($c), "!utf8::is_utf8 beyond");
442 ok(!utf8::is_utf8($d), "!utf8::is_utf8 unicode");
6e37fd2a
JH
443
444 utf8::decode($a);
445 utf8::decode($b);
446 utf8::decode($c);
7adaf5b2 447 utf8::decode($d);
6e37fd2a
JH
448
449 is($a, "A", "basic");
450 is($b, "\xFF", "beyond");
7adaf5b2
KW
451 is($c, "\xDF", "beyond");
452 is($d, "\x{100}", "unicode");
6e37fd2a
JH
453
454 ok(utf8::valid($a), "!utf8::valid basic");
455 ok(utf8::valid($b), "!utf8::valid beyond");
7adaf5b2
KW
456 ok(utf8::valid($c), "!utf8::valid beyond");
457 ok(utf8::valid($d), " utf8::valid unicode");
6e37fd2a
JH
458
459 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
83bcbc61 460 if ($::IS_EBCDIC) { # EBCDIC.
2f3efc97
JH
461 ok( utf8::is_utf8(pack('U',0x0ff)), " utf8::is_utf8 beyond");
462 } else {
463 ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
464 }
7adaf5b2
KW
465 ok( utf8::is_utf8($c), " utf8::is_utf8 beyond"); # $c stays in UTF-8.
466 ok( utf8::is_utf8($d), " utf8::is_utf8 unicode");
6e37fd2a 467}
5fec3b1d
NC
468
469{
470 eval {utf8::encode("£")};
471 like($@, qr/^Modification of a read-only value attempted/,
472 "utf8::encode should refuse to touch read-only values");
473}
06a45632
ST
474
475{
b2b7346b
FC
476 # Make sure utf8::decode respects copy-on-write [perl #91834].
477 # Hash keys are the easiest way to test this.
d591e493 478 my $name = byte_utf8a_to_utf8n("\x{c3}\x{b3}");
b2b7346b
FC
479 my ($k1) = keys %{ { $name=>undef } };
480 my $k2 = $name;
481 utf8::decode($k1);
482 utf8::decode($k2);
483 my $h = { $k1 => 1, $k2 => 2 };
1df6869d 484 is join('', keys %$h), $k2, 'utf8::decode respects copy-on-write';
b2b7346b
FC
485}
486
487{
492ebaba
FC
488 # Make sure utf8::decode does not modify read-only scalars
489 # [perl #91850].
490
d591e493 491 my $name = byte_utf8a_to_utf8n("\x{c3}\x{b3}");
492ebaba
FC
492 Internals::SvREADONLY($name, 1);
493 eval { utf8::decode($name) };
494 like $@, qr/^Modification of a read-only/,
495 'utf8::decode respects readonliness';
496}
497
498{
892522a6 499 # utf8::decode should stringify refs [perl #91852].
c7102404 500
d591e493 501 package eieifg { use overload '""' => sub { main::byte_utf8a_to_utf8n("\x{c3}\x{b3}") },
c7102404
FC
502 fallback => 1 }
503
504 my $name = bless[], eieifg::;
505 utf8::decode($name);
d591e493 506 is $name, uni_to_native("\xf3"), 'utf8::decode flattens references';
c7102404
FC
507}
508
509{
64470437
AB
510 # What do the utf8::* functions do when given a reference? A test
511 # for a behavior change that made this start dying as of
512 # v5.15.6-407-gc710240 due to a fix for [perl #91852]:
513 #
514 # ./miniperl -Ilib -wle 'use strict; print $]; my $s = shift; my $s_ref = \$s; utf8::decode($s_ref); print $$s_ref' hlagh
515 my %expected = (
516 'utf8::is_utf8' => { returns => "hlagh" },
517 'utf8::valid' => { returns => "hlagh" },
518 'utf8::encode' => { error => qr/Can't use string .*? as a SCALAR ref/},
519 'utf8::decode' => { error => qr/Can't use string .*? as a SCALAR ref/},
520 'utf8::upgrade' => { error => qr/Can't use string .*? as a SCALAR ref/ },
521 'utf8::downgrade' => { returns => "hlagh" },
522 'utf8::native_to_unicode' => { returns => "hlagh" },
523 'utf8::unicode_to_native' => { returns => "hlagh" },
524 );
525 for my $func (sort keys %expected) { # sort just so it's deterministic wrt diffing *.t output
526 my $code = sprintf q[
527 use strict;
528 my $s = "hlagh";
529 my $r = \$s;
273e254d 530 my $dummy = %s($r);
64470437
AB
531 $$r;
532 ], $func;
533 my $ret = eval $code or my $error = $@;
534 if (my $error_rx = $expected{$func}->{error}) {
535 if (defined $error) {
536 like $error, $error_rx, "The $func function should die with an error matching $error_rx";
537 } else {
538 fail("We were expecting an error when calling the $func function but got a value of '$ret' instead");
539 }
540 } elsif (my $returns = $expected{$func}->{returns}) {
541 is($ret, $returns, "The $func function lives and returns '$returns' as expected");
542 } else {
543 die "PANIC: Internal Error"
544 }
545 }
546}
547
548{
d591e493 549 my $a = "456" . uni_to_native("\xb6");
06a45632
ST
550 utf8::upgrade($a);
551
d591e493 552 my $b = "123456" . uni_to_native("\xb6");
ccc73c2d 553 $b =~ s/^...//;
06a45632
ST
554 utf8::upgrade($b);
555 is($b, $a, "utf8::upgrade OffsetOK");
556}
bd7017d3
NC
557
558{
559 fresh_perl_like ('use utf8; utf8::moo()',
560 qr/Undefined subroutine utf8::moo/, {stderr=>1},
561 "Check Carp is loaded for AUTOLOADing errors")
562}
77263263
ST
563
564{
565 # failure of is_utf8_char() without NATIVE_TO_UTF on EBCDIC (0260..027F)
566 ok(utf8::valid(chr(0x250)), "0x250");
567 ok(utf8::valid(chr(0x260)), "0x260");
568 ok(utf8::valid(chr(0x270)), "0x270");
569 ok(utf8::valid(chr(0x280)), "0x280");
570}
96d9949f
EB
571
572{
573 use utf8;
574 ok( !utf8::is_utf8( "asd" ), "Wasteful format - qq{}" );
575 ok( !utf8::is_utf8( 'asd' ), "Wasteful format - q{}" );
576 ok( !utf8::is_utf8( qw(asd) ), "Wasteful format - qw{}" );
577 ok( !utf8::is_utf8( (asd => 1)[0] ), "Wasteful format - =>" );
96d9949f 578 ok( !utf8::is_utf8( -asd ), "Wasteful format - -word" );
e4dc48dc 579 no warnings 'bareword';
96d9949f 580 ok( !utf8::is_utf8( asd:: ), "Wasteful format - word::" );
e4dc48dc
NC
581 no warnings 'reserved';
582 no strict 'subs';
583 ok( !utf8::is_utf8( asd ), "Wasteful format - bareword" );
96d9949f 584}
a18d6e6e
NC
585
586{
587 my @highest =
588 (undef, 0x7F, 0x7FF, 0xFFFF, 0x1FFFFF, 0x3FFFFFF, 0x7FFFFFFF);
589 my @step =
590 (undef, undef, 0x40, 0x1000, 0x40000, 0x1000000, 0x40000000);
591
592 foreach my $length (6, 5, 4, 3, 2) {
593 my $high = $highest[$length];
594 while ($high > $highest[$length - 1]) {
595 my $low = $high - $step[$length] + 1;
596 $low = $highest[$length - 1] + 1 if $low <= $highest[$length - 1];
597 ok(utf8::valid(do {no warnings 'utf8'; chr $low}),
598 sprintf "chr %x, length $length is valid", $low);
599 ok(utf8::valid(do {no warnings 'utf8'; chr $high}),
600 sprintf "chr %x, length $length is valid", $high);
601 $high -= $step[$length];
602 }
603 }
604}
605
75da9d4c
DM
606# #80190 update pos, and cached length/position-mapping after
607# utf8 upgrade/downgrade, encode/decode
608
609for my $pos (0..5) {
610
75da9d4c 611 my $p;
d591e493
KW
612 my $utf8_bytes = byte_utf8a_to_utf8n("\xc8\x81\xe3\xbf\xbf");
613 my $s = "A$utf8_bytes\x{100}";
75da9d4c
DM
614 chop($s);
615
616 pos($s) = $pos;
617 # also sets cache
618 is(length($s), 6, "(pos $pos) len before utf8::downgrade");
619 is(pos($s), $pos, "(pos $pos) pos before utf8::downgrade");
620 utf8::downgrade($s);
621 is(length($s), 6, "(pos $pos) len after utf8::downgrade");
622 is(pos($s), $pos, "(pos $pos) pos after utf8::downgrade");
d591e493 623 is($s, "A$utf8_bytes","(pos $pos) str after utf8::downgrade");
75da9d4c
DM
624 utf8::decode($s);
625 is(length($s), 3, "(pos $pos) len after D; utf8::decode");
158f7f72 626 is(pos($s), undef, "(pos $pos) pos after D; utf8::decode");
d591e493 627 is($s, "A\x{201}\x{3fff}", "(pos $pos) str after D; utf8::decode");
75da9d4c
DM
628 utf8::encode($s);
629 is(length($s), 6, "(pos $pos) len after D; utf8::encode");
158f7f72 630 is(pos($s), undef, "(pos $pos) pos after D; utf8::encode");
d591e493 631 is($s, "A$utf8_bytes","(pos $pos) str after D; utf8::encode");
75da9d4c 632
d591e493 633 $s = "A$utf8_bytes";
75da9d4c
DM
634
635 pos($s) = $pos;
636 is(length($s), 6, "(pos $pos) len before utf8::upgrade");
637 is(pos($s), $pos, "(pos $pos) pos before utf8::upgrade");
638 utf8::upgrade($s);
639 is(length($s), 6, "(pos $pos) len after utf8::upgrade");
640 is(pos($s), $pos, "(pos $pos) pos after utf8::upgrade");
d591e493 641 is($s, "A$utf8_bytes","(pos $pos) str after utf8::upgrade");
75da9d4c
DM
642 utf8::decode($s);
643 is(length($s), 3, "(pos $pos) len after U; utf8::decode");
158f7f72 644 is(pos($s), undef, "(pos $pos) pos after U; utf8::decode");
d591e493 645 is($s, "A\x{201}\x{3fff}", "(pos $pos) str after U; utf8::decode");
75da9d4c
DM
646 utf8::encode($s);
647 is(length($s), 6, "(pos $pos) len after U; utf8::encode");
158f7f72 648 is(pos($s), undef, "(pos $pos) pos after U; utf8::encode");
d591e493 649 is($s, "A$utf8_bytes","(pos $pos) str after U; utf8::encode");
75da9d4c
DM
650}
651
273e254d
KW
652SKIP: {
653 skip("Test only valid on ASCII platform", 1) unless $::IS_ASCII;
654 require Config;
655 skip("Test needs a B module, which is lacking in this Perl", 1)
656 if $Config::Config{'extensions'} !~ /\bB\b/;
657
658 my $out = runperl ( switches => ["-XMO=Concise"],
659 prog => 'utf8::unicode_to_native(0x41);
660 utf8::native_to_unicode(0x42)',
661 stderr => 1 );
662 unlike($out, qr/entersub/,
663 "utf8::unicode_to_native() and native_to_unicode() optimized out");
664}
665
666
c56ed9f6
FC
667# [perl #119043] utf8::upgrade should not croak on read-only COWs
668for(__PACKAGE__) {
c56ed9f6
FC
669 eval { utf8::upgrade($_) };
670 is $@, "", 'no error with utf8::upgrade on read-only COW';
c56ed9f6
FC
671}
672# This one croaks, but not because the scalar is read-only
673eval "package \x{100};\n" . <<'END'
674 for(__PACKAGE__) {
675 eval { utf8::downgrade($_) };
676 ::like $@, qr/^Wide character/,
677 'right error with utf8::downgrade on read-only COW';
678 }
679 1
680END
681or die $@;
682
a18d6e6e 683done_testing();