For tied file handle calls, use PUSH* when we know that the stack has space.
[p5sagit/p5-mst-13.2.git] / lib / charnames.t
CommitLineData
423cee85 1#!./perl
2
52ea3e69 3my @WARN;
4
423cee85 5BEGIN {
6 unless(grep /blib/, @INC) {
7 chdir 't' if -d 't';
20822f61 8 @INC = '../lib';
143a3e5e 9 require './test.pl';
423cee85 10 }
52ea3e69 11 $SIG{__WARN__} = sub { push @WARN, @_ };
423cee85 12}
13
63c6dcc1 14require File::Spec;
15
423cee85 16$| = 1;
822ebcc8 17
e10d7780 18print "1..81\n";
423cee85 19
20use charnames ':full';
21
93979888 22print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here!?";
423cee85 23print "ok 1\n";
24
c82a54e6 25{
5d9a6404 26 use bytes; # TEST -utf8 can switch utf8 on
c82a54e6 27
28 print "# \$res=$res \$\@='$@'\nnot "
29 if $res = eval <<'EOE'
423cee85 30use charnames ":full";
4a2d328f 31"Here: \N{CYRILLIC SMALL LETTER BE}!";
423cee85 321
33EOE
c82a54e6 34 or $@ !~ /above 0xFF/;
35 print "ok 2\n";
36 # print "# \$res=$res \$\@='$@'\n";
423cee85 37
c82a54e6 38 print "# \$res=$res \$\@='$@'\nnot "
39 if $res = eval <<'EOE'
423cee85 40use charnames 'cyrillic';
4a2d328f 41"Here: \N{Be}!";
423cee85 421
43EOE
c82a54e6 44 or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/;
45 print "ok 3\n";
46}
423cee85 47
48# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt
210db7fc 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}
c5cc3500 62
63sub to_bytes {
f337b084 64 unpack"U0a*", shift;
c5cc3500 65}
66
423cee85 67{
68 use charnames ':full';
423cee85 69
c5cc3500 70 print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be;
423cee85 71 print "ok 4\n";
72
73 use charnames qw(cyrillic greek :short);
74
c5cc3500 75 print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}")
423cee85 76 eq "$encoded_be,$encoded_alpha,$encoded_bet";
77 print "ok 5\n";
78}
e1992b6d 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";
f08d6ad9 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";
e1992b6d 96}
c00525d4 97
98{
99 use charnames qw(:full);
55eda711 100 use utf8;
51cf30b6 101
c00525d4 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
f9a63242 109{
110 use charnames qw(:full);
55eda711 111 use utf8;
f9a63242 112 print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
113 print "ok 14\n";
114}
115
b896c7a5 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";
4765795a 122}
b896c7a5 123
4765795a 124{
51cf30b6 125 # 20001114.001
4765795a 126
4c53e876 127 no utf8; # naked Latin-1
3ba0e062 128
4765795a 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 }
b896c7a5 137}
138
daf0d493 139{
140 print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
141 print "ok 17\n";
142
a23c04e4 143 # Unused Hebrew.
11881cb4 144 print "not " if defined charnames::viacode(0x0590);
daf0d493 145 print "ok 18\n";
146}
147
148{
149 print "not " unless
51b0dbc4 150 sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
daf0d493 151 print "ok 19\n";
152
153 print "not " if
154 defined charnames::vianame("NONE SUCH");
155 print "ok 20\n";
156}
4e2cda5d 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
51b0dbc4 165 sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
4e2cda5d 166 print "ok 22\n";
167
168}
301a3cda 169
822ebcc8 170print "not " unless "\N{CHARACTER TABULATION}" eq "\t";
301a3cda 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
7b903762 179print "not " unless "\N{LINE FEED (LF)}" eq "\n";
180print "ok 26\n";
eb380778 181
7b903762 182print "not " unless "\N{LINE FEED}" eq "\n";
183print "ok 27\n";
52ea3e69 184
7b903762 185print "not " unless "\N{LF}" eq "\n";
186print "ok 28\n";
52ea3e69 187
a2e77dd4 188my $nel = ord("A") == 193 ? qr/^(?:\x15|\x25)$/ : qr/^\x85$/;
189
190print "not " unless "\N{NEXT LINE (NEL)}" =~ $nel;
52ea3e69 191print "ok 29\n";
192
a2e77dd4 193print "not " unless "\N{NEXT LINE}" =~ $nel;
52ea3e69 194print "ok 30\n";
195
a2e77dd4 196print "not " unless "\N{NEL}" =~ $nel;
51e9e896 197print "ok 31\n";
198
274085e3 199print "not " unless "\N{BYTE ORDER MARK}" eq chr(0xFEFF);
51e9e896 200print "ok 32\n";
201
d7d589a8 202print "not " unless "\N{BOM}" eq chr(0xFEFF);
51e9e896 203print "ok 33\n";
204
52ea3e69 205{
206 use warnings 'deprecated';
207
208 print "not " unless "\N{HORIZONTAL TABULATION}" eq "\t";
51e9e896 209 print "ok 34\n";
52ea3e69 210
211 print "not " unless grep { /"HORIZONTAL TABULATION" is deprecated/ } @WARN;
51e9e896 212 print "ok 35\n";
822ebcc8 213
52ea3e69 214 no warnings 'deprecated';
215
216 print "not " unless "\N{VERTICAL TABULATION}" eq "\013";
51e9e896 217 print "ok 36\n";
52ea3e69 218
219 print "not " if grep { /"VERTICAL TABULATION" is deprecated/ } @WARN;
51e9e896 220 print "ok 37\n";
52ea3e69 221}
822ebcc8 222
274085e3 223print "not " unless charnames::viacode(0xFEFF) eq "ZERO WIDTH NO-BREAK SPACE";
a23c04e4 224print "ok 38\n";
225
872c91ae 226{
227 use warnings;
228 print "not " unless ord("\N{BOM}") == 0xFEFF;
229 print "ok 39\n";
230}
231
24b5d5cc 232print "not " unless ord("\N{ZWNJ}") == 0x200C;
233print "ok 40\n";
234
235print "not " unless ord("\N{ZWJ}") == 0x200D;
236print "ok 41\n";
dbc0d4f2 237
238print "not " unless "\N{U+263A}" eq "\N{WHITE SMILING FACE}";
239print "ok 42\n";
240
51b0dbc4 241{
242 print "not " unless
243 0x3093 == charnames::vianame("HIRAGANA LETTER N");
244 print "ok 43\n";
245
246 print "not " unless
247 0x0397 == charnames::vianame("GREEK CAPITAL LETTER ETA");
248 print "ok 44\n";
249}
250
00d835f2 251print "not " if defined charnames::viacode(0x110000);
51b0dbc4 252print "ok 45\n";
00d835f2 253
254print "not " if grep { /you asked for U+110000/ } @WARN;
51b0dbc4 255print "ok 46\n";
35c0985d 256
e10d7780 257print "not " unless "NULL" eq charnames::viacode(0);
258print "ok 47\n";
259
35c0985d 260
261# ---- Alias extensions
262
63c6dcc1 263my $alifile = File::Spec->catfile(File::Spec->updir, qw(lib unicore xyzzy_alias.pl));
35c0985d 264my $i = 0;
35c0985d 265
266my @prgs;
267{ local $/ = undef;
268 @prgs = split "\n########\n", <DATA>;
269 }
270
e10d7780 271my $i = 47;
35c0985d 272for (@prgs) {
273 my ($code, $exp) = ((split m/\nEXPECT\n/), '$');
274 my ($prog, $fil) = ((split m/\nFILE\n/, $code), "");
f89542f7 275 my $tmpfile = tempfile();
35c0985d 276 open my $tmp, "> $tmpfile" or die "Could not open $tmpfile: $!";
277 print $tmp $prog, "\n";
278 close $tmp or die "Could not close $tmpfile: $!";
279 if ($fil) {
280 $fil .= "\n";
281 open my $ali, "> $alifile" or die "Could not open $alifile: $!";
282 print $ali $fil;
283 close $ali or die "Could not close $alifile: $!";
284 }
143a3e5e 285 my $res = runperl( switches => $switch,
286 progfile => $tmpfile,
287 stderr => 1 );
35c0985d 288 my $status = $?;
289 $res =~ s/[\r\n]+$//;
290 $res =~ s/tmp\d+/-/g; # fake $prog from STDIN
291 $res =~ s/\n%[A-Z]+-[SIWEF]-.*$// # clip off DCL status msg
292 if $^O eq "VMS";
293 $exp =~ s/[\r\n]+$//;
35c0985d 294 my $pfx = ($res =~ s/^PREFIX\n//);
295 my $rexp = qr{^$exp};
296 if ($res =~ s/^SKIPPED\n//) {
297 print "$results\n";
298 }
299 elsif (($pfx and $res !~ /^\Q$expected/) or
300 (!$pfx and $res !~ $rexp)) {
301 print STDERR
302 "PROG:\n$prog\n",
303 "FILE:\n$fil",
304 "EXPECTED:\n$exp\n",
305 "GOT:\n$res\n";
306 print "not ";
307 }
308 print "ok ", ++$i, "\n";
35c0985d 309 $fil or next;
310 1 while unlink $alifile;
311 }
312
e5c3f898 313# [perl #30409] charnames.pm clobbers default variable
314$_ = 'foobar';
315eval "use charnames ':full';";
316print "not " unless $_ eq 'foobar';
e10d7780 317print "ok 75\n";
e5c3f898 318
c776535e 319# Unicode slowdown noted by Phil Pennock, traced to a bug fix in index
320# SADAHIRO Tomoyuki's suggestion is to ensure that the UTF-8ness of both
321# arguments are indentical before calling index.
322# To do this can take advantage of the fact that unicore/Name.pl is 7 bit
323# (or at least should be). So assert that that it's true here.
324
325my $names = do "unicore/Name.pl";
e10d7780 326print defined $names ? "ok 76\n" : "not ok 76\n";
c776535e 327if (ord('A') == 65) { # as on ASCII or UTF-8 machines
328 my $non_ascii = $names =~ tr/\0-\177//c;
e10d7780 329 print $non_ascii ? "not ok 77 # $non_ascii\n" : "ok 77\n";
c776535e 330} else {
e10d7780 331 print "ok 77\n";
c776535e 332}
333
eb915052 334# Verify that charnames propagate to eval("")
335my $evaltry = eval q[ "Eval: \N{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}" ];
336if ($@) {
e10d7780 337 print "# $@not ok 78\nnot ok 79\n";
eb915052 338} else {
eb915052 339 print "ok 78\n";
e10d7780 340 print "not " unless $evaltry eq "Eval: \N{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}";
341 print "ok 79\n";
eb915052 342}
c776535e 343
ae6979a8 344# Verify that db includes the normative NameAliases.txt names
345print "not " unless "\N{U+1D0C5}" eq "\N{BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS}";
e10d7780 346print "ok 80\n";
ae6979a8 347
ec34a119 348# [perl #73174] use of \N{FOO} used to reset %^H
349
350{
351 use charnames ":full";
352 my $res;
353 BEGIN { $^H{73174} = "foo" }
354 BEGIN { $res = ($^H{73174} // "") }
355 # forces loading of utf8.pm, which used to reset %^H
356 $res .= '-1' if ":" =~ /\N{COLON}/i;
357 BEGIN { $res .= '-' . ($^H{73174} // "") }
358 $res .= '-' . ($^H{73174} // "");
359 $res .= '-2' if ":" =~ /\N{COLON}/;
360 $res .= '-3' if ":" =~ /\N{COLON}/i;
361 print $res eq "foo-foo-1--2-3" ? "" : "not ",
e10d7780 362 "ok 81 - \$^H{foo} correct after /\\N{bar}/i (res=$res)\n";
ec34a119 363}
364
35c0985d 365__END__
51cf30b6 366# unsupported pragma
367use charnames ":scoobydoo";
368"Here: \N{e_ACUTE}!\n";
369EXPECT
370unsupported special ':scoobydoo' in charnames at
371########
35c0985d 372# wrong type of alias (missing colon)
373use charnames "alias";
374"Here: \N{e_ACUTE}!\n";
375EXPECT
51cf30b6 376Unknown charname 'e_ACUTE' at
35c0985d 377########
378# alias without an argument
379use charnames ":alias";
380"Here: \N{e_ACUTE}!\n";
381EXPECT
51cf30b6 382:alias needs an argument in charnames at
383########
384# reversed sequence
385use charnames ":alias" => ":full";
386"Here: \N{e_ACUTE}!\n";
387EXPECT
388:alias cannot use existing pragma :full \(reversed order\?\) at
35c0985d 389########
390# alias with hashref but no :full
391use charnames ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
392"Here: \N{e_ACUTE}!\n";
393EXPECT
394Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
395########
396# alias with hashref but with :short
397use charnames ":short", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
398"Here: \N{e_ACUTE}!\n";
399EXPECT
400Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
401########
402# alias with hashref to :full OK
403use charnames ":full", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
404"Here: \N{e_ACUTE}!\n";
405EXPECT
406$
407########
408# alias with hashref to :short but using :full
409use charnames ":full", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
410"Here: \N{e_ACUTE}!\n";
411EXPECT
412Unknown charname 'LATIN:e WITH ACUTE' at
413########
414# alias with hashref to :short OK
415use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
416"Here: \N{e_ACUTE}!\n";
417EXPECT
418$
419########
420# alias with bad hashref
421use charnames ":short", ":alias" => "e_ACUTE";
422"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
423EXPECT
51cf30b6 424unicore/e_ACUTE_alias.pl cannot be used as alias file for charnames at
35c0985d 425########
426# alias with arrayref
427use charnames ":short", ":alias" => [ e_ACUTE => "LATIN:e WITH ACUTE" ];
428"Here: \N{e_ACUTE}!\n";
429EXPECT
430Only HASH reference supported as argument to :alias at
431########
432# alias with bad hashref
433use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE", "a_ACUTE" };
434"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
435EXPECT
29489e7c 436Use of uninitialized value
35c0985d 437########
438# alias with hashref two aliases
439use charnames ":short", ":alias" => {
440 e_ACUTE => "LATIN:e WITH ACUTE",
441 a_ACUTE => "",
442 };
443"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
444EXPECT
445Unknown charname '' at
446########
447# alias with hashref two aliases
448use charnames ":short", ":alias" => {
449 e_ACUTE => "LATIN:e WITH ACUTE",
450 a_ACUTE => "LATIN:a WITH ACUTE",
451 };
452"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
453EXPECT
454$
455########
456# alias with hashref using mixed aliasses
457use charnames ":short", ":alias" => {
458 e_ACUTE => "LATIN:e WITH ACUTE",
459 a_ACUTE => "LATIN SMALL LETTER A WITH ACUT",
460 };
461"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
462EXPECT
463Unknown charname 'LATIN SMALL LETTER A WITH ACUT' at
464########
465# alias with hashref using mixed aliasses
466use charnames ":short", ":alias" => {
467 e_ACUTE => "LATIN:e WITH ACUTE",
468 a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
469 };
470"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
471EXPECT
472Unknown charname 'LATIN SMALL LETTER A WITH ACUTE' at
473########
474# alias with hashref using mixed aliasses
475use charnames ":full", ":alias" => {
476 e_ACUTE => "LATIN:e WITH ACUTE",
477 a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
478 };
479"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
480EXPECT
481Unknown charname 'LATIN:e WITH ACUTE' at
482########
483# alias with nonexisting file
484use charnames ":full", ":alias" => "xyzzy";
485"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
486EXPECT
51cf30b6 487unicore/xyzzy_alias.pl cannot be used as alias file for charnames at
488########
489# alias with bad file name
490use charnames ":full", ":alias" => "xy 7-";
491"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
492EXPECT
493Charnames alias files can only have identifier characters at
494########
495# alias with non_absolute (existing) file name (which it should /not/ use)
496use charnames ":full", ":alias" => "perl";
497"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
498EXPECT
499unicore/perl_alias.pl cannot be used as alias file for charnames at
35c0985d 500########
501# alias with bad file
502use charnames ":full", ":alias" => "xyzzy";
503"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
504FILE
505#!perl
5060;
507EXPECT
51cf30b6 508unicore/xyzzy_alias.pl did not return a \(valid\) list of alias pairs at
35c0985d 509########
510# alias with file with empty list
511use charnames ":full", ":alias" => "xyzzy";
512"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
513FILE
514#!perl
515();
516EXPECT
517Unknown charname 'e_ACUTE' at
518########
519# alias with file OK but file has :short aliasses
520use charnames ":full", ":alias" => "xyzzy";
521"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
522FILE
523#!perl
524( e_ACUTE => "LATIN:e WITH ACUTE",
525 a_ACUTE => "LATIN:a WITH ACUTE",
526 );
527EXPECT
528Unknown charname 'LATIN:e WITH ACUTE' at
529########
530# alias with :short and file OK
531use charnames ":short", ":alias" => "xyzzy";
532"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
533FILE
534#!perl
535( e_ACUTE => "LATIN:e WITH ACUTE",
536 a_ACUTE => "LATIN:a WITH ACUTE",
537 );
538EXPECT
539$
540########
541# alias with :short and file OK has :long aliasses
542use charnames ":short", ":alias" => "xyzzy";
543"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
544FILE
545#!perl
546( e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
547 a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
548 );
549EXPECT
550Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
551########
552# alias with file implicit :full but file has :short aliasses
553use charnames ":alias" => ":xyzzy";
554"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
555FILE
556#!perl
557( e_ACUTE => "LATIN:e WITH ACUTE",
558 a_ACUTE => "LATIN:a WITH ACUTE",
559 );
560EXPECT
561Unknown charname 'LATIN:e WITH ACUTE' at
562########
563# alias with file implicit :full and file has :long aliasses
564use charnames ":alias" => ":xyzzy";
565"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
566FILE
567#!perl
568( e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
569 a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
570 );
571EXPECT
572$