lib/utf8.t

   1 #!./perl
   2
   3 my $has_perlio;
   4
   5 BEGIN {
   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.
  12 EOF
  13     }
  14 }
  15
  16 no 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
  40 plan tests => 146;
  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";
 170 BANG
 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 #
 275 SKIP: {
 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     }
 284 CODE
 285 }
 286
 287 {
 288     use utf8;
 289     $a = <<'END';
 290 0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
 291 END
 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
 329 SKIP: {
 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
 429 {
 430     fresh_perl_like ('use utf8; utf8::moo()',
 431                      qr/Undefined subroutine utf8::moo/, {stderr=>1},
 432                     "Check Carp is loaded for AUTOLOADing errors")
 433 }