9 unless ($has_perlio = find PerlIO::Layer 'perlio') {
11 # Since you don't have perlio you might get failures with UTF-8 locales.
16 no utf8; # Ironic, no?
20 # Think carefully before adding tests here. In general this should be
21 # used only for about three categories of tests:
23 # (1) tests that absolutely require 'use utf8', and since that in general
24 # shouldn't be needed as the utf8 is being obsoleted, this should
25 # have rather few tests. If you want to test Unicode and regexes,
26 # you probably want to go to op/regexp or op/pat; if you want to test
27 # split, go to op/split; pack, op/pack; appending or joining,
28 # op/append or op/join, and so forth
30 # (2) tests that have to do with Unicode tokenizing (though it's likely
31 # that all the other Unicode tests sprinkled around the t/**/*.t are
32 # going to catch that)
34 # (3) complicated tests that simultaneously stress so many Unicode features
35 # that deciding into which other test script the tests should go to
36 # is hard -- maybe consider breaking up the complicated test
47 { use bytes; $a = "\xc3\xa4" }
48 { use utf8; $b = "\xe4" }
54 { use utf8; ok($a ne $b) }
61 my $smiley = "\x{263a}";
63 for my $s ("\x{263a}",
72 my $length_chars = length($s);
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;
79 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
83 for my $s ("\x{263a}" . "\x{263a}",
92 my $length_chars = length($s);
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;
99 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
107 local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
108 my $x = eval q/"\\/ . "\x{100}" . q/"/;;
110 ok($w == 0 && $x eq "\x{100}");
120 $result .= '>' . join (',', map {ord} split //, $_) . '<'
126 eval $show or die $@; # We don't expect this sub definition to fail.
127 my $progfile = 'utf' . $$;
128 END {unlink_all $progfile}
130 # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC
131 # 173 is not punctuation in either ASCII or EBCDIC
133 foreach (60, 173, 257, 65532) {
136 # I don't want to use map {ord} and I've no need to hardcode the UTF
138 my $charsubst = $char;
139 $charsubst =~ s/(.)/ord ($1) . ','/ge;
141 # Not testing this one against map {ord}
143 = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
144 push @char, [$_, $char, $charsubst, $char_as_ord];
146 # Now we've done all the UTF8 munching hopefully we're safe
148 ['check our detection program works',
149 'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
150 ['check literal 8 bit input',
151 '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
152 ['check no utf8; makes no change',
153 'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
154 # Now we do the real byte sequences that are valid UTF8
156 ["the utf8 sequence for chr $_->[0]",
157 qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
158 ["no utf8; for the utf8 sequence for chr $_->[0]",
159 qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
160 ["use utf8; for the utf8 sequence for chr $_->[0]",
161 qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
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",
168 use utf8; %a = ("\xE1\xA0"=>"sterling");
169 print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
171 qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm
175 my ($why, $prog, $expect) = @$_;
176 open P, ">$progfile" or die "Can't open '$progfile': $!";
177 binmode(P, ":bytes") if $has_perlio;
178 print P $show, $prog, '; print $b'
179 or die "Print to 'progfile' failed: $!";
180 close P or die "Can't close '$progfile': $!";
181 if ($why =~ s/^!//) {
182 print "# Possible delay...\n";
186 my $result = runperl ( stderr => 1, progfile => $progfile );
187 like ($result, $expect, $why);
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
192 # evals do the same thing. Hopefully doing it later successfully decouples
193 # the previous tests from anything messy that may go wrong with the evals.
195 my ($why, $prog, $expect) = @$_;
196 next if $why =~ m/^!/; # Goes bang.
197 my $result = eval $prog;
199 print "# prog is $prog\n";
200 print "# \$\@=", _qq($@), "\n";
202 like ($result, $expect, $why);
205 # See what the tokeniser does with hash keys.
206 print "# What does the tokeniser do with utf8 hash keys?\n";
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),
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),
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),
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),
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),
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),
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),
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),
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),
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),
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),
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),
262 my ($why, $prog, $expect) = @$_;
264 my $result = eval $prog;
265 like ($result, $expect, $why);
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
276 skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
277 ok('' eq runperl(prog => <<'CODE'), "change #17928");
278 my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
290 0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
295 push @i, $s = index($a, '6'); # 60
296 push @i, $s = index($a, '.', $s); # next . after 60 is 62
297 push @i, $s = index($a, '5'); # 50
298 push @i, $s = index($a, '.', $s); # next . after 52 is 52
299 push @i, $s = index($a, '7'); # 70
300 push @i, $s = index($a, '.', $s); # next . after 70 is 72
301 push @i, $s = index($a, '4'); # 40
302 push @i, $s = index($a, '.', $s); # next . after 40 is 42
303 is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
306 push @i, $s = rindex($a, '6'); # 60
307 push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
308 push @i, $s = rindex($a, '5'); # 50
309 push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
310 push @i, $s = rindex($a, '7'); # 70
311 push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
312 push @i, $s = rindex($a, '4'); # 40
313 push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
314 is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
317 push @i, $s = index($a, '6'); # 60
318 push @i, index($a, '.', $s); # next . after 60 is 62
319 push @i, rindex($a, '.', $s); # previous . before 60 is 58
320 push @i, $s = rindex($a, '5'); # 60
321 push @i, index($a, '.', $s); # next . after 50 is 52
322 push @i, rindex($a, '.', $s); # previous . before 50 is 48
323 push @i, $s = index($a, '7', $s); # 70
324 push @i, index($a, '.', $s); # next . after 70 is 72
325 push @i, rindex($a, '.', $s); # previous . before 70 is 68
326 is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
330 skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
332 eval qq{is(q \xc3\xbc test \xc3\xbc, qq\xc2\xb7 test \xc2\xb7,
333 "utf8 quote delimiters [perl #16823]");};
336 # Test the "internals".
343 ok( utf8::valid($a), "utf8::valid basic");
344 ok( utf8::valid($b), "utf8::valid beyond");
345 ok( utf8::valid($c), "utf8::valid unicode");
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");
351 is(utf8::upgrade($a), 1, "utf8::upgrade basic");
352 is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
353 is(utf8::upgrade($c), 2, "utf8::upgrade unicode");
355 is($a, "A", "basic");
356 is($b, "\xFF", "beyond");
357 is($c, "\x{100}", "unicode");
359 ok( utf8::valid($a), "utf8::valid basic");
360 ok( utf8::valid($b), "utf8::valid beyond");
361 ok( utf8::valid($c), "utf8::valid unicode");
363 ok( utf8::is_utf8($a), "utf8::is_utf8 basic");
364 ok( utf8::is_utf8($b), "utf8::is_utf8 beyond");
365 ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
367 is(utf8::downgrade($a), 1, "utf8::downgrade basic");
368 is(utf8::downgrade($b), 1, "utf8::downgrade beyond");
370 is($a, "A", "basic");
371 is($b, "\xFF", "beyond");
373 ok( utf8::valid($a), "utf8::valid basic");
374 ok( utf8::valid($b), "utf8::valid beyond");
376 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
377 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
383 is($a, "A", "basic");
384 is(length($b), 2, "beyond length");
385 is(length($c), 2, "unicode length");
387 ok(utf8::valid($a), "utf8::valid basic");
388 ok(utf8::valid($b), "utf8::valid beyond");
389 ok(utf8::valid($c), "utf8::valid unicode");
391 # encode() clears the UTF-8 flag (unlike upgrade()).
392 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
393 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
394 ok(!utf8::is_utf8($c), "!utf8::is_utf8 unicode");
400 is($a, "A", "basic");
401 is($b, "\xFF", "beyond");
402 is($c, "\x{100}", "unicode");
404 ok(utf8::valid($a), "!utf8::valid basic");
405 ok(utf8::valid($b), "!utf8::valid beyond");
406 ok(utf8::valid($c), " utf8::valid unicode");
408 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
409 ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
410 ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
414 eval {utf8::encode("£")};
415 like($@, qr/^Modification of a read-only value attempted/,
416 "utf8::encode should refuse to touch read-only values");