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..69\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 # wrong type of alias (missing colon)
 332 use charnames "alias";
 333 "Here: \N{e_ACUTE}!\n";
 334 EXPECT
 335 Unknown charname 'e_ACUTE' at
 336 ########
 337 # alias without an argument
 338 use charnames ":alias";
 339 "Here: \N{e_ACUTE}!\n";
 340 EXPECT
 341 Unknown charname 'e_ACUTE' at
 342 ########
 343 # alias with hashref but no :full
 344 use charnames ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
 345 "Here: \N{e_ACUTE}!\n";
 346 EXPECT
 347 Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
 348 ########
 349 # alias with hashref but with :short
 350 use charnames ":short", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
 351 "Here: \N{e_ACUTE}!\n";
 352 EXPECT
 353 Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
 354 ########
 355 # alias with hashref to :full OK
 356 use charnames ":full", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
 357 "Here: \N{e_ACUTE}!\n";
 358 EXPECT
 359 $
 360 ########
 361 # alias with hashref to :short but using :full
 362 use charnames ":full", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
 363 "Here: \N{e_ACUTE}!\n";
 364 EXPECT
 365 Unknown charname 'LATIN:e WITH ACUTE' at
 366 ########
 367 # alias with hashref to :short OK
 368 use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
 369 "Here: \N{e_ACUTE}!\n";
 370 EXPECT
 371 $
 372 ########
 373 # alias with bad hashref
 374 use charnames ":short", ":alias" => "e_ACUTE";
 375 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 376 EXPECT
 377 Odd number of elements in anonymous hash at
 378 ########
 379 # alias with arrayref
 380 use charnames ":short", ":alias" => [ e_ACUTE => "LATIN:e WITH ACUTE" ];
 381 "Here: \N{e_ACUTE}!\n";
 382 EXPECT
 383 Only HASH reference supported as argument to :alias at
 384 ########
 385 # alias with bad hashref
 386 use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE", "a_ACUTE" };
 387 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 388 EXPECT
 389 Use of uninitialized value in string eq at
 390 ########
 391 # alias with hashref two aliases
 392 use charnames ":short", ":alias" => {
 393     e_ACUTE => "LATIN:e WITH ACUTE",
 394     a_ACUTE => "",
 395     };
 396 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 397 EXPECT
 398 Unknown charname '' at
 399 ########
 400 # alias with hashref two aliases
 401 use charnames ":short", ":alias" => {
 402     e_ACUTE => "LATIN:e WITH ACUTE",
 403     a_ACUTE => "LATIN:a WITH ACUTE",
 404     };
 405 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 406 EXPECT
 407 $
 408 ########
 409 # alias with hashref using mixed aliasses
 410 use charnames ":short", ":alias" => {
 411     e_ACUTE => "LATIN:e WITH ACUTE",
 412     a_ACUTE => "LATIN SMALL LETTER A WITH ACUT",
 413     };
 414 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 415 EXPECT
 416 Unknown charname 'LATIN SMALL LETTER A WITH ACUT' at
 417 ########
 418 # alias with hashref using mixed aliasses
 419 use charnames ":short", ":alias" => {
 420     e_ACUTE => "LATIN:e WITH ACUTE",
 421     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 422     };
 423 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 424 EXPECT
 425 Unknown charname 'LATIN SMALL LETTER A WITH ACUTE' at
 426 ########
 427 # alias with hashref using mixed aliasses
 428 use charnames ":full", ":alias" => {
 429     e_ACUTE => "LATIN:e WITH ACUTE",
 430     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 431     };
 432 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 433 EXPECT
 434 Unknown charname 'LATIN:e WITH ACUTE' at
 435 ########
 436 # alias with nonexisting file
 437 use charnames ":full", ":alias" => "xyzzy";
 438 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 439 EXPECT
 440 Odd number of elements in anonymous hash at
 441 ########
 442 # alias with bad file
 443 use charnames ":full", ":alias" => "xyzzy";
 444 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 445 FILE
 446 #!perl
 447 0;
 448 EXPECT
 449 Odd number of elements in anonymous hash at
 450 ########
 451 # alias with file with empty list
 452 use charnames ":full", ":alias" => "xyzzy";
 453 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 454 FILE
 455 #!perl
 456 ();
 457 EXPECT
 458 Unknown charname 'e_ACUTE' at
 459 ########
 460 # alias with file OK but file has :short aliasses
 461 use charnames ":full", ":alias" => "xyzzy";
 462 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 463 FILE
 464 #!perl
 465 (   e_ACUTE => "LATIN:e WITH ACUTE",
 466     a_ACUTE => "LATIN:a WITH ACUTE",
 467     );
 468 EXPECT
 469 Unknown charname 'LATIN:e WITH ACUTE' at
 470 ########
 471 # alias with :short and file OK
 472 use charnames ":short", ":alias" => "xyzzy";
 473 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 474 FILE
 475 #!perl
 476 (   e_ACUTE => "LATIN:e WITH ACUTE",
 477     a_ACUTE => "LATIN:a WITH ACUTE",
 478     );
 479 EXPECT
 480 $
 481 ########
 482 # alias with :short and file OK has :long aliasses
 483 use charnames ":short", ":alias" => "xyzzy";
 484 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 485 FILE
 486 #!perl
 487 (   e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
 488     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 489     );
 490 EXPECT
 491 Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
 492 ########
 493 # alias with file implicit :full but file has :short aliasses
 494 use charnames ":alias" => ":xyzzy";
 495 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 496 FILE
 497 #!perl
 498 (   e_ACUTE => "LATIN:e WITH ACUTE",
 499     a_ACUTE => "LATIN:a WITH ACUTE",
 500     );
 501 EXPECT
 502 Unknown charname 'LATIN:e WITH ACUTE' at
 503 ########
 504 # alias with file implicit :full and file has :long aliasses
 505 use charnames ":alias" => ":xyzzy";
 506 "Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
 507 FILE
 508 #!perl
 509 (   e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
 510     a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
 511     );
 512 EXPECT
 513 $