t/pragma/utf8.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     $ENV{PERL5LIB} = '../lib';
   7     if ( ord("\t") != 9 ) { # skip on ebcdic platforms
   8         print "1..0 # Skip utf8 tests on ebcdic platform.\n";
   9         exit;
  10     }
  11 }
  12
  13 print "1..103\n";
  14
  15 my $test = 1;
  16
  17 sub ok {
  18     my ($got,$expect) = @_;
  19     print "# expected [$expect], got [$got]\nnot " if $got ne $expect;
  20     print "ok $test\n";
  21 }
  22
  23 sub nok {
  24     my ($got,$expect) = @_;
  25     print "# expected not [$expect], got [$got]\nnot " if $got eq $expect;
  26     print "ok $test\n";
  27 }
  28
  29 sub ok_bytes {
  30     use bytes;
  31     my ($got,$expect) = @_;
  32     print "# expected [$expect], got [$got]\nnot " if $got ne $expect;
  33     print "ok $test\n";
  34 }
  35
  36 sub nok_bytes {
  37     use bytes;
  38     my ($got,$expect) = @_;
  39     print "# expected not [$expect], got [$got]\nnot " if $got eq $expect;
  40     print "ok $test\n";
  41 }
  42
  43 {
  44     use utf8;
  45     $_ = ">\x{263A}<";
  46     s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg;
  47     ok $_, '>&#9786;<';
  48     $test++;                            # 1
  49
  50     $_ = ">\x{263A}<";
  51     my $rx = "\x{80}-\x{10ffff}";
  52     s/([$rx])/"&#".ord($1).";"/eg;
  53     ok $_, '>&#9786;<';
  54     $test++;                            # 2
  55
  56     $_ = ">\x{263A}<";
  57     my $rx = "\\x{80}-\\x{10ffff}";
  58     s/([$rx])/"&#".ord($1).";"/eg;
  59     ok $_, '>&#9786;<';
  60     $test++;                            # 3
  61
  62     $_ = "alpha,numeric";
  63     m/([[:alpha:]]+)/;
  64     ok $1, 'alpha';
  65     $test++;                            # 4
  66
  67     $_ = "alphaNUMERICstring";
  68     m/([[:^lower:]]+)/;
  69     ok $1, 'NUMERIC';
  70     $test++;                            # 5
  71
  72     $_ = "alphaNUMERICstring";
  73     m/(\p{Ll}+)/;
  74     ok $1, 'alpha';
  75     $test++;                            # 6
  76
  77     $_ = "alphaNUMERICstring";
  78     m/(\p{Lu}+)/;
  79     ok $1, 'NUMERIC';
  80     $test++;                            # 7
  81
  82     $_ = "alpha,numeric";
  83     m/([\p{IsAlpha}]+)/;
  84     ok $1, 'alpha';
  85     $test++;                            # 8
  86
  87     $_ = "alphaNUMERICstring";
  88     m/([^\p{IsLower}]+)/;
  89     ok $1, 'NUMERIC';
  90     $test++;                            # 9
  91
  92     $_ = "alpha123numeric456";
  93     m/([\p{IsDigit}]+)/;
  94     ok $1, '123';
  95     $test++;                            # 10
  96
  97     $_ = "alpha123numeric456";
  98     m/([^\p{IsDigit}]+)/;
  99     ok $1, 'alpha';
 100     $test++;                            # 11
 101
 102     $_ = ",123alpha,456numeric";
 103     m/([\p{IsAlnum}]+)/;
 104     ok $1, '123alpha';
 105     $test++;                            # 12
 106 }
 107
 108 {
 109     use utf8;
 110
 111     $_ = "\x{263A}>\x{263A}\x{263A}";
 112
 113     ok length, 4;
 114     $test++;                            # 13
 115
 116     ok length((m/>(.)/)[0]), 1;
 117     $test++;                            # 14
 118
 119     ok length($&), 2;
 120     $test++;                            # 15
 121
 122     ok length($'), 1;
 123     $test++;                            # 16
 124
 125     ok length($`), 1;
 126     $test++;                            # 17
 127
 128     ok length($1), 1;
 129     $test++;                            # 18
 130
 131     ok length($tmp=$&), 2;
 132     $test++;                            # 19
 133
 134     ok length($tmp=$'), 1;
 135     $test++;                            # 20
 136
 137     ok length($tmp=$`), 1;
 138     $test++;                            # 21
 139
 140     ok length($tmp=$1), 1;
 141     $test++;                            # 22
 142
 143     {
 144         use bytes;
 145
 146         my $tmp = $&;
 147         ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
 148         $test++;                                # 23
 149
 150         $tmp = $';
 151         ok $tmp, pack("C*", 0342, 0230, 0272);
 152         $test++;                                # 24
 153
 154         $tmp = $`;
 155         ok $tmp, pack("C*", 0342, 0230, 0272);
 156         $test++;                                # 25
 157
 158         $tmp = $1;
 159         ok $tmp, pack("C*", 0342, 0230, 0272);
 160         $test++;                                # 26
 161     }
 162
 163     ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272);
 164     $test++;                            # 27
 165
 166     ok_bytes $', pack("C*", 0342, 0230, 0272);
 167     $test++;                            # 28
 168
 169     ok_bytes $`, pack("C*", 0342, 0230, 0272);
 170     $test++;                            # 29
 171
 172     ok_bytes $1, pack("C*", 0342, 0230, 0272);
 173     $test++;                            # 30
 174
 175     {
 176         use bytes;
 177         no utf8;
 178
 179         ok length, 10;
 180         $test++;                                # 31
 181
 182         ok length((m/>(.)/)[0]), 1;
 183         $test++;                                # 32
 184
 185         ok length($&), 2;
 186         $test++;                                # 33
 187
 188         ok length($'), 5;
 189         $test++;                                # 34
 190
 191         ok length($`), 3;
 192         $test++;                                # 35
 193
 194         ok length($1), 1;
 195         $test++;                                # 36
 196
 197         ok $&, pack("C*", ord(">"), 0342);
 198         $test++;                                # 37
 199
 200         ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
 201         $test++;                                # 38
 202
 203         ok $`, pack("C*", 0342, 0230, 0272);
 204         $test++;                                # 39
 205
 206         ok $1, pack("C*", 0342);
 207         $test++;                                # 40
 208     }
 209
 210     {
 211         no utf8;
 212         $_="\342\230\272>\342\230\272\342\230\272";
 213     }
 214
 215     ok length, 10;
 216     $test++;                            # 41
 217
 218     ok length((m/>(.)/)[0]), 1;
 219     $test++;                            # 42
 220
 221     ok length($&), 2;
 222     $test++;                            # 43
 223
 224     ok length($'), 1;
 225     $test++;                            # 44
 226
 227     ok length($`), 1;
 228     $test++;                            # 45
 229
 230     ok length($1), 1;
 231     $test++;                            # 46
 232
 233     ok length($tmp=$&), 2;
 234     $test++;                            # 47
 235
 236     ok length($tmp=$'), 1;
 237     $test++;                            # 48
 238
 239     ok length($tmp=$`), 1;
 240     $test++;                            # 49
 241
 242     ok length($tmp=$1), 1;
 243     $test++;                            # 50
 244
 245     {
 246         use bytes;
 247
 248         my $tmp = $&;
 249         ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
 250         $test++;                                # 51
 251
 252         $tmp = $';
 253         ok $tmp, pack("C*", 0342, 0230, 0272);
 254         $test++;                                # 52
 255
 256         $tmp = $`;
 257         ok $tmp, pack("C*", 0342, 0230, 0272);
 258         $test++;                                # 53
 259
 260         $tmp = $1;
 261         ok $tmp, pack("C*", 0342, 0230, 0272);
 262         $test++;                                # 54
 263     }
 264
 265     {
 266         use bytes;
 267         no utf8;
 268
 269         ok length, 10;
 270         $test++;                                # 55
 271
 272         ok length((m/>(.)/)[0]), 1;
 273         $test++;                                # 56
 274
 275         ok length($&), 2;
 276         $test++;                                # 57
 277
 278         ok length($'), 5;
 279         $test++;                                # 58
 280
 281         ok length($`), 3;
 282         $test++;                                # 59
 283
 284         ok length($1), 1;
 285         $test++;                                # 60
 286
 287         ok $&, pack("C*", ord(">"), 0342);
 288         $test++;                                # 61
 289
 290         ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
 291         $test++;                                # 62
 292
 293         ok $`, pack("C*", 0342, 0230, 0272);
 294         $test++;                                # 63
 295
 296         ok $1, pack("C*", 0342);
 297         $test++;                                # 64
 298     }
 299
 300     ok "\x{ab}" =~ /^\x{ab}$/, 1;
 301     $test++;                                    # 65
 302 }
 303
 304 {
 305     use utf8;
 306     ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2);
 307     $test++;                # 66
 308 }
 309
 310 {
 311     use utf8;
 312     my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
 313     ok "@a", "1234 123 2345";
 314     $test++;                # 67
 315 }
 316
 317 {
 318     use utf8;
 319     my $x = chr(123);
 320     my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345)));
 321     ok "@a", "1234 2345";
 322     $test++;                # 68
 323 }
 324
 325 {
 326     # bug id 20001009.001
 327
 328     my ($a, $b);
 329
 330     { use bytes; $a = "\xc3\xa4" }
 331     { use utf8;  $b = "\xe4"     } # \xXX must not produce UTF-8
 332
 333     print "not " if $a eq $b;
 334     print "ok $test\n"; $test++;
 335
 336     { use utf8; print "not " if $a eq $b; }
 337     print "ok $test\n"; $test++;
 338 }
 339
 340 {
 341     # bug id 20001008.001
 342
 343     my @x = ("stra\337e 138","stra\337e 138");
 344     for (@x) {
 345         s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
 346         my($latin) = /^(.+)(?:\s+\d)/;
 347         print $latin eq "stra\337e" ? "ok $test\n" :
 348             "#latin[$latin]\nnot ok $test\n";
 349         $test++;
 350         $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
 351         use utf8;
 352         $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
 353     }
 354 }
 355
 356 {
 357     # bug id 20000819.004
 358
 359     $_ = $dx = "\x{10f2}";
 360     s/($dx)/$dx$1/;
 361     {
 362         use bytes;
 363         print "not " unless $_ eq "$dx$dx";
 364         print "ok $test\n";
 365         $test++;
 366     }
 367
 368     $_ = $dx = "\x{10f2}";
 369     s/($dx)/$1$dx/;
 370     {
 371         use bytes;
 372         print "not " unless $_ eq "$dx$dx";
 373         print "ok $test\n";
 374         $test++;
 375     }
 376
 377     $dx = "\x{10f2}";
 378     $_  = "\x{10f2}\x{10f2}";
 379     s/($dx)($dx)/$1$2/;
 380     {
 381         use bytes;
 382         print "not " unless $_ eq "$dx$dx";
 383         print "ok $test\n";
 384         $test++;
 385     }
 386 }
 387
 388 {
 389     # bug id 20000323.056
 390
 391     print "not " unless "\x{41}" eq +v65;
 392     print "ok $test\n";
 393     $test++;
 394
 395     print "not " unless "\x41" eq +v65;
 396     print "ok $test\n";
 397     $test++;
 398
 399     print "not " unless "\x{c8}" eq +v200;
 400     print "ok $test\n";
 401     $test++;
 402
 403     print "not " unless "\xc8" eq +v200;
 404     print "ok $test\n";
 405     $test++;
 406
 407     print "not " unless "\x{221b}" eq v8731;
 408     print "ok $test\n";
 409     $test++;
 410 }
 411
 412 {
 413     # bug id 20000427.003
 414
 415     use utf8;
 416     use warnings;
 417     use strict;
 418
 419     my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}";
 420
 421     my @charlist = split //, $sushi;
 422     my $r = '';
 423     foreach my $ch (@charlist) {
 424         $r = $r . " " . sprintf "U+%04X", ord($ch);
 425     }
 426
 427     print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B";
 428     print "ok $test\n";
 429     $test++;
 430 }
 431
 432 {
 433     # bug id 20000901.092
 434     # test that undef left and right of utf8 results in a valid string
 435
 436     my $a;
 437     $a .= "\x{1ff}";
 438     print "not " unless $a eq "\x{1ff}";
 439     print "ok $test\n";
 440     $test++;
 441 }
 442
 443 {
 444     # bug id 20000426.003
 445
 446     use utf8;
 447
 448     my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";
 449
 450     my ($a, $b, $c) = split(/\x40/, $s);
 451     print "not "
 452         unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a;
 453     print "ok $test\n";
 454     $test++;
 455
 456     my ($a, $b) = split(/\x{100}/, $s);
 457     print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20";
 458     print "ok $test\n";
 459     $test++;
 460
 461     my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
 462     print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20";
 463     print "ok $test\n";
 464     $test++;
 465
 466     my ($a, $b) = split(/\x40\x{80}/, $s);
 467     print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20";
 468     print "ok $test\n";
 469     $test++;
 470
 471     my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
 472     print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20";
 473     print "ok $test\n";
 474     $test++;
 475 }
 476
 477 {
 478     # bug id 20000730.004
 479
 480     use utf8;
 481
 482     my $smiley = "\x{263a}";
 483
 484     for my $s ("\x{263a}",                     #  1
 485                $smiley,                        #  2
 486
 487                "" . $smiley,                   #  3
 488                "" . "\x{263a}",                #  4
 489
 490                $smiley    . "",                #  5
 491                "\x{263a}" . "",                #  6
 492                ) {
 493         my $length_chars = length($s);
 494         my $length_bytes;
 495         { use bytes; $length_bytes = length($s) }
 496         my @regex_chars = $s =~ m/(.)/g;
 497         my $regex_chars = @regex_chars;
 498         my @split_chars = split //, $s;
 499         my $split_chars = @split_chars;
 500         print "not "
 501             unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq
 502                    "1/1/1/3";
 503         print "ok $test\n";
 504         $test++;
 505     }
 506
 507     for my $s ("\x{263a}" . "\x{263a}",        #  7
 508                $smiley    . $smiley,           #  8
 509
 510                "\x{263a}\x{263a}",             #  9
 511                "$smiley$smiley",               # 10
 512
 513                "\x{263a}" x 2,                 # 11
 514                $smiley    x 2,                 # 12
 515                ) {
 516         my $length_chars = length($s);
 517         my $length_bytes;
 518         { use bytes; $length_bytes = length($s) }
 519         my @regex_chars = $s =~ m/(.)/g;
 520         my $regex_chars = @regex_chars;
 521         my @split_chars = split //, $s;
 522         my $split_chars = @split_chars;
 523         print "not "
 524             unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq
 525                    "2/2/2/6";
 526         print "ok $test\n";
 527         $test++;
 528     }
 529 }
 530
 531 {
 532     # ID 20001020.006
 533
 534     "x" =~ /(.)/; # unset $2
 535
 536     # Without the fix this will croak:
 537     # Modification of a read-only value attempted at ...
 538     "$2\x{1234}";
 539
 540     print "ok $test\n";
 541     $test++;
 542
 543     # For symmetry with the above.
 544     "\x{1234}$2";
 545
 546     print "ok $test\n";
 547     $test++;
 548
 549     *pi = \undef;
 550     # This bug existed earlier than the $2 bug, but is fixed with the same
 551     # patch. Without the fix this will also croak:
 552     # Modification of a read-only value attempted at ...
 553     "$pi\x{1234}";
 554
 555     print "ok $test\n";
 556     $test++;
 557
 558     # For symmetry with the above.
 559     "\x{1234}$pi";
 560
 561     print "ok $test\n";
 562     $test++;
 563 }