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