lib/utf8.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 # NOTE!
  10 #
  11 # Think carefully before adding tests here.  In general this should be
  12 # used only for about three categories of tests:
  13 #
  14 # (1) tests that absolutely require 'use utf8', and since that in general
  15 #     shouldn't be needed as the utf8 is being obsoleted, this should
  16 #     have rather few tests.  If you want to test Unicode and regexes,
  17 #     you probably want to go to op/regexp or op/pat; if you want to test
  18 #     split, go to op/split; pack, op/pack; appending or joining,
  19 #     op/append or op/join, and so forth
  20 #
  21 # (2) tests that have to do with Unicode tokenizing (though it's likely
  22 #     that all the other Unicode tests sprinkled around the t/**/*.t are
  23 #     going to catch that)
  24 #
  25 # (3) complicated tests that simultaneously stress so many Unicode features
  26 #     that deciding into which other test script the tests should go to
  27 #     is hard -- maybe consider breaking up the complicated test
  28 #
  29 #
  30
  31 plan tests => 94;
  32
  33 {
  34     # bug id 20001009.001
  35
  36     my ($a, $b);
  37
  38     { use bytes; $a = "\xc3\xa4" }
  39     { use utf8;  $b = "\xe4"     }
  40
  41     my $test = 68;
  42
  43     ok($a ne $b);
  44
  45     { use utf8; ok($a ne $b) }
  46 }
  47
  48
  49 {
  50     # bug id 20000730.004
  51
  52     my $smiley = "\x{263a}";
  53
  54     for my $s ("\x{263a}",
  55                $smiley,
  56
  57                "" . $smiley,
  58                "" . "\x{263a}",
  59
  60                $smiley    . "",
  61                "\x{263a}" . "",
  62                ) {
  63         my $length_chars = length($s);
  64         my $length_bytes;
  65         { use bytes; $length_bytes = length($s) }
  66         my @regex_chars = $s =~ m/(.)/g;
  67         my $regex_chars = @regex_chars;
  68         my @split_chars = split //, $s;
  69         my $split_chars = @split_chars;
  70         ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
  71            "1/1/1/3");
  72     }
  73
  74     for my $s ("\x{263a}" . "\x{263a}",
  75                $smiley    . $smiley,
  76
  77                "\x{263a}\x{263a}",
  78                "$smiley$smiley",
  79
  80                "\x{263a}" x 2,
  81                $smiley    x 2,
  82                ) {
  83         my $length_chars = length($s);
  84         my $length_bytes;
  85         { use bytes; $length_bytes = length($s) }
  86         my @regex_chars = $s =~ m/(.)/g;
  87         my $regex_chars = @regex_chars;
  88         my @split_chars = split //, $s;
  89         my $split_chars = @split_chars;
  90         ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
  91            "2/2/2/6");
  92     }
  93 }
  94
  95
  96 {
  97     my $w = 0;
  98     local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
  99     my $x = eval q/"\\/ . "\x{100}" . q/"/;;
 100
 101     ok($w == 0 && $x eq "\x{100}");
 102 }
 103
 104 {
 105     use warnings;
 106     use strict;
 107
 108     my $show = q(
 109                  sub show {
 110                    my $result;
 111                    $result .= '>' . join (',', map {ord} split //, $_) . '<'
 112                      foreach @_;
 113                    $result;
 114                  }
 115                  1;
 116                 );
 117     eval $show or die $@; # We don't expect this sub definition to fail.
 118     my $progfile = 'utf' . $$;
 119     END {unlink_all $progfile}
 120
 121     # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC
 122     # 173 is not punctuation in either ASCII or EBCDIC
 123     my (@char);
 124     foreach (60, 173, 257, 65532) {
 125       my $char = chr $_;
 126       utf8::encode($char);
 127       # I don't want to use map {ord} and I've no need to hardcode the UTF
 128       # version
 129       my $charsubst = $char;
 130       $charsubst =~ s/(.)/ord ($1) . ','/ge;
 131       chop $charsubst;
 132       # Not testing this one against map {ord}
 133       my $char_as_ord
 134           = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
 135       push @char, [$_, $char, $charsubst, $char_as_ord];
 136     }
 137     # Now we've done all the UTF8 munching hopefully we're safe
 138     my @tests = (
 139              ['check our detection program works',
 140               'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
 141              ['check literal 8 bit input',
 142               '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
 143              ['check no utf8; makes no change',
 144               'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
 145              # Now we do the real byte sequences that are valid UTF8
 146              (map {
 147                ["the utf8 sequence for chr $_->[0]",
 148                 qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
 149                ["no utf8; for the utf8 sequence for chr $_->[0]",
 150                 qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
 151                ["use utf8; for the utf8 sequence for chr $_->[0]",
 152                 qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
 153               } @char),
 154              # Interpolation of hex characters needs to take place now, as we're
 155              # testing feeding malformed utf8 into perl. Bug now fixed was an
 156              # "out of memory" error. We really need the "" [rather than qq()
 157              # or q()] to get the best explosion.
 158              ["!Feed malformed utf8 into perl.", <<"BANG",
 159     use utf8; %a = ("\xE1\xA0"=>"sterling");
 160     print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
 161 BANG
 162               qr/^Malformed UTF-8 character \(2 bytes, need 3.+\).*start\d+,end$/s
 163              ],
 164             );
 165     foreach (@tests) {
 166         my ($why, $prog, $expect) = @$_;
 167         open P, ">$progfile" or die "Can't open '$progfile': $!";
 168         binmode(P, ":bytes");
 169         print P $show, $prog, '; print $b'
 170             or die "Print to 'progfile' failed: $!";
 171         close P or die "Can't close '$progfile': $!";
 172         if ($why =~ s/^!//) {
 173             print "# Possible delay...\n";
 174         } else {
 175             print "# $prog\n";
 176         }
 177         my $result = runperl ( stderr => 1, progfile => $progfile );
 178         like ($result, $expect, $why);
 179     }
 180     print
 181         "# Again! Again! [but this time as eval, and not the explosive one]\n";
 182     # and now we've safely done them all as separate files, check that the
 183     # evals do the same thing. Hopefully doing it later sucessfully decouples
 184     # the previous tests from anything messy that may go wrong with the evals.
 185     foreach (@tests) {
 186         my ($why, $prog, $expect) = @$_;
 187         next if $why =~ m/^!/; # Goes bang.
 188         my $result = eval $prog;
 189         if ($@) {
 190             print "# prog is $prog\n";
 191             print "# \$\@=", _qq($@), "\n";
 192         }
 193         like ($result, $expect, $why);
 194     }
 195
 196     # See what the tokeniser does with hash keys.
 197     print "# What does the tokeniser do with utf8 hash keys?\n";
 198     @tests = (map {
 199         # This is the control - I don't expect it to fail
 200         ["assign utf8 for chr $_->[0] to a hash",
 201          qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
 202             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 203          qr/^>$_->[2]<$/],
 204         ["no utf8; assign utf8 for chr $_->[0] to a hash",
 205          qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
 206             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 207          qr/^>$_->[2]<$/],
 208         ["use utf8; assign utf8 for chr $_->[0] to a hash",
 209          qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
 210             my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
 211          qr/^>$_->[0]<$/],
 212         # Now check literal $h{"x"} constructions.
 213         ["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
 214          qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
 215             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 216          qr/^>$_->[2]<$/],
 217         ["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
 218          qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
 219             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 220          qr/^>$_->[2]<$/],
 221         ["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
 222          qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
 223             my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
 224          qr/^>$_->[0]<$/],
 225         # Now check "x" => constructions.
 226         ["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
 227          qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
 228             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 229          qr/^>$_->[2]<$/],
 230         ["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
 231          qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
 232             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 233          qr/^>$_->[2]<$/],
 234         ["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
 235          qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
 236             my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
 237          qr/^>$_->[0]<$/],
 238         # Check copies of hashes made from literal utf8 keys
 239         ["assign utf8 for chr $_->[0] to a hash, then copy it",
 240          qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
 241             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 242          qr/^>$_->[2]<$/],
 243         ["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
 244          qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i;
 245             my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
 246          qr/^>$_->[2]<$/],
 247         ["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
 248          qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
 249             my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
 250          qr/^>$_->[0]<$/],
 251      } @char);
 252     foreach (@tests) {
 253         my ($why, $prog, $expect) = @$_;
 254         # print "# $prog\n";
 255         my $result = eval $prog;
 256         like ($result, $expect, $why);
 257     }
 258 }