This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #39420] [PATCH] Data::Dumper fails to escape bless class name
[perl5.git] / lib / charnames.pm
CommitLineData
423cee85 1package charnames;
b177ca84
JF
2use strict;
3use warnings;
51cf30b6 4use File::Spec;
075d4edd 5our $VERSION = '1.06';
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
423cee85
JH
387=head1 CUSTOM TRANSLATORS
388
d5448623 389The mechanism of translation of C<\N{...}> escapes is general and not
423cee85 390hardwired into F<charnames.pm>. A module can install custom
d5448623 391translations (inside the scope which C<use>s the module) with the
423cee85
JH
392following magic incantation:
393
d5448623
GS
394 sub import {
395 shift;
d5448623
GS
396 $^H{charnames} = \&translator;
397 }
423cee85
JH
398
399Here translator() is a subroutine which takes C<CHARNAME> as an
400argument, and returns text to insert into the string instead of the
4a2d328f 401C<\N{CHARNAME}> escape. Since the text to insert should be different
d5448623
GS
402in C<bytes> mode and out of it, the function should check the current
403state of C<bytes>-flag as in:
404
405 use bytes (); # for $bytes::hint_bits
406 sub translator {
407 if ($^H & $bytes::hint_bits) {
408 return bytes_translator(@_);
409 }
410 else {
411 return utf8_translator(@_);
412 }
423cee85 413 }
423cee85 414
35c0985d
MB
415=head1 CUSTOM ALIASES
416
417This version of charnames supports three mechanisms of adding local
418or customized aliases to standard Unicode naming conventions (:full)
419
420=head2 Anonymous hashes
421
422 use charnames ":full", ":alias" => {
423 e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
424 };
425 my $str = "\N{e_ACUTE}";
426
427=head2 Alias file
428
429 use charnames ":full", ":alias" => "pro";
430
431 will try to read "unicore/pro_alias.pl" from the @INC path. This
432 file should return a list in plain perl:
433
434 (
435 A_GRAVE => "LATIN CAPITAL LETTER A WITH GRAVE",
436 A_CIRCUM => "LATIN CAPITAL LETTER A WITH CIRCUMFLEX",
437 A_DIAERES => "LATIN CAPITAL LETTER A WITH DIAERESIS",
438 A_TILDE => "LATIN CAPITAL LETTER A WITH TILDE",
439 A_BREVE => "LATIN CAPITAL LETTER A WITH BREVE",
440 A_RING => "LATIN CAPITAL LETTER A WITH RING ABOVE",
441 A_MACRON => "LATIN CAPITAL LETTER A WITH MACRON",
442 );
443
444=head2 Alias shortcut
445
446 use charnames ":alias" => ":pro";
447
448 works exactly the same as the alias pairs, only this time,
449 ":full" is inserted automatically as first argument (if no
450 other argument is given).
451
b177ca84
JF
452=head1 charnames::viacode(code)
453
454Returns the full name of the character indicated by the numeric code.
455The example
456
457 print charnames::viacode(0x2722);
458
459prints "FOUR TEARDROP-SPOKED ASTERISK".
460
daf0d493
JH
461Returns undef if no name is known for the code.
462
35c0985d 463This works only for the standard names, and does not yet apply
daf0d493
JH
464to custom translators.
465
274085e3
PN
466Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
467SPACE", not "BYTE ORDER MARK".
468
eb6a2339 469=head1 charnames::vianame(name)
daf0d493
JH
470
471Returns the code point indicated by the name.
472The example
473
474 printf "%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
475
476prints "2722".
477
eb6a2339 478Returns undef if the name is unknown.
b177ca84 479
35c0985d 480This works only for the standard names, and does not yet apply
b177ca84
JF
481to custom translators.
482
52ea3e69
JH
483=head1 ALIASES
484
485A few aliases have been defined for convenience: instead of having
486to use the official names
487
488 LINE FEED (LF)
489 FORM FEED (FF)
490 CARRIAGE RETURN (CR)
491 NEXT LINE (NEL)
492
493(yes, with parentheses) one can use
494
495 LINE FEED
496 FORM FEED
497 CARRIAGE RETURN
498 NEXT LINE
499 LF
500 FF
501 CR
502 NEL
503
504One can also use
505
506 BYTE ORDER MARK
507 BOM
508
24b5d5cc
JH
509and
510
511 ZWNJ
512 ZWJ
513
514for ZERO WIDTH NON-JOINER and ZERO WIDTH JOINER.
52ea3e69
JH
515
516For backward compatibility one can use the old names for
517certain C0 and C1 controls
518
519 old new
520
521 HORIZONTAL TABULATION CHARACTER TABULATION
522 VERTICAL TABULATION LINE TABULATION
523 FILE SEPARATOR INFORMATION SEPARATOR FOUR
524 GROUP SEPARATOR INFORMATION SEPARATOR THREE
525 RECORD SEPARATOR INFORMATION SEPARATOR TWO
526 UNIT SEPARATOR INFORMATION SEPARATOR ONE
527 PARTIAL LINE DOWN PARTIAL LINE FORWARD
528 PARTIAL LINE UP PARTIAL LINE BACKWARD
529
530but the old names in addition to giving the character
531will also give a warning about being deprecated.
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
544Since evaluation of the translation function happens in a middle of
545compilation (of a string literal), the translation function should not
546do any C<eval>s or C<require>s. This restriction should be lifted in
547a future version of Perl.
548
549=cut