lib/charnames.t

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