1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
package charnames;
my $fname = 'unicode/UnicodeData-Latest.txt';
my $txt;
# This is not optimized in any way yet
sub charnames {
$name = shift;
$txt = do "unicode/Name.pl" unless $txt;
my @off;
if ($^H{charnames_full} and $txt =~ /\t\t$name$/m) {
@off = ($-[0], $+[0]);
}
unless (@off) {
if ($^H{charnames_short} and $name =~ /^(.*?):(.*)/s) {
my ($script, $cname) = ($1,$2);
my $case = ( $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U$cname$/m) {
@off = ($-[0], $+[0]);
}
}
}
unless (@off) {
my $case = ( $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
for ( @{$^H{charnames_scripts}} ) {
(@off = ($-[0], $+[0])), last
if $txt =~ m/\t\t$_ (?:$case )?LETTER \U$name$/m;
}
}
die "Unknown charname '$name'" unless @off;
# use caller 'encoding'; # Does not work at compile time?
my $ord = hex substr $txt, $off[0] - 4, 4;
if ($^H & 0x8) {
use utf8;
return chr $ord;
}
return chr $ord if $ord <= 255;
my $hex = sprintf '%X=0%o', $ord, $ord;
my $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
die "Character 0x$hex with name '$fname' is above 0xFF";
}
sub import {
shift;
die "No scripts for `use charnames'" unless @_;
$^H |= 0x20000;
$^H{charnames} = \&charnames ;
my %h;
@h{@_} = (1) x @_;
$^H{charnames_full} = delete $h{':full'};
$^H{charnames_short} = delete $h{':short'};
$^H{charnames_scripts} = [map uc, keys %h];
}
1;
__END__
=head1 NAME
charnames - define character names for C<\N{named}> string literal escape.
=head1 SYNOPSIS
use charnames ':full';
print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
use charnames ':short';
print "\N{greek:Sigma} is an upper-case sigma.\n";
use charnames qw(cyrillic greek);
print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
=head1 DESCRIPTION
Pragma C<use charnames> supports arguments C<:full>, C<:short> and
script names. If C<:full> is present, for expansion of
C<\N{CHARNAME}}> string C<CHARNAME> is first looked in the list of
standard Unicode names of chars. If C<:short> is present, and
C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
with script name arguments, then for C<\N{CHARNAME}}> the name
C<CHARNAME> is looked up as a letter in the given scripts (in the
specified order).
For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
F<charcodes.pm> looks for the names
SCRIPTNAME CAPITAL LETTER CHARNAME
SCRIPTNAME SMALL LETTER CHARNAME
SCRIPTNAME LETTER CHARNAME
in the table of standard Unicode names. If C<CHARNAME> is lowercase,
then the C<CAPITAL> variant is ignored, otherwise C<SMALL> variant is
ignored.
=head1 CUSTOM TRANSLATORS
The mechanism of translation is C<\N{...}> escapes is general and not
hardwired into F<charnames.pm>. A module can install custom
translations (inside the scope which C<use>s the module) by the
following magic incantation:
sub import {
shift;
$^H |= 0x20000;
$^H{charnames} = \&translator;
}
Here translator() is a subroutine which takes C<CHARNAME> as an
argument, and returns text to insert into the string instead of the
C<\N{CHARNAME}> escape. Since the text to insert should be different
in C<utf8> mode and out of it, the function should check the current
state of C<utf8>-flag as in
sub translator {
if ($^H & 0x8) {
return utf_translator(@_);
} else {
return no_utf_translator(@_);
}
}
=head1 BUGS
Since evaluation of the translation function happens in a middle of
compilation (of a string literal), the translation function should not
do any C<eval>s or C<require>s. This restriction should be lifted in
a future version of Perl.
=cut
|
