This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Clarify sv.c API wording.
[perl5.git] / lib / charnames.pm
CommitLineData
423cee85 1package charnames;
b177ca84
JF
2use strict;
3use warnings;
51cf30b6 4use File::Spec;
af048c18 5our $VERSION = '1.07';
b75c8c73 6
d5448623 7use bytes (); # for $bytes::hint_bits
423cee85 8
52ea3e69
JH
9my %alias1 = (
10 # Icky 3.2 names with parentheses.
11 'LINE FEED' => 'LINE FEED (LF)',
12 'FORM FEED' => 'FORM FEED (FF)',
13 'CARRIAGE RETURN' => 'CARRIAGE RETURN (CR)',
14 'NEXT LINE' => 'NEXT LINE (NEL)',
15 # Convenience.
16 'LF' => 'LINE FEED (LF)',
17 'FF' => 'FORM FEED (FF)',
eb380778 18 'CR' => 'CARRIAGE RETURN (CR)',
51e9e896 19 'NEL' => 'NEXT LINE (NEL)',
24b5d5cc
JH
20 # More convenience. For futher convencience,
21 # it is suggested some way using using the NamesList
22 # aliases is implemented.
23 'ZWNJ' => 'ZERO WIDTH NON-JOINER',
24 'ZWJ' => 'ZERO WIDTH JOINER',
52ea3e69
JH
25 'BOM' => 'BYTE ORDER MARK',
26 );
27
28my %alias2 = (
29 # Pre-3.2 compatibility (only for the first 256 characters).
30 'HORIZONTAL TABULATION' => 'CHARACTER TABULATION',
31 'VERTICAL TABULATION' => 'LINE TABULATION',
32 'FILE SEPARATOR' => 'INFORMATION SEPARATOR FOUR',
33 'GROUP SEPARATOR' => 'INFORMATION SEPARATOR THREE',
34 'RECORD SEPARATOR' => 'INFORMATION SEPARATOR TWO',
35 'UNIT SEPARATOR' => 'INFORMATION SEPARATOR ONE',
36 'PARTIAL LINE DOWN' => 'PARTIAL LINE FORWARD',
37 'PARTIAL LINE UP' => 'PARTIAL LINE BACKWARD',
38 );
39
35c0985d
MB
40my %alias3 = (
41 # User defined aliasses. Even more convenient :)
42 );
423cee85
JH
43my $txt;
44
8878f897
T
45sub croak
46{
47 require Carp; goto &Carp::croak;
48} # croak
49
50sub carp
51{
52 require Carp; goto &Carp::carp;
53} # carp
54
35c0985d
MB
55sub alias (@)
56{
57 @_ or return %alias3;
58 my $alias = ref $_[0] ? $_[0] : { @_ };
59 @alias3{keys %$alias} = values %$alias;
60} # alias
61
62sub alias_file ($)
63{
51cf30b6
MB
64 my ($arg, $file) = @_;
65 if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
66 $file = $arg;
67 }
68 elsif ($arg =~ m/^\w+$/) {
69 $file = "unicore/${arg}_alias.pl";
70 }
71 else {
72 croak "Charnames alias files can only have identifier characters";
73 }
35c0985d 74 if (my @alias = do $file) {
51cf30b6
MB
75 @alias == 1 && !defined $alias[0] and
76 croak "$file cannot be used as alias file for charnames";
77 @alias % 2 and
78 croak "$file did not return a (valid) list of alias pairs";
35c0985d
MB
79 alias (@alias);
80 return (1);
81 }
82 0;
83} # alias_file
84
423cee85 85# This is not optimized in any way yet
b177ca84
JF
86sub charnames
87{
88 my $name = shift;
89
52ea3e69 90 if (exists $alias1{$name}) {
35c0985d 91 $name = $alias1{$name};
52ea3e69 92 }
35c0985d
MB
93 elsif (exists $alias2{$name}) {
94 require warnings;
95 warnings::warnif('deprecated', qq{Unicode character name "$name" is deprecated, use "$alias2{$name}" instead});
96 $name = $alias2{$name};
97 }
98 elsif (exists $alias3{$name}) {
99 $name = $alias3{$name};
52ea3e69 100 }
b177ca84 101
52ea3e69 102 my $ord;
423cee85 103 my @off;
52ea3e69
JH
104 my $fname;
105
106 if ($name eq "BYTE ORDER MARK") {
35c0985d
MB
107 $fname = $name;
108 $ord = 0xFEFF;
52ea3e69 109 } else {
35c0985d
MB
110 ## Suck in the code/name list as a big string.
111 ## Lines look like:
112 ## "0052\t\tLATIN CAPITAL LETTER R\n"
113 $txt = do "unicore/Name.pl" unless $txt;
114
115 ## @off will hold the index into the code/name string of the start and
116 ## end of the name as we find it.
117
a6d05634 118 ## If :full, look for the name exactly
35c0985d
MB
119 if ($^H{charnames_full} and $txt =~ /\t\t\Q$name\E$/m) {
120 @off = ($-[0], $+[0]);
121 }
122
123 ## If we didn't get above, and :short allowed, look for the short name.
124 ## The short name is like "greek:Sigma"
125 unless (@off) {
126 if ($^H{charnames_short} and $name =~ /^(.+?):(.+)/s) {
127 my ($script, $cname) = ($1, $2);
128 my $case = $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
129 if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U\Q$cname\E$/m) {
52ea3e69 130 @off = ($-[0], $+[0]);
35c0985d 131 }
423cee85 132 }
35c0985d 133 }
b177ca84 134
35c0985d
MB
135 ## If we still don't have it, check for the name among the loaded
136 ## scripts.
137 if (not @off) {
138 my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
139 for my $script (@{$^H{charnames_scripts}}) {
140 if ($txt =~ m/\t\t$script (?:$case )?LETTER \U\Q$name\E$/m) {
141 @off = ($-[0], $+[0]);
142 last;
143 }
52ea3e69 144 }
35c0985d
MB
145 }
146
147 ## If we don't have it by now, give up.
148 unless (@off) {
149 carp "Unknown charname '$name'";
150 return "\x{FFFD}";
151 }
152
153 ##
154 ## Now know where in the string the name starts.
155 ## The code, in hex, is before that.
156 ##
157 ## The code can be 4-6 characters long, so we've got to sort of
158 ## go look for it, just after the newline that comes before $off[0].
159 ##
160 ## This would be much easier if unicore/Name.pl had info in
161 ## a name/code order, instead of code/name order.
162 ##
163 ## The +1 after the rindex() is to skip past the newline we're finding,
164 ## or, if the rindex() fails, to put us to an offset of zero.
165 ##
166 my $hexstart = rindex($txt, "\n", $off[0]) + 1;
167
168 ## we know where it starts, so turn into number -
169 ## the ordinal for the char.
075d4edd 170 $ord = CORE::hex substr($txt, $hexstart, $off[0] - $hexstart);
423cee85 171 }
b177ca84 172
d5448623 173 if ($^H & $bytes::hint_bits) { # "use bytes" in effect?
8058d7ab 174 use bytes;
d41ff1b8 175 return chr $ord if $ord <= 255;
f0175764 176 my $hex = sprintf "%04x", $ord;
52ea3e69 177 if (not defined $fname) {
35c0985d 178 $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
52ea3e69 179 }
f0175764 180 croak "Character 0x$hex with name '$fname' is above 0xFF";
423cee85 181 }
f0175764 182
52ea3e69 183 no warnings 'utf8'; # allow even illegal characters
bfa383d6 184 return pack "U", $ord;
35c0985d 185} # charnames
423cee85 186
b177ca84
JF
187sub import
188{
189 shift; ## ignore class name
190
35c0985d
MB
191 if (not @_) {
192 carp("`use charnames' needs explicit imports list");
b177ca84 193 }
423cee85 194 $^H{charnames} = \&charnames ;
b177ca84
JF
195
196 ##
197 ## fill %h keys with our @_ args.
198 ##
35c0985d 199 my ($promote, %h, @args) = (0);
e5c3f898
MG
200 while (my $arg = shift) {
201 if ($arg eq ":alias") {
51cf30b6
MB
202 @_ or
203 croak ":alias needs an argument in charnames";
35c0985d
MB
204 my $alias = shift;
205 if (ref $alias) {
206 ref $alias eq "HASH" or
51cf30b6 207 croak "Only HASH reference supported as argument to :alias";
35c0985d
MB
208 alias ($alias);
209 next;
210 }
51cf30b6
MB
211 if ($alias =~ m{:(\w+)$}) {
212 $1 eq "full" || $1 eq "short" and
213 croak ":alias cannot use existing pragma :$1 (reversed order?)";
214 alias_file ($1) and $promote = 1;
215 next;
35c0985d 216 }
51cf30b6
MB
217 alias_file ($alias);
218 next;
219 }
e5c3f898
MG
220 if (substr($arg, 0, 1) eq ':' and ! ($arg eq ":full" || $arg eq ":short")) {
221 warn "unsupported special '$arg' in charnames";
51cf30b6 222 next;
35c0985d 223 }
e5c3f898 224 push @args, $arg;
35c0985d
MB
225 }
226 @args == 0 && $promote and @args = (":full");
227 @h{@args} = (1) x @args;
b177ca84 228
423cee85
JH
229 $^H{charnames_full} = delete $h{':full'};
230 $^H{charnames_short} = delete $h{':short'};
231 $^H{charnames_scripts} = [map uc, keys %h];
b177ca84
JF
232
233 ##
234 ## If utf8? warnings are enabled, and some scripts were given,
235 ## see if at least we can find one letter of each script.
236 ##
35c0985d
MB
237 if (warnings::enabled('utf8') && @{$^H{charnames_scripts}}) {
238 $txt = do "unicore/Name.pl" unless $txt;
239
240 for my $script (@{$^H{charnames_scripts}}) {
241 if (not $txt =~ m/\t\t$script (?:CAPITAL |SMALL )?LETTER /) {
242 warnings::warn('utf8', "No such script: '$script'");
b177ca84 243 }
35c0985d 244 }
bd62941a 245 }
35c0985d 246} # import
423cee85 247
4e2cda5d
JH
248my %viacode;
249
b177ca84
JF
250sub viacode
251{
35c0985d
MB
252 if (@_ != 1) {
253 carp "charnames::viacode() expects one argument";
bd5c3bd9 254 return;
35c0985d 255 }
f0175764 256
35c0985d 257 my $arg = shift;
b177ca84 258
bd5c3bd9
T
259 # this comes actually from Unicode::UCD, where it is the named
260 # function _getcode (), but it avoids the overhead of loading it
35c0985d 261 my $hex;
bd5c3bd9 262 if ($arg =~ /^[1-9]\d*$/) {
35c0985d 263 $hex = sprintf "%04X", $arg;
bd5c3bd9
T
264 } elsif ($arg =~ /^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/) {
265 $hex = $1;
35c0985d
MB
266 } else {
267 carp("unexpected arg \"$arg\" to charnames::viacode()");
268 return;
269 }
b177ca84 270
bd5c3bd9
T
271 # checking the length first is slightly faster
272 if (length($hex) > 5 && hex($hex) > 0x10FFFF) {
9b5be9b5 273 carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)";
35c0985d
MB
274 return;
275 }
f0175764 276
35c0985d 277 return $viacode{$hex} if exists $viacode{$hex};
4e2cda5d 278
35c0985d 279 $txt = do "unicore/Name.pl" unless $txt;
b177ca84 280
bd5c3bd9
T
281 return unless $txt =~ m/^$hex\t\t(.+)/m;
282
283 $viacode{$hex} = $1;
35c0985d 284} # viacode
daf0d493 285
4e2cda5d
JH
286my %vianame;
287
daf0d493
JH
288sub vianame
289{
35c0985d
MB
290 if (@_ != 1) {
291 carp "charnames::vianame() expects one name argument";
292 return ()
293 }
daf0d493 294
35c0985d 295 my $arg = shift;
daf0d493 296
075d4edd 297 return chr CORE::hex $1 if $arg =~ /^U\+([0-9a-fA-F]+)$/;
dbc0d4f2 298
35c0985d 299 return $vianame{$arg} if exists $vianame{$arg};
4e2cda5d 300
35c0985d 301 $txt = do "unicore/Name.pl" unless $txt;
daf0d493 302
35c0985d
MB
303 my $pos = index $txt, "\t\t$arg\n";
304 if ($[ <= $pos) {
305 my $posLF = rindex $txt, "\n", $pos;
306 (my $code = substr $txt, $posLF + 1, 6) =~ tr/\t//d;
075d4edd 307 return $vianame{$arg} = CORE::hex $code;
35c0985d
MB
308
309 # If $pos is at the 1st line, $posLF must be $[ - 1 (not found);
310 # then $posLF + 1 equals to $[ (at the beginning of $txt).
311 # Otherwise $posLF is the position of "\n";
312 # then $posLF + 1 must be the position of the next to "\n"
313 # (the beginning of the line).
314 # substr($txt, $posLF + 1, 6) may be "0000\t\t", "00A1\t\t",
315 # "10300\t", "100000", etc. So we can get the code via removing TAB.
316 } else {
317 return;
318 }
319} # vianame
b177ca84 320
423cee85
JH
321
3221;
323__END__
324
325=head1 NAME
326
274085e3 327charnames - define character names for C<\N{named}> string literal escapes
423cee85
JH
328
329=head1 SYNOPSIS
330
331 use charnames ':full';
4a2d328f 332 print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
423cee85
JH
333
334 use charnames ':short';
4a2d328f 335 print "\N{greek:Sigma} is an upper-case sigma.\n";
423cee85
JH
336
337 use charnames qw(cyrillic greek);
4a2d328f 338 print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
423cee85 339
35c0985d
MB
340 use charnames ":full", ":alias" => {
341 e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
76ae0c45 342 };
35c0985d
MB
343 print "\N{e_ACUTE} is a small letter e with an acute.\n";
344
76ae0c45 345 use charnames ();
a23c04e4
JH
346 print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
347 printf "%04X", charnames::vianame("GOTHIC LETTER AHSA"); # prints "10330"
b177ca84 348
423cee85
JH
349=head1 DESCRIPTION
350
35c0985d
MB
351Pragma C<use charnames> supports arguments C<:full>, C<:short>, script
352names and customized aliases. If C<:full> is present, for expansion of
76ae0c45
RGS
353C<\N{CHARNAME}>, the string C<CHARNAME> is first looked up in the list of
354standard Unicode character names. If C<:short> is present, and
423cee85
JH
355C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
356as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
a191c821 357with script name arguments, then for C<\N{CHARNAME}> the name
423cee85 358C<CHARNAME> is looked up as a letter in the given scripts (in the
35c0985d 359specified order). Customized aliases are explained in L</CUSTOM ALIASES>.
423cee85
JH
360
361For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
d5448623 362this pragma looks for the names
423cee85
JH
363
364 SCRIPTNAME CAPITAL LETTER CHARNAME
365 SCRIPTNAME SMALL LETTER CHARNAME
366 SCRIPTNAME LETTER CHARNAME
367
368in the table of standard Unicode names. If C<CHARNAME> is lowercase,
daf0d493
JH
369then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant
370is ignored.
371
372Note that C<\N{...}> is compile-time, it's a special form of string
373constant used inside double-quoted strings: in other words, you cannot
4e2cda5d 374use variables inside the C<\N{...}>. If you want similar run-time
daf0d493 375functionality, use charnames::vianame().
423cee85 376
301a3cda 377For the C0 and C1 control characters (U+0000..U+001F, U+0080..U+009F)
dbc0d4f2
JH
378as of Unicode 3.1, there are no official Unicode names but you can use
379instead the ISO 6429 names (LINE FEED, ESCAPE, and so forth). In
380Unicode 3.2 (as of Perl 5.8) some naming changes take place ISO 6429
381has been updated, see L</ALIASES>. Also note that the U+UU80, U+0081,
382U+0084, and U+0099 do not have names even in ISO 6429.
383
384Since the Unicode standard uses "U+HHHH", so can you: "\N{U+263a}"
385is the Unicode smiley face, or "\N{WHITE SMILING FACE}".
301a3cda 386
5ffe0e96 387=head1 ALIASES
423cee85 388
5ffe0e96
MB
389A few aliases have been defined for convenience: instead of having
390to use the official names
423cee85 391
5ffe0e96
MB
392 LINE FEED (LF)
393 FORM FEED (FF)
394 CARRIAGE RETURN (CR)
395 NEXT LINE (NEL)
423cee85 396
5ffe0e96 397(yes, with parentheses) one can use
d5448623 398
5ffe0e96
MB
399 LINE FEED
400 FORM FEED
401 CARRIAGE RETURN
402 NEXT LINE
403 LF
404 FF
405 CR
406 NEL
407
408One can also use
409
410 BYTE ORDER MARK
411 BOM
412
413and
414
415 ZWNJ
416 ZWJ
417
418for ZERO WIDTH NON-JOINER and ZERO WIDTH JOINER.
419
420For backward compatibility one can use the old names for
421certain C0 and C1 controls
422
423 old new
424
425 HORIZONTAL TABULATION CHARACTER TABULATION
426 VERTICAL TABULATION LINE TABULATION
427 FILE SEPARATOR INFORMATION SEPARATOR FOUR
428 GROUP SEPARATOR INFORMATION SEPARATOR THREE
429 RECORD SEPARATOR INFORMATION SEPARATOR TWO
430 UNIT SEPARATOR INFORMATION SEPARATOR ONE
431 PARTIAL LINE DOWN PARTIAL LINE FORWARD
432 PARTIAL LINE UP PARTIAL LINE BACKWARD
433
434but the old names in addition to giving the character
435will also give a warning about being deprecated.
423cee85 436
35c0985d
MB
437=head1 CUSTOM ALIASES
438
439This version of charnames supports three mechanisms of adding local
440or customized aliases to standard Unicode naming conventions (:full)
441
442=head2 Anonymous hashes
443
444 use charnames ":full", ":alias" => {
445 e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
446 };
447 my $str = "\N{e_ACUTE}";
448
449=head2 Alias file
450
451 use charnames ":full", ":alias" => "pro";
452
453 will try to read "unicore/pro_alias.pl" from the @INC path. This
454 file should return a list in plain perl:
455
456 (
457 A_GRAVE => "LATIN CAPITAL LETTER A WITH GRAVE",
458 A_CIRCUM => "LATIN CAPITAL LETTER A WITH CIRCUMFLEX",
459 A_DIAERES => "LATIN CAPITAL LETTER A WITH DIAERESIS",
460 A_TILDE => "LATIN CAPITAL LETTER A WITH TILDE",
461 A_BREVE => "LATIN CAPITAL LETTER A WITH BREVE",
462 A_RING => "LATIN CAPITAL LETTER A WITH RING ABOVE",
463 A_MACRON => "LATIN CAPITAL LETTER A WITH MACRON",
464 );
465
466=head2 Alias shortcut
467
468 use charnames ":alias" => ":pro";
469
470 works exactly the same as the alias pairs, only this time,
471 ":full" is inserted automatically as first argument (if no
472 other argument is given).
473
b177ca84
JF
474=head1 charnames::viacode(code)
475
476Returns the full name of the character indicated by the numeric code.
477The example
478
479 print charnames::viacode(0x2722);
480
481prints "FOUR TEARDROP-SPOKED ASTERISK".
482
daf0d493
JH
483Returns undef if no name is known for the code.
484
35c0985d 485This works only for the standard names, and does not yet apply
daf0d493
JH
486to custom translators.
487
274085e3
PN
488Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
489SPACE", not "BYTE ORDER MARK".
490
eb6a2339 491=head1 charnames::vianame(name)
daf0d493
JH
492
493Returns the code point indicated by the name.
494The example
495
496 printf "%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
497
498prints "2722".
499
eb6a2339 500Returns undef if the name is unknown.
b177ca84 501
35c0985d 502This works only for the standard names, and does not yet apply
b177ca84
JF
503to custom translators.
504
5ffe0e96 505=head1 CUSTOM TRANSLATORS
52ea3e69 506
5ffe0e96
MB
507The mechanism of translation of C<\N{...}> escapes is general and not
508hardwired into F<charnames.pm>. A module can install custom
509translations (inside the scope which C<use>s the module) with the
510following magic incantation:
52ea3e69 511
5ffe0e96
MB
512 sub import {
513 shift;
514 $^H{charnames} = \&translator;
515 }
52ea3e69 516
5ffe0e96
MB
517Here translator() is a subroutine which takes C<CHARNAME> as an
518argument, and returns text to insert into the string instead of the
519C<\N{CHARNAME}> escape. Since the text to insert should be different
520in C<bytes> mode and out of it, the function should check the current
521state of C<bytes>-flag as in:
52ea3e69 522
5ffe0e96
MB
523 use bytes (); # for $bytes::hint_bits
524 sub translator {
525 if ($^H & $bytes::hint_bits) {
526 return bytes_translator(@_);
527 }
528 else {
529 return utf8_translator(@_);
530 }
531 }
52ea3e69 532
f0175764
JH
533=head1 ILLEGAL CHARACTERS
534
00d835f2
JH
535If you ask by name for a character that does not exist, a warning is
536given and the Unicode I<replacement character> "\x{FFFD}" is returned.
537
538If you ask by code for a character that does not exist, no warning is
539given and C<undef> is returned. (Though if you ask for a code point
540past U+10FFFF you do get a warning.)
f0175764 541
423cee85
JH
542=head1 BUGS
543
fe749c9a
KW
544Unicode standard named sequences are not recognized, such as
545C<LATIN CAPITAL LETTER A WITH MACRON AND GRAVE>
546(which should mean C<LATIN CAPITAL LETTER A WITH MACRON> with an additional
547C<COMBINING GRAVE ACCENT>).
548
423cee85
JH
549Since evaluation of the translation function happens in a middle of
550compilation (of a string literal), the translation function should not
551do any C<eval>s or C<require>s. This restriction should be lifted in
552a future version of Perl.
553
554=cut