1#!./perl 2 3my $has_perlio; 4 5BEGIN { 6 chdir 't' if -d 't'; 7 @INC = '../lib'; 8 require './test.pl'; 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 } 14} 15 16no utf8; # Ironic, no? 17 18# NOTE! 19# 20# Think carefully before adding tests here. In general this should be 21# used only for about three categories of tests: 22# 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 29# 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) 33# 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 37# 38# 39 40plan tests => 145; 41 42{ 43 # bug id 20001009.001 44 45 my ($a, $b); 46 47 { use bytes; $a = "\xc3\xa4" } 48 { use utf8; $b = "\xe4" } 49 50 my $test = 68; 51 52 ok($a ne $b); 53 54 { use utf8; ok($a ne $b) } 55} 56 57 58{ 59 # bug id 20000730.004 60 61 my $smiley = "\x{263a}"; 62 63 for my $s ("\x{263a}", 64 $smiley, 65 66 "" . $smiley, 67 "" . "\x{263a}", 68 69 $smiley . "", 70 "\x{263a}" . "", 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; 79 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq 80 "1/1/1/3"); 81 } 82 83 for my $s ("\x{263a}" . "\x{263a}", 84 $smiley . $smiley, 85 86 "\x{263a}\x{263a}", 87 "$smiley$smiley", 88 89 "\x{263a}" x 2, 90 $smiley x 2, 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; 99 ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq 100 "2/2/2/6"); 101 } 102} 103 104 105{ 106 my $w = 0; 107 local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ }; 108 my $x = eval q/"\\/ . "\x{100}" . q/"/;; 109 110 ok($w == 0 && $x eq "\x{100}"); 111} 112 113{ 114 use warnings; 115 use strict; 116 117 my $show = q( 118 sub show { 119 my $result; 120 $result .= '>' . join (',', map {ord} split //, $_) . '<' 121 foreach @_; 122 $result; 123 } 124 1; 125 ); 126 eval $show or die $@; # We don't expect this sub definition to fail. 127 my $progfile = 'utf' . $$; 128 END {unlink_all $progfile} 129 130 # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC 131 # 173 is not punctuation in either ASCII or EBCDIC 132 my (@char); 133 foreach (60, 173, 257, 65532) { 134 my $char = chr $_; 135 utf8::encode($char); 136 # I don't want to use map {ord} and I've no need to hardcode the UTF 137 # version 138 my $charsubst = $char; 139 $charsubst =~ s/(.)/ord ($1) . ','/ge; 140 chop $charsubst; 141 # Not testing this one against map {ord} 142 my $char_as_ord 143 = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char; 144 push @char, [$_, $char, $charsubst, $char_as_ord]; 145 } 146 # Now we've done all the UTF8 munching hopefully we're safe 147 my @tests = ( 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 155 (map { 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]<$/], 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", 168 use utf8; %a = ("\xE1\xA0"=>"sterling"); 169 print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n"; 170BANG 171 qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm 172 ], 173 ); 174 foreach (@tests) { 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"; 183 } else { 184 print "# $prog\n"; 185 } 186 my $result = runperl ( stderr => 1, progfile => $progfile ); 187 like ($result, $expect, $why); 188 } 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 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. 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 } 267} 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# 275SKIP: { 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; }; 279 { 280 use utf8; 281 eval $code; 282 print $@ if $@; 283 } 284CODE 285} 286 287{ 288 use utf8; 289 $a = <<'END'; 2900 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 ....... 291END 292 my (@i, $s); 293 294 @i = (); 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"); 304 305 @i = (); 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"); 315 316 @i = (); 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"); 327} 328 329SKIP: { 330 skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193; 331 use utf8; 332 eval qq{is(q \xc3\xbc test \xc3\xbc, qq\xc2\xb7 test \xc2\xb7, 333 "utf8 quote delimiters [perl #16823]");}; 334} 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"); 352 is(utf8::upgrade($b), 2, "utf8::upgrade beyond"); 353 is(utf8::upgrade($c), 2, "utf8::upgrade unicode"); 354 355 is($a, "A", "basic"); 356 is($b, "\xFF", "beyond"); 357 is($c, "\x{100}", "unicode"); 358 359 ok( utf8::valid($a), "utf8::valid basic"); 360 ok( utf8::valid($b), "utf8::valid beyond"); 361 ok( utf8::valid($c), "utf8::valid unicode"); 362 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"); 366 367 is(utf8::downgrade($a), 1, "utf8::downgrade basic"); 368 is(utf8::downgrade($b), 1, "utf8::downgrade beyond"); 369 370 is($a, "A", "basic"); 371 is($b, "\xFF", "beyond"); 372 373 ok( utf8::valid($a), "utf8::valid basic"); 374 ok( utf8::valid($b), "utf8::valid beyond"); 375 376 ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); 377 ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); 378 379 utf8::encode($a); 380 utf8::encode($b); 381 utf8::encode($c); 382 383 is($a, "A", "basic"); 384 is(length($b), 2, "beyond length"); 385 is(length($c), 2, "unicode length"); 386 387 ok(utf8::valid($a), "utf8::valid basic"); 388 ok(utf8::valid($b), "utf8::valid beyond"); 389 ok(utf8::valid($c), "utf8::valid unicode"); 390 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"); 395 396 utf8::decode($a); 397 utf8::decode($b); 398 utf8::decode($c); 399 400 is($a, "A", "basic"); 401 is($b, "\xFF", "beyond"); 402 is($c, "\x{100}", "unicode"); 403 404 ok(utf8::valid($a), "!utf8::valid basic"); 405 ok(utf8::valid($b), "!utf8::valid beyond"); 406 ok(utf8::valid($c), " utf8::valid unicode"); 407 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"); 411} 412 413{ 414 eval {utf8::encode("�")}; 415 like($@, qr/^Modification of a read-only value attempted/, 416 "utf8::encode should refuse to touch read-only values"); 417} 418 419{ 420 my $a = "456\xb6"; 421 utf8::upgrade($a); 422 423 my $b = "123456\xb6"; 424 $b =~ s/^...//; 425 utf8::upgrade($b); 426 is($b, $a, "utf8::upgrade OffsetOK"); 427} 428