This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Doc fix for charnames::vianame
[perl5.git] / lib / charnames.pm
CommitLineData
423cee85 1package charnames;
b177ca84
JF
2use strict;
3use warnings;
4use Carp;
5our $VERSION = '1.01';
b75c8c73 6
d5448623
GS
7use bytes (); # for $bytes::hint_bits
8$charnames::hint_bits = 0x20000;
423cee85 9
52ea3e69
JH
10my %alias1 = (
11 # Icky 3.2 names with parentheses.
12 'LINE FEED' => 'LINE FEED (LF)',
13 'FORM FEED' => 'FORM FEED (FF)',
14 'CARRIAGE RETURN' => 'CARRIAGE RETURN (CR)',
15 'NEXT LINE' => 'NEXT LINE (NEL)',
16 # Convenience.
17 'LF' => 'LINE FEED (LF)',
18 'FF' => 'FORM FEED (FF)',
19 'CR' => 'CARRIAGE RETURN (LF)',
51e9e896 20 'NEL' => 'NEXT LINE (NEL)',
24b5d5cc
JH
21 # More convenience. For futher convencience,
22 # it is suggested some way using using the NamesList
23 # aliases is implemented.
24 'ZWNJ' => 'ZERO WIDTH NON-JOINER',
25 'ZWJ' => 'ZERO WIDTH JOINER',
52ea3e69
JH
26 'BOM' => 'BYTE ORDER MARK',
27 );
28
29my %alias2 = (
30 # Pre-3.2 compatibility (only for the first 256 characters).
31 'HORIZONTAL TABULATION' => 'CHARACTER TABULATION',
32 'VERTICAL TABULATION' => 'LINE TABULATION',
33 'FILE SEPARATOR' => 'INFORMATION SEPARATOR FOUR',
34 'GROUP SEPARATOR' => 'INFORMATION SEPARATOR THREE',
35 'RECORD SEPARATOR' => 'INFORMATION SEPARATOR TWO',
36 'UNIT SEPARATOR' => 'INFORMATION SEPARATOR ONE',
37 'PARTIAL LINE DOWN' => 'PARTIAL LINE FORWARD',
38 'PARTIAL LINE UP' => 'PARTIAL LINE BACKWARD',
39 );
40
423cee85
JH
41my $txt;
42
43# This is not optimized in any way yet
b177ca84
JF
44sub charnames
45{
46 my $name = shift;
47
52ea3e69
JH
48 if (exists $alias1{$name}) {
49 $name = $alias1{$name};
50 }
51 if (exists $alias2{$name}) {
52 require warnings;
53 warnings::warnif('deprecated', qq{Unicode character name "$name" is deprecated, use "$alias2{$name}" instead});
54 $name = $alias2{$name};
55 }
b177ca84 56
52ea3e69 57 my $ord;
423cee85 58 my @off;
52ea3e69
JH
59 my $fname;
60
61 if ($name eq "BYTE ORDER MARK") {
62 $fname = $name;
d7d589a8 63 $ord = 0xFEFF;
52ea3e69
JH
64 } else {
65 ## Suck in the code/name list as a big string.
66 ## Lines look like:
67 ## "0052\t\tLATIN CAPITAL LETTER R\n"
68 $txt = do "unicore/Name.pl" unless $txt;
b177ca84 69
52ea3e69
JH
70 ## @off will hold the index into the code/name string of the start and
71 ## end of the name as we find it.
72
73 ## If :full, look for the the name exactly
74 if ($^H{charnames_full} and $txt =~ /\t\t\Q$name\E$/m) {
75 @off = ($-[0], $+[0]);
423cee85 76 }
b177ca84 77
52ea3e69
JH
78 ## If we didn't get above, and :short allowed, look for the short name.
79 ## The short name is like "greek:Sigma"
80 unless (@off) {
81 if ($^H{charnames_short} and $name =~ /^(.+?):(.+)/s) {
82 my ($script, $cname) = ($1,$2);
83 my $case = ( $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
84 if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U\Q$cname\E$/m) {
85 @off = ($-[0], $+[0]);
86 }
87 }
88 }
89
90 ## If we still don't have it, check for the name among the loaded
91 ## scripts.
92 if (not @off)
b177ca84 93 {
52ea3e69
JH
94 my $case = ( $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
95 for my $script ( @{$^H{charnames_scripts}} )
96 {
97 if ($txt =~ m/\t\t$script (?:$case )?LETTER \U\Q$name\E$/m) {
98 @off = ($-[0], $+[0]);
99 last;
100 }
101 }
b177ca84 102 }
52ea3e69
JH
103
104 ## If we don't have it by now, give up.
105 unless (@off) {
106 carp "Unknown charname '$name'";
107 return "\x{FFFD}";
108 }
109
110 ##
111 ## Now know where in the string the name starts.
274085e3 112 ## The code, in hex, is before that.
52ea3e69
JH
113 ##
114 ## The code can be 4-6 characters long, so we've got to sort of
115 ## go look for it, just after the newline that comes before $off[0].
116 ##
117 ## This would be much easier if unicore/Name.pl had info in
118 ## a name/code order, instead of code/name order.
119 ##
120 ## The +1 after the rindex() is to skip past the newline we're finding,
121 ## or, if the rindex() fails, to put us to an offset of zero.
122 ##
123 my $hexstart = rindex($txt, "\n", $off[0]) + 1;
124
125 ## we know where it starts, so turn into number -
126 ## the ordinal for the char.
127 $ord = hex substr($txt, $hexstart, $off[0] - $hexstart);
423cee85 128 }
b177ca84 129
d5448623 130 if ($^H & $bytes::hint_bits) { # "use bytes" in effect?
8058d7ab 131 use bytes;
d41ff1b8 132 return chr $ord if $ord <= 255;
f0175764 133 my $hex = sprintf "%04x", $ord;
52ea3e69
JH
134 if (not defined $fname) {
135 $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
136 }
f0175764 137 croak "Character 0x$hex with name '$fname' is above 0xFF";
423cee85 138 }
f0175764 139
52ea3e69 140 no warnings 'utf8'; # allow even illegal characters
bfa383d6 141 return pack "U", $ord;
423cee85
JH
142}
143
b177ca84
JF
144sub import
145{
146 shift; ## ignore class name
147
148 if (not @_)
149 {
150 carp("`use charnames' needs explicit imports list");
151 }
d5448623 152 $^H |= $charnames::hint_bits;
423cee85 153 $^H{charnames} = \&charnames ;
b177ca84
JF
154
155 ##
156 ## fill %h keys with our @_ args.
157 ##
423cee85
JH
158 my %h;
159 @h{@_} = (1) x @_;
b177ca84 160
423cee85
JH
161 $^H{charnames_full} = delete $h{':full'};
162 $^H{charnames_short} = delete $h{':short'};
163 $^H{charnames_scripts} = [map uc, keys %h];
b177ca84
JF
164
165 ##
166 ## If utf8? warnings are enabled, and some scripts were given,
167 ## see if at least we can find one letter of each script.
168 ##
169 if (warnings::enabled('utf8') && @{$^H{charnames_scripts}})
170 {
171 $txt = do "unicore/Name.pl" unless $txt;
172
173 for my $script (@{$^H{charnames_scripts}})
174 {
175 if (not $txt =~ m/\t\t$script (?:CAPITAL |SMALL )?LETTER /) {
176 warnings::warn('utf8', "No such script: '$script'");
177 }
178 }
bd62941a 179 }
423cee85
JH
180}
181
f0175764
JH
182require Unicode::UCD; # for Unicode::UCD::_getcode()
183
4e2cda5d
JH
184my %viacode;
185
b177ca84
JF
186sub viacode
187{
188 if (@_ != 1) {
274085e3 189 carp "charnames::viacode() expects one argument";
b177ca84
JF
190 return ()
191 }
f0175764 192
b177ca84 193 my $arg = shift;
f0175764 194 my $code = Unicode::UCD::_getcode($arg);
b177ca84
JF
195
196 my $hex;
f0175764
JH
197
198 if (defined $code) {
b177ca84
JF
199 $hex = sprintf "%04X", $arg;
200 } else {
201 carp("unexpected arg \"$arg\" to charnames::viacode()");
daf0d493 202 return;
b177ca84
JF
203 }
204
f0175764
JH
205 if ($code > 0x10FFFF) {
206 carp "Unicode characters only allocated up to 0x10FFFF (you asked for $hex)";
11881cb4 207 return;
f0175764
JH
208 }
209
4e2cda5d
JH
210 return $viacode{$hex} if exists $viacode{$hex};
211
b177ca84
JF
212 $txt = do "unicore/Name.pl" unless $txt;
213
214 if ($txt =~ m/^$hex\t\t(.+)/m) {
4e2cda5d 215 return $viacode{$hex} = $1;
b177ca84 216 } else {
11881cb4 217 return;
daf0d493
JH
218 }
219}
220
4e2cda5d
JH
221my %vianame;
222
daf0d493
JH
223sub vianame
224{
225 if (@_ != 1) {
226 carp "charnames::vianame() expects one name argument";
227 return ()
228 }
229
230 my $arg = shift;
231
dbc0d4f2
JH
232 return chr hex $1 if $arg =~ /^U\+([0-9a-fA-F]+)$/;
233
4e2cda5d
JH
234 return $vianame{$arg} if exists $vianame{$arg};
235
daf0d493
JH
236 $txt = do "unicore/Name.pl" unless $txt;
237
238 if ($txt =~ m/^([0-9A-F]+)\t\t($arg)/m) {
4e2cda5d 239 return $vianame{$arg} = hex $1;
daf0d493
JH
240 } else {
241 return;
b177ca84
JF
242 }
243}
244
423cee85
JH
245
2461;
247__END__
248
249=head1 NAME
250
274085e3 251charnames - define character names for C<\N{named}> string literal escapes
423cee85
JH
252
253=head1 SYNOPSIS
254
255 use charnames ':full';
4a2d328f 256 print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
423cee85
JH
257
258 use charnames ':short';
4a2d328f 259 print "\N{greek:Sigma} is an upper-case sigma.\n";
423cee85
JH
260
261 use charnames qw(cyrillic greek);
4a2d328f 262 print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
423cee85 263
a23c04e4
JH
264 print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
265 printf "%04X", charnames::vianame("GOTHIC LETTER AHSA"); # prints "10330"
b177ca84 266
423cee85
JH
267=head1 DESCRIPTION
268
269Pragma C<use charnames> supports arguments C<:full>, C<:short> and
270script names. If C<:full> is present, for expansion of
a191c821 271C<\N{CHARNAME}> string C<CHARNAME> is first looked in the list of
423cee85
JH
272standard Unicode names of chars. If C<:short> is present, and
273C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
274as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
a191c821 275with script name arguments, then for C<\N{CHARNAME}> the name
423cee85
JH
276C<CHARNAME> is looked up as a letter in the given scripts (in the
277specified order).
278
279For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
d5448623 280this pragma looks for the names
423cee85
JH
281
282 SCRIPTNAME CAPITAL LETTER CHARNAME
283 SCRIPTNAME SMALL LETTER CHARNAME
284 SCRIPTNAME LETTER CHARNAME
285
286in the table of standard Unicode names. If C<CHARNAME> is lowercase,
daf0d493
JH
287then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant
288is ignored.
289
290Note that C<\N{...}> is compile-time, it's a special form of string
291constant used inside double-quoted strings: in other words, you cannot
4e2cda5d 292use variables inside the C<\N{...}>. If you want similar run-time
daf0d493 293functionality, use charnames::vianame().
423cee85 294
301a3cda 295For the C0 and C1 control characters (U+0000..U+001F, U+0080..U+009F)
dbc0d4f2
JH
296as of Unicode 3.1, there are no official Unicode names but you can use
297instead the ISO 6429 names (LINE FEED, ESCAPE, and so forth). In
298Unicode 3.2 (as of Perl 5.8) some naming changes take place ISO 6429
299has been updated, see L</ALIASES>. Also note that the U+UU80, U+0081,
300U+0084, and U+0099 do not have names even in ISO 6429.
301
302Since the Unicode standard uses "U+HHHH", so can you: "\N{U+263a}"
303is the Unicode smiley face, or "\N{WHITE SMILING FACE}".
301a3cda 304
423cee85
JH
305=head1 CUSTOM TRANSLATORS
306
d5448623 307The mechanism of translation of C<\N{...}> escapes is general and not
423cee85 308hardwired into F<charnames.pm>. A module can install custom
d5448623 309translations (inside the scope which C<use>s the module) with the
423cee85
JH
310following magic incantation:
311
d5448623
GS
312 use charnames (); # for $charnames::hint_bits
313 sub import {
314 shift;
315 $^H |= $charnames::hint_bits;
316 $^H{charnames} = \&translator;
317 }
423cee85
JH
318
319Here translator() is a subroutine which takes C<CHARNAME> as an
320argument, and returns text to insert into the string instead of the
4a2d328f 321C<\N{CHARNAME}> escape. Since the text to insert should be different
d5448623
GS
322in C<bytes> mode and out of it, the function should check the current
323state of C<bytes>-flag as in:
324
325 use bytes (); # for $bytes::hint_bits
326 sub translator {
327 if ($^H & $bytes::hint_bits) {
328 return bytes_translator(@_);
329 }
330 else {
331 return utf8_translator(@_);
332 }
423cee85 333 }
423cee85 334
b177ca84
JF
335=head1 charnames::viacode(code)
336
337Returns the full name of the character indicated by the numeric code.
338The example
339
340 print charnames::viacode(0x2722);
341
342prints "FOUR TEARDROP-SPOKED ASTERISK".
343
daf0d493
JH
344Returns undef if no name is known for the code.
345
274085e3 346This works only for the standard names, and does not yet apply
daf0d493
JH
347to custom translators.
348
274085e3
PN
349Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
350SPACE", not "BYTE ORDER MARK".
351
eb6a2339 352=head1 charnames::vianame(name)
daf0d493
JH
353
354Returns the code point indicated by the name.
355The example
356
357 printf "%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
358
359prints "2722".
360
eb6a2339 361Returns undef if the name is unknown.
b177ca84 362
eb6a2339 363This works only for the standard names, and does not yet apply
b177ca84
JF
364to custom translators.
365
52ea3e69
JH
366=head1 ALIASES
367
368A few aliases have been defined for convenience: instead of having
369to use the official names
370
371 LINE FEED (LF)
372 FORM FEED (FF)
373 CARRIAGE RETURN (CR)
374 NEXT LINE (NEL)
375
376(yes, with parentheses) one can use
377
378 LINE FEED
379 FORM FEED
380 CARRIAGE RETURN
381 NEXT LINE
382 LF
383 FF
384 CR
385 NEL
386
387One can also use
388
389 BYTE ORDER MARK
390 BOM
391
24b5d5cc
JH
392and
393
394 ZWNJ
395 ZWJ
396
397for ZERO WIDTH NON-JOINER and ZERO WIDTH JOINER.
52ea3e69
JH
398
399For backward compatibility one can use the old names for
400certain C0 and C1 controls
401
402 old new
403
404 HORIZONTAL TABULATION CHARACTER TABULATION
405 VERTICAL TABULATION LINE TABULATION
406 FILE SEPARATOR INFORMATION SEPARATOR FOUR
407 GROUP SEPARATOR INFORMATION SEPARATOR THREE
408 RECORD SEPARATOR INFORMATION SEPARATOR TWO
409 UNIT SEPARATOR INFORMATION SEPARATOR ONE
410 PARTIAL LINE DOWN PARTIAL LINE FORWARD
411 PARTIAL LINE UP PARTIAL LINE BACKWARD
412
413but the old names in addition to giving the character
414will also give a warning about being deprecated.
415
f0175764
JH
416=head1 ILLEGAL CHARACTERS
417
a23c04e4
JH
418If you ask for a character that does not exist, a warning is given
419and the Unicode I<replacement character> "\x{FFFD}" is returned.
f0175764 420
423cee85
JH
421=head1 BUGS
422
423Since evaluation of the translation function happens in a middle of
424compilation (of a string literal), the translation function should not
425do any C<eval>s or C<require>s. This restriction should be lifted in
426a future version of Perl.
427
428=cut