[ PATCH ] mymalloc on HP-UX
[p5sagit/p5-mst-13.2.git] / lib / charnames.pm
CommitLineData
423cee85 1package charnames;
b177ca84 2use strict;
3use warnings;
4use Carp;
5our $VERSION = '1.01';
b75c8c73 6
d5448623 7use bytes (); # for $bytes::hint_bits
8$charnames::hint_bits = 0x20000;
423cee85 9
52ea3e69 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)',
eb380778 19 'CR' => 'CARRIAGE RETURN (CR)',
51e9e896 20 'NEL' => 'NEXT LINE (NEL)',
24b5d5cc 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 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 41my $txt;
42
43# This is not optimized in any way yet
b177ca84 44sub charnames
45{
46 my $name = shift;
47
52ea3e69 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 59 my $fname;
60
61 if ($name eq "BYTE ORDER MARK") {
62 $fname = $name;
d7d589a8 63 $ord = 0xFEFF;
52ea3e69 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 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 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 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 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 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 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 142}
143
b177ca84 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 154
155 ##
156 ## fill %h keys with our @_ args.
157 ##
423cee85 158 my %h;
159 @h{@_} = (1) x @_;
b177ca84 160
423cee85 161 $^H{charnames_full} = delete $h{':full'};
162 $^H{charnames_short} = delete $h{':short'};
163 $^H{charnames_scripts} = [map uc, keys %h];
b177ca84 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 180}
181
f0175764 182require Unicode::UCD; # for Unicode::UCD::_getcode()
183
4e2cda5d 184my %viacode;
185
b177ca84 186sub viacode
187{
188 if (@_ != 1) {
274085e3 189 carp "charnames::viacode() expects one argument";
b177ca84 190 return ()
191 }
f0175764 192
b177ca84 193 my $arg = shift;
f0175764 194 my $code = Unicode::UCD::_getcode($arg);
b177ca84 195
196 my $hex;
f0175764 197
198 if (defined $code) {
b177ca84 199 $hex = sprintf "%04X", $arg;
200 } else {
201 carp("unexpected arg \"$arg\" to charnames::viacode()");
daf0d493 202 return;
b177ca84 203 }
204
f0175764 205 if ($code > 0x10FFFF) {
00d835f2 206 carp sprintf "Unicode characters only allocated up to U+10FFFF (you asked for U+%X)", $hex;
11881cb4 207 return;
f0175764 208 }
209
4e2cda5d 210 return $viacode{$hex} if exists $viacode{$hex};
211
b177ca84 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 218 }
219}
220
4e2cda5d 221my %vianame;
222
daf0d493 223sub vianame
224{
225 if (@_ != 1) {
226 carp "charnames::vianame() expects one name argument";
227 return ()
228 }
229
230 my $arg = shift;
231
dbc0d4f2 232 return chr hex $1 if $arg =~ /^U\+([0-9a-fA-F]+)$/;
233
4e2cda5d 234 return $vianame{$arg} if exists $vianame{$arg};
235
daf0d493 236 $txt = do "unicore/Name.pl" unless $txt;
237
94ec6410 238 my $pos = index $txt, "\t\t$arg\n";
239 if ($[ <= $pos) {
240 my $posLF = rindex $txt, "\n", $pos;
241 (my $code = substr $txt, $posLF + 1, 6) =~ tr/\t//d;
242 return $vianame{$arg} = hex $code;
243
244 # If $pos is at the 1st line, $posLF must be $[ - 1 (not found);
245 # then $posLF + 1 equals to $[ (at the beginning of $txt).
246 # Otherwise $posLF is the position of "\n";
247 # then $posLF + 1 must be the position of the next to "\n"
248 # (the beginning of the line).
249 # substr($txt, $posLF + 1, 6) may be "0000\t\t", "00A1\t\t",
250 # "10300\t", "100000", etc. So we can get the code via removing TAB.
daf0d493 251 } else {
252 return;
b177ca84 253 }
254}
255
423cee85 256
2571;
258__END__
259
260=head1 NAME
261
274085e3 262charnames - define character names for C<\N{named}> string literal escapes
423cee85 263
264=head1 SYNOPSIS
265
266 use charnames ':full';
4a2d328f 267 print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
423cee85 268
269 use charnames ':short';
4a2d328f 270 print "\N{greek:Sigma} is an upper-case sigma.\n";
423cee85 271
272 use charnames qw(cyrillic greek);
4a2d328f 273 print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
423cee85 274
a23c04e4 275 print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
276 printf "%04X", charnames::vianame("GOTHIC LETTER AHSA"); # prints "10330"
b177ca84 277
423cee85 278=head1 DESCRIPTION
279
280Pragma C<use charnames> supports arguments C<:full>, C<:short> and
281script names. If C<:full> is present, for expansion of
a191c821 282C<\N{CHARNAME}> string C<CHARNAME> is first looked in the list of
423cee85 283standard Unicode names of chars. If C<:short> is present, and
284C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
285as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
a191c821 286with script name arguments, then for C<\N{CHARNAME}> the name
423cee85 287C<CHARNAME> is looked up as a letter in the given scripts (in the
288specified order).
289
290For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
d5448623 291this pragma looks for the names
423cee85 292
293 SCRIPTNAME CAPITAL LETTER CHARNAME
294 SCRIPTNAME SMALL LETTER CHARNAME
295 SCRIPTNAME LETTER CHARNAME
296
297in the table of standard Unicode names. If C<CHARNAME> is lowercase,
daf0d493 298then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant
299is ignored.
300
301Note that C<\N{...}> is compile-time, it's a special form of string
302constant used inside double-quoted strings: in other words, you cannot
4e2cda5d 303use variables inside the C<\N{...}>. If you want similar run-time
daf0d493 304functionality, use charnames::vianame().
423cee85 305
301a3cda 306For the C0 and C1 control characters (U+0000..U+001F, U+0080..U+009F)
dbc0d4f2 307as of Unicode 3.1, there are no official Unicode names but you can use
308instead the ISO 6429 names (LINE FEED, ESCAPE, and so forth). In
309Unicode 3.2 (as of Perl 5.8) some naming changes take place ISO 6429
310has been updated, see L</ALIASES>. Also note that the U+UU80, U+0081,
311U+0084, and U+0099 do not have names even in ISO 6429.
312
313Since the Unicode standard uses "U+HHHH", so can you: "\N{U+263a}"
314is the Unicode smiley face, or "\N{WHITE SMILING FACE}".
301a3cda 315
423cee85 316=head1 CUSTOM TRANSLATORS
317
d5448623 318The mechanism of translation of C<\N{...}> escapes is general and not
423cee85 319hardwired into F<charnames.pm>. A module can install custom
d5448623 320translations (inside the scope which C<use>s the module) with the
423cee85 321following magic incantation:
322
d5448623 323 use charnames (); # for $charnames::hint_bits
324 sub import {
325 shift;
326 $^H |= $charnames::hint_bits;
327 $^H{charnames} = \&translator;
328 }
423cee85 329
330Here translator() is a subroutine which takes C<CHARNAME> as an
331argument, and returns text to insert into the string instead of the
4a2d328f 332C<\N{CHARNAME}> escape. Since the text to insert should be different
d5448623 333in C<bytes> mode and out of it, the function should check the current
334state of C<bytes>-flag as in:
335
336 use bytes (); # for $bytes::hint_bits
337 sub translator {
338 if ($^H & $bytes::hint_bits) {
339 return bytes_translator(@_);
340 }
341 else {
342 return utf8_translator(@_);
343 }
423cee85 344 }
423cee85 345
b177ca84 346=head1 charnames::viacode(code)
347
348Returns the full name of the character indicated by the numeric code.
349The example
350
351 print charnames::viacode(0x2722);
352
353prints "FOUR TEARDROP-SPOKED ASTERISK".
354
daf0d493 355Returns undef if no name is known for the code.
356
274085e3 357This works only for the standard names, and does not yet apply
daf0d493 358to custom translators.
359
274085e3 360Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
361SPACE", not "BYTE ORDER MARK".
362
eb6a2339 363=head1 charnames::vianame(name)
daf0d493 364
365Returns the code point indicated by the name.
366The example
367
368 printf "%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
369
370prints "2722".
371
eb6a2339 372Returns undef if the name is unknown.
b177ca84 373
eb6a2339 374This works only for the standard names, and does not yet apply
b177ca84 375to custom translators.
376
52ea3e69 377=head1 ALIASES
378
379A few aliases have been defined for convenience: instead of having
380to use the official names
381
382 LINE FEED (LF)
383 FORM FEED (FF)
384 CARRIAGE RETURN (CR)
385 NEXT LINE (NEL)
386
387(yes, with parentheses) one can use
388
389 LINE FEED
390 FORM FEED
391 CARRIAGE RETURN
392 NEXT LINE
393 LF
394 FF
395 CR
396 NEL
397
398One can also use
399
400 BYTE ORDER MARK
401 BOM
402
24b5d5cc 403and
404
405 ZWNJ
406 ZWJ
407
408for ZERO WIDTH NON-JOINER and ZERO WIDTH JOINER.
52ea3e69 409
410For backward compatibility one can use the old names for
411certain C0 and C1 controls
412
413 old new
414
415 HORIZONTAL TABULATION CHARACTER TABULATION
416 VERTICAL TABULATION LINE TABULATION
417 FILE SEPARATOR INFORMATION SEPARATOR FOUR
418 GROUP SEPARATOR INFORMATION SEPARATOR THREE
419 RECORD SEPARATOR INFORMATION SEPARATOR TWO
420 UNIT SEPARATOR INFORMATION SEPARATOR ONE
421 PARTIAL LINE DOWN PARTIAL LINE FORWARD
422 PARTIAL LINE UP PARTIAL LINE BACKWARD
423
424but the old names in addition to giving the character
425will also give a warning about being deprecated.
426
f0175764 427=head1 ILLEGAL CHARACTERS
428
00d835f2 429If you ask by name for a character that does not exist, a warning is
430given and the Unicode I<replacement character> "\x{FFFD}" is returned.
431
432If you ask by code for a character that does not exist, no warning is
433given and C<undef> is returned. (Though if you ask for a code point
434past U+10FFFF you do get a warning.)
f0175764 435
423cee85 436=head1 BUGS
437
438Since evaluation of the translation function happens in a middle of
439compilation (of a string literal), the translation function should not
440do any C<eval>s or C<require>s. This restriction should be lifted in
441a future version of Perl.
442
443=cut