lib/charnames.t

   1 #!./perl
   2
   3 my @WARN;
   4
   5 BEGIN {
   6     unless(grep /blib/, @INC) {
   7         chdir 't' if -d 't';
   8         @INC = '../lib';
   9     }
  10     $SIG{__WARN__} = sub { push @WARN, @_ };
  11 }
  12
  13 $| = 1;
  14
  15 print "1..73\n";
  16
  17 use charnames ':full';
  18
  19 print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here!?";
  20 print "ok 1\n";
  21
  22 {
  23   use bytes;                    # TEST -utf8 can switch utf8 on
  24
  25   print "# \$res=$res \$\@='$@'\nnot "
  26     if $res = eval <<'EOE'
  27 use charnames ":full";
  28 "Here: \N{CYRILLIC SMALL LETTER BE}!";
  29 1
  30 EOE
  31       or $@ !~ /above 0xFF/;
  32   print "ok 2\n";
  33   # print "# \$res=$res \$\@='$@'\n";
  34
  35   print "# \$res=$res \$\@='$@'\nnot "
  36     if $res = eval <<'EOE'
  37 use charnames 'cyrillic';
  38 "Here: \N{Be}!";
  39 1
  40 EOE
  41       or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/;
  42   print "ok 3\n";
  43 }
  44
  45 # If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt
  46 if (ord('A') == 65) { # as on ASCII or UTF-8 machines
  47     $encoded_be = "\320\261";
  48     $encoded_alpha = "\316\261";
  49     $encoded_bet = "\327\221";
  50     $encoded_deseng = "\360\220\221\215";
  51 }
  52 else { # EBCDIC where UTF-EBCDIC may be used (this may be 1047 specific since
  53        # UTF-EBCDIC is codepage specific)
  54     $encoded_be = "\270\102\130";
  55     $encoded_alpha = "\264\130";
  56     $encoded_bet = "\270\125\130";
  57     $encoded_deseng = "\336\102\103\124";
  58 }
  59
  60 sub to_bytes {
  61     pack"a*", shift;
  62 }
  63
  64 {
  65   use charnames ':full';
  66
  67   print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be;
  68   print "ok 4\n";
  69
  70   use charnames qw(cyrillic greek :short);
  71
  72   print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}")
  73     eq "$encoded_be,$encoded_alpha,$encoded_bet";
  74   print "ok 5\n";
  75 }
  76
  77 {
  78     use charnames ':full';
  79     print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}";
  80     print "ok 6\n";
  81     print "not " unless length("\x{263a}") == 1;
  82     print "ok 7\n";
  83     print "not " unless length("\N{WHITE SMILING FACE}") == 1;
  84     print "ok 8\n";
  85     print "not " unless sprintf("%vx", "\x{263a}") eq "263a";
  86     print "ok 9\n";
  87     print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a";
  88     print "ok 10\n";
  89     print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a";
  90     print "ok 11\n";
  91     print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a";
  92     print "ok 12\n";
  93 }
  94
  95 {
  96    use charnames qw(:full);
  97    use utf8;
  98
  99     my $x = "\x{221b}";
 100     my $named = "\N{CUBE ROOT}";
 101
 102     print "not " unless ord($x) == ord($named);
 103     print "ok 13\n";
 104 }
 105
 106 {
 107    use charnames qw(:full);
 108    use utf8;
 109    print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
 110    print "ok 14\n";
 111 }
 112
 113 {
 114   use charnames ':full';
 115
 116   print "not "
 117       unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng;
 118   print "ok 15\n";
 119 }
 120
 121 {
 122   # 20001114.001
 123
 124   no utf8; # naked Latin-1
 125
 126   if (ord("Ä") == 0xc4) { # Try to do this only on Latin-1.
 127       use charnames ':full';
 128       my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
 129       print "not " unless $text eq "\xc4" && ord($text) == 0xc4;
 130       print "ok 16\n";
 131   } else {
 132       print "ok 16 # Skip: not Latin-1\n";
 133   }
 134 }
 135
 136 {
 137     print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
 138     print "ok 17\n";
 139
 140     # Unused Hebrew.
 141     print "not " if defined charnames::viacode(0x0590);
 142     print "ok 18\n";
 143 }
 144
 145 {
 146     print "not " unless
 147         sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
 148     print "ok 19\n";
 149
 150     print "not " if
 151         defined charnames::vianame("NONE SUCH");
 152     print "ok 20\n";
 153 }
 154
 155 {
 156     # check that caching at least hasn't broken anything
 157
 158     print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
 159     print "ok 21\n";
 160
 161     print "not " unless
 162         sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
 163     print "ok 22\n";
 164
 165 }
 166
 167 print "not " unless "\N{CHARACTER TABULATION}" eq "\t";
 168 print "ok 23\n";
 169
 170 print "not " unless "\N{ESCAPE}" eq "\e";
 171 print "ok 24\n";
 172
 173 print "not " unless "\N{NULL}" eq "\c@";
 174 print "ok 25\n";
 175
 176 if ($^O eq 'MacOS')
 177 {
 178         print "not " unless "\N{CARRIAGE RETURN (CR)}" eq "\n";
 179         print "ok 26\n";
 180
 181         print "not " unless "\N{CARRIAGE RETURN}" eq "\n";
 182         print "ok 27\n";
 183
 184         print "not " unless "\N{CR}" eq "\n";
 185         print "ok 28\n";
 186 }
 187 else
 188 {
 189         print "not " unless "\N{LINE FEED (LF)}" eq "\n";
 190         print "ok 26\n";
 191
 192         print "not " unless "\N{LINE FEED}" eq "\n";
 193         print "ok 27\n";
 194
 195         print "not " unless "\N{LF}" eq "\n";
 196         print "ok 28\n";
 197 }
 198
 199 my $nel = ord("A") == 193 ? qr/^(?:\x15|\x25)$/ : qr/^\x85$/;
 200
 201 print "not " unless "\N{NEXT LINE (NEL)}" =~ $nel;
 202 print "ok 29\n";
 203
 204 print "not " unless "\N{NEXT LINE}" =~ $nel;
 205 print "ok 30\n";
 206
 207 print "not " unless "\N{NEL}" =~ $nel;
 208 print "ok 31\n";
 209
 210 print "not " unless "\N{BYTE ORDER MARK}" eq chr(0xFEFF);
 211 print "ok 32\n";
 212
 213 print "not " unless "\N{BOM}" eq chr(0xFEFF);
 214 print "ok 33\n";
 215
 216 {
 217     use warnings 'deprecated';
 218
 219     print "not " unless "\N{HORIZONTAL TABULATION}" eq "\t";
 220     print "ok 34\n";
 221
 222     print "not " unless grep { /"HORIZONTAL TABULATION" is deprecated/ } @WARN;
 223     print "ok 35\n";
 224
 225     no warnings 'deprecated';
 226
 227     print "not " unless "\N{VERTICAL TABULATION}" eq "\013";
 228     print "ok 36\n";
 229
 230     print "not " if grep { /"VERTICAL TABULATION" is deprecated/ } @WARN;
 231     print "ok 37\n";
 232 }
 233
 234 print "not " unless charnames::viacode(0xFEFF) eq "ZERO WIDTH NO-BREAK SPACE";
 235 print "ok 38\n";
 236
 237 {
 238     use warnings;
 239     print "not " unless ord("\N{BOM}") == 0xFEFF;
 240     print "ok 39\n";
 241 }
 242
 243 print "not " unless ord("\N{ZWNJ}") == 0x200C;
 244 print "ok 40\n";
 245
 246 print "not " unless ord("\N{ZWJ}") == 0x200D;
 247 print "ok 41\n";
 248
 249 print "not " unless "\N{U+263A}" eq "\N{WHITE SMILING FACE}";
 250 print "ok 42\n";
 251
 252 {
 253     print "not " unless
 254         0x3093 == charnames::vianame("HIRAGANA LETTER N");
 255     print "ok 43\n";
 256
 257     print "not " unless
 258         0x0397 == charnames::vianame("GREEK CAPITAL LETTER ETA");
 259     print "ok 44\n";
 260 }
 261
 262 print "not " if defined charnames::viacode(0x110000);
 263 print "ok 45\n";
 264
 265 print "not " if grep { /you asked for U+110000/ } @WARN;
 266 print "ok 46\n";
 267
 268
 269 # ---- Alias extensions
 270
 271 my $tmpfile = "tmp0000";
 272 my $alifile = "../lib/unicore/xyzzy_alias.pl";
 273 my $i = 0;
 274 1 while -e ++$tmpfile;
 275 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
 276
 277 my @prgs;
 278 {   local $/ = undef;
 279     @prgs = split "\n########\n", <DATA>;
 280     }
 281
 282 my $i = 46;
 283 for (@prgs) {
 284     my ($code, $exp) = ((split m/\nEXPECT\n/), '$');
 285     my ($prog, $fil) = ((split m/\nFILE\n/, $code), "");
 286     open my $tmp, "> $tmpfile" or die "Could not open $tmpfile: $!";
 287     print $tmp $prog, "\n";
 288     close $tmp or die "Could not close $tmpfile: $!";
 289     if ($fil) {
 290         $fil .= "\n";
 291         open my $ali, "> $alifile" or die "Could not open $alifile: $!";
 292         print $ali $fil;
 293         close $ali or die "Could not close $alifile: $!";
 294         }
 295     my $res =
 296         $^O eq "MSWin32" ? `.\\perl -I../lib $switch $tmpfile 2>&1` :
 297         $^O eq "NetWare" ? `perl    -I../lib $switch $tmpfile 2>&1` :
 298         $^O eq "MacOS"   ? `$^X     -I::lib -MMac::err=unix $switch $tmpfile` :
 299                            `./perl -I. -I../lib $switch $tmpfile 2>&1`;
 300     my $status = $?;
 301     $res =~ s/[\r\n]+$//;
 302     $res =~ s/tmp\d+/-/g;                       # fake $prog from STDIN
 303     $res =~ s/\n%[A-Z]+-[SIWEF]-.*$//           # clip off DCL status msg
 304         if $^O eq "VMS";
 305     $exp =~ s/[\r\n]+$//;
 306     if ($^O eq "MacOS") {
 307         $exp =~ s{(\./)?abc\.pm}{:abc.pm}g;
 308         $exp =~ s{./abc}        {:abc}g;
 309         }
 310     my $pfx = ($res =~ s/^PREFIX\n//);
 311     my $rexp = qr{^$exp};
 312     if ($res =~ s/^SKIPPED\n//) {
 313         print "$results\n";
 314         }
 315     elsif (($pfx and $res !~ /^\Q$expected/) or
 316           (!$pfx and $res !~ $rexp)) {
 317         print STDERR
 318             "PROG:\n$prog\n",
 319             "FILE:\n$fil",
 320             "EXPECTED:\n$exp\n",
 321             "GOT:\n$res\n";
 322         print "not ";
 323         }
 324     print "ok ", ++$i, "\n";
 325     1 while unlink $tmpfile;
 326     $fil or next;
 327     1 while unlink $alifile;
 328     }
 329
 330 __END__
 331 # unsupported pragma
 332 use charnames ":scoobydoo";
 333 "Here: \N{e_ACUTE}!\n";
 334 EXPECT
 335 unsupported special ':scoobydoo' in charnames at
 336 ########
 337 # wrong type of alias (missing colon)
 338 use charnames "alias";
 339 "Here: \N{e_ACUTE}!\n";
 340 EXPECT
 341 Unknown charname 'e_ACUTE' at
 342 ########
 343 # alias without an argument
 344 use charnames ":alias";
 345 "Here: \N{e_ACUTE}!\n";
 346 EXPECT
 347 :alias needs an argument in charnames at
 348 ########
 349 # reversed sequence
 350 use charnames ":alias" => ":full";
 351 "Here: \N{e_ACUTE}!\n";
 352 EXPECT
 353 :alias cannot use existing pragma :full \(reversed order\?\) at
 354 ########
 355 # alias with hashref but no :full
 356 use charnames ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
 357 "Here: \N{e_ACUTE}!\n";
 358 EXPECT
 359 Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
 360 ########
 361 # alias with hashref but with :short
 362 use charnames ":short", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
 363 "Here: \N{e_ACUTE}!\n";
 364 EXPECT
 365 Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
 366 ########
 367 # alias with hashref to :full OK
 368 use charnames ":full", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
 369 "Here: \N{e_ACUTE}!\n";
 370 EXPECT
 371 $
 372 ########
 373 # alias with hashref to :short but using :full
 374 use charnames ":full", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
 375 "Here: \N{e_ACUTE}!\n";
 376 EXPECT
 377 Unknown charname 'LATIN:e WITH ACUTE' at
 378 ########
 379 # alias with hashref to :short OK
 380 use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
 381 "Here: \N{e_ACUTE}!\n";
 382 EXPECT
 383 $
 384 ########
 385 # alias with bad hashref
 386 use charnames ":short", ":alias" => "e_ACUTE";
 387 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 388 EXPECT
 389 unicore/e_ACUTE_alias.pl cannot be used as alias file for charnames at
 390 ########
 391 # alias with arrayref
 392 use charnames ":short", ":alias" => [ e_ACUTE => "LATIN:e WITH ACUTE" ];
 393 "Here: \N{e_ACUTE}!\n";
 394 EXPECT
 395 Only HASH reference supported as argument to :alias at
 396 ########
 397 # alias with bad hashref
 398 use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE", "a_ACUTE" };
 399 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 400 EXPECT
 401 Use of uninitialized value in string eq at
 402 ########
 403 # alias with hashref two aliases
 404 use charnames ":short", ":alias" => {
 405     e_ACUTE => "LATIN:e WITH ACUTE",
 406     a_ACUTE => "",
 407     };
 408 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 409 EXPECT
 410 Unknown charname '' at
 411 ########
 412 # alias with hashref two aliases
 413 use charnames ":short", ":alias" => {
 414     e_ACUTE => "LATIN:e WITH ACUTE",
 415     a_ACUTE => "LATIN:a WITH ACUTE",
 416     };
 417 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 418 EXPECT
 419 $
 420 ########
 421 # alias with hashref using mixed aliasses
 422 use charnames ":short", ":alias" => {
 423     e_ACUTE => "LATIN:e WITH ACUTE",
 424     a_ACUTE => "LATIN SMALL LETTER A WITH ACUT",
 425     };
 426 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 427 EXPECT
 428 Unknown charname 'LATIN SMALL LETTER A WITH ACUT' at
 429 ########
 430 # alias with hashref using mixed aliasses
 431 use charnames ":short", ":alias" => {
 432     e_ACUTE => "LATIN:e WITH ACUTE",
 433     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 434     };
 435 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 436 EXPECT
 437 Unknown charname 'LATIN SMALL LETTER A WITH ACUTE' at
 438 ########
 439 # alias with hashref using mixed aliasses
 440 use charnames ":full", ":alias" => {
 441     e_ACUTE => "LATIN:e WITH ACUTE",
 442     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 443     };
 444 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 445 EXPECT
 446 Unknown charname 'LATIN:e WITH ACUTE' at
 447 ########
 448 # alias with nonexisting file
 449 use charnames ":full", ":alias" => "xyzzy";
 450 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 451 EXPECT
 452 unicore/xyzzy_alias.pl cannot be used as alias file for charnames at
 453 ########
 454 # alias with bad file name
 455 use charnames ":full", ":alias" => "xy 7-";
 456 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 457 EXPECT
 458 Charnames alias files can only have identifier characters at
 459 ########
 460 # alias with non_absolute (existing) file name (which it should /not/ use)
 461 use charnames ":full", ":alias" => "perl";
 462 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 463 EXPECT
 464 unicore/perl_alias.pl cannot be used as alias file for charnames at
 465 ########
 466 # alias with bad file
 467 use charnames ":full", ":alias" => "xyzzy";
 468 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 469 FILE
 470 #!perl
 471 0;
 472 EXPECT
 473 unicore/xyzzy_alias.pl did not return a \(valid\) list of alias pairs at
 474 ########
 475 # alias with file with empty list
 476 use charnames ":full", ":alias" => "xyzzy";
 477 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 478 FILE
 479 #!perl
 480 ();
 481 EXPECT
 482 Unknown charname 'e_ACUTE' at
 483 ########
 484 # alias with file OK but file has :short aliasses
 485 use charnames ":full", ":alias" => "xyzzy";
 486 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 487 FILE
 488 #!perl
 489 (   e_ACUTE => "LATIN:e WITH ACUTE",
 490     a_ACUTE => "LATIN:a WITH ACUTE",
 491     );
 492 EXPECT
 493 Unknown charname 'LATIN:e WITH ACUTE' at
 494 ########
 495 # alias with :short and file OK
 496 use charnames ":short", ":alias" => "xyzzy";
 497 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 498 FILE
 499 #!perl
 500 (   e_ACUTE => "LATIN:e WITH ACUTE",
 501     a_ACUTE => "LATIN:a WITH ACUTE",
 502     );
 503 EXPECT
 504 $
 505 ########
 506 # alias with :short and file OK has :long aliasses
 507 use charnames ":short", ":alias" => "xyzzy";
 508 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 509 FILE
 510 #!perl
 511 (   e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
 512     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 513     );
 514 EXPECT
 515 Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
 516 ########
 517 # alias with file implicit :full but file has :short aliasses
 518 use charnames ":alias" => ":xyzzy";
 519 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 520 FILE
 521 #!perl
 522 (   e_ACUTE => "LATIN:e WITH ACUTE",
 523     a_ACUTE => "LATIN:a WITH ACUTE",
 524     );
 525 EXPECT
 526 Unknown charname 'LATIN:e WITH ACUTE' at
 527 ########
 528 # alias with file implicit :full and file has :long aliasses
 529 use charnames ":alias" => ":xyzzy";
 530 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 531 FILE
 532 #!perl
 533 (   e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
 534     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 535     );
 536 EXPECT
 537 $