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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
#!perl -w
use 5.012;
use strict;
use warnings;
require 'regen/regen_lib.pl';
# This program outputs the 256 lines that form the guts of the PL_charclass
# table. The output should be used to manually replace the table contents in
# l1_charclass_tab.h. Each line is a bit map of properties that the Unicode
# code point at the corresponding position in the table array has. The first
# line corresponds to code point U+0000, NULL, the last line to U=00FF. For
# an application to see if the code point "i" has a particular property, it
# just does
# 'PL_charclass[i] & BIT'
# The bit names are of the form '_CC_property_suffix', where 'CC' stands for
# character class, and 'property' is the corresponding property, and 'suffix'
# is one of '_A' to mean the property is true only if the corresponding code
# point is ASCII, and '_L1' means that the range includes any Latin1
# character (ISO-8859-1 including the C0 and C1 controls). A property without
# these suffixes does not have different forms for both ranges.
# The data in the table is pretty well set in stone, so that this program need
# be run only when adding new properties to it.
my @properties = qw(
ALNUMC_A
ALNUMC_L1
ALPHA_A
ALPHA_L1
BLANK_A
BLANK_L1
CHARNAME_CONT
CNTRL_A
CNTRL_L1
DIGIT_A
GRAPH_A
GRAPH_L1
IDFIRST_A
IDFIRST_L1
LOWER_A
LOWER_L1
OCTAL_A
PRINT_A
PRINT_L1
PSXSPC_A
PSXSPC_L1
PUNCT_A
PUNCT_L1
SPACE_A
SPACE_L1
UPPER_A
UPPER_L1
WORDCHAR_A
WORDCHAR_L1
XDIGIT_A
);
# Read in the case fold mappings.
my %folded_closure;
my $file="lib/unicore/CaseFolding.txt";
open my $fh, "<", $file or die "Failed to read '$file': $!";
while (<$fh>) {
chomp;
# Lines look like (without the initial '#'
#0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
my ($line, $comment) = split / \s+ \# \s+ /x, $_;
next if $line eq "" || substr($line, 0, 1) eq '#';
my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line;
my $from = hex $hex_from;
# Perl only deals with C and F folds
next if $fold_type ne 'C' and $fold_type ne 'F';
# Get each code point in the range that participates in this line's fold.
# The hash has keys of each code point in the range, and values of what it
# folds to and what folds to it
foreach my $hex_fold (@folded) {
my $fold = hex $hex_fold;
push @{$folded_closure{$fold}}, $from if $fold < 256;
push @{$folded_closure{$from}}, $fold if $from < 256;
}
}
# Now having read all the lines, combine them into the full closure of each
# code point in the range by adding lists together that share a common element
foreach my $folded (keys %folded_closure) {
foreach my $from (grep { $_ < 256 } @{$folded_closure{$folded}}) {
push @{$folded_closure{$from}}, @{$folded_closure{$folded}};
}
}
my @bits; # Bit map for each code point
foreach my $folded (keys %folded_closure) {
$bits[$folded] = "_CC_NONLATIN1_FOLD" if grep { $_ > 255 }
@{$folded_closure{$folded}};
}
for my $ord (0..255) {
my $char = chr($ord);
utf8::upgrade($char); # Important to use Unicode semantics!
for my $property (@properties) {
my $name = $property;
# The property name that corresponds to this doesn't have a suffix.
# If is a latin1 version, no further checking is needed.
if (! ($name =~ s/_L1$//)) {
# Here, isn't an L1. It's either a special one or the suffix ends
# in _A. In the latter case, it's automatically false for
# non-ascii. The one current special is valid over the whole range.
next if $name =~ s/_A$// && $ord >= 128;
}
my $re;
if ($name eq 'PUNCT') {;
# Sadly, this is inconsistent: \pP and \pS for the ascii range,
# just \pP outside it.
$re = qr/\p{Punct}|[^\P{Symbol}\P{ASCII}]/;
} elsif ($name eq 'CHARNAME_CONT') {;
$re = qr/[-\w ():\xa0]/;
} elsif ($name eq 'SPACE') {;
$re = qr/\s/;
} elsif ($name eq 'IDFIRST') {
$re = qr/[_\p{Alpha}]/;
} elsif ($name eq 'PSXSPC') {
$re = qr/[\v\p{Space}]/;
} elsif ($name eq 'WORDCHAR') {
$re = qr/\w/;
} elsif ($name eq 'ALNUMC') {
# Like \w, but no underscore
$re = qr/\p{Alnum}/;
} elsif ($name eq 'OCTAL') {
$re = qr/[0-7]/;
} else { # The remainder have the same name and values as Unicode
$re = eval "qr/\\p{$name}/";
use Carp;
carp $@ if ! defined $re;
}
#print "$ord, $name $property, $re\n";
if ($char =~ $re) { # Add this property if matches
$bits[$ord] .= '|' if $bits[$ord];
$bits[$ord] .= "_CC_$property";
}
}
#print __LINE__, " $ord $char $bits[$ord]\n";
}
# Names of C0 controls
my @C0 = qw (
NUL
SOH
STX
ETX
EOT
ENQ
ACK
BEL
BS
HT
LF
VT
FF
CR
SO
SI
DLE
DC1
DC2
DC3
DC4
NAK
SYN
ETB
CAN
EOM
SUB
ESC
FS
GS
RS
US
);
# Names of C1 controls, plus the adjacent DEL
my @C1 = qw(
DEL
PAD
HOP
BPH
NBH
IND
NEL
SSA
ESA
HTS
HTJ
VTS
PLD
PLU
RI
SS2
SS3
DCS
PU1
PU2
STS
CCH
MW
SPA
EPA
SOS
SGC
SCI
CSI
ST
OSC
PM
APC
);
my $out_fh = open_new('l1_char_class_tab.h', '>',
{style => '*', by => $0, from => $file});
# Output the table using fairly short names for each char.
for my $ord (0..255) {
my $name;
if ($ord < 32) { # A C0 control
$name = $C0[$ord];
} elsif ($ord > 32 && $ord < 127) { # Graphic
$name = "'" . chr($ord) . "'";
} elsif ($ord >= 127 && $ord <= 0x9f) {
$name = $C1[$ord - 127]; # A C1 control + DEL
} else { # SPACE, or, if Latin1, shorten the name */
use charnames();
$name = charnames::viacode($ord);
$name =~ s/LATIN CAPITAL LETTER //
|| $name =~ s/LATIN SMALL LETTER (.*)/\L$1/;
}
printf $out_fh "/* U+%02X %s */ %s,\n", $ord, $name, $bits[$ord];
}
read_only_bottom_close_and_rename($out_fh)
|
