This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/mk_invlists.pl: White-space only
[perl5.git] / regen / mk_invlists.pl
CommitLineData
9d9177be
KW
1#!perl -w
2use 5.015;
3use strict;
4use warnings;
99f21fb9
KW
5use Unicode::UCD qw(prop_aliases
6 prop_values
7 prop_value_aliases
8 prop_invlist
9 prop_invmap search_invlist
10 );
9d9177be 11require 'regen/regen_lib.pl';
0c4ecf42 12require 'regen/charset_translations.pl';
9d9177be
KW
13
14# This program outputs charclass_invlists.h, which contains various inversion
15# lists in the form of C arrays that are to be used as-is for inversion lists.
16# Thus, the lists it contains are essentially pre-compiled, and need only a
17# light-weight fast wrapper to make them usable at run-time.
18
19# As such, this code knows about the internal structure of these lists, and
20# any change made to that has to be done here as well. A random number stored
21# in the headers is used to minimize the possibility of things getting
22# out-of-sync, or the wrong data structure being passed. Currently that
23# random number is:
99f21fb9
KW
24
25# charclass_invlists.h now also has a partial implementation of inversion
26# maps; enough to generate tables for the line break properties, such as GCB
27
0a07b44b 28my $VERSION_DATA_STRUCTURE_TYPE = 148565664;
9d9177be 29
99f21fb9
KW
30# integer or float
31my $numeric_re = qr/ ^ -? \d+ (:? \. \d+ )? $ /ax;
32
33# Matches valid C language enum names: begins with ASCII alphabetic, then any
34# ASCII \w
35my $enum_name_re = qr / ^ [[:alpha:]] \w* $ /ax;
36
9d9177be
KW
37my $out_fh = open_new('charclass_invlists.h', '>',
38 {style => '*', by => $0,
39 from => "Unicode::UCD"});
40
bffc0129 41my $in_file_pound_if = 0;
43b443dd 42
9d9177be
KW
43print $out_fh "/* See the generating file for comments */\n\n";
44
bffc0129
KW
45# The symbols generated by this program are all currently defined only in a
46# single dot c each. The code knows where most of them go, but this hash
47# gives overrides for the exceptions to the typical place
48my %exceptions_to_where_to_define =
49 ( NonL1_Perl_Non_Final_Folds => 'PERL_IN_REGCOMP_C',
50 AboveLatin1 => 'PERL_IN_REGCOMP_C',
51 Latin1 => 'PERL_IN_REGCOMP_C',
52 UpperLatin1 => 'PERL_IN_REGCOMP_C',
53 _Perl_Any_Folds => 'PERL_IN_REGCOMP_C',
54 _Perl_Folds_To_Multi_Char => 'PERL_IN_REGCOMP_C',
55 _Perl_IDCont => 'PERL_IN_UTF8_C',
56 _Perl_IDStart => 'PERL_IN_UTF8_C',
57 );
015bb97c 58
f79a09fc
KW
59# This hash contains the properties with enums that have hard-coded references
60# to them in C code. Its only use is to make sure that if perl is compiled
61# with an older Unicode data set, that all the enum values the code is
62# expecting will still be in the enum typedef. Thus the code doesn't have to
63# change. The Unicode version won't have any code points that have these enum
64# values, so the code that handles them will not get exercised. This is far
65# better than having to #ifdef things.
66my %hard_coded_enums =
67 ( gcb => [
68 'Control',
69 'CR',
70 'Extend',
71 'L',
72 'LF',
73 'LV',
74 'LVT',
75 'Other',
76 'Prepend',
77 'Regional_Indicator',
78 'SpacingMark',
79 'T',
80 'V',
81 ],
82 sb => [
83 'ATerm',
84 'Close',
85 'CR',
86 'Extend',
87 'Format',
88 'LF',
89 'Lower',
90 'Numeric',
91 'OLetter',
92 'Other',
93 'SContinue',
94 'Sep',
95 'Sp',
96 'STerm',
97 'Upper',
98 ],
99 wb => [
100 'ALetter',
101 'CR',
102 'Double_Quote',
103 'Extend',
104 'ExtendNumLet',
105 'Format',
106 'Hebrew_Letter',
107 'Katakana',
108 'LF',
109 'MidLetter',
110 'MidNum',
111 'MidNumLet',
112 'Newline',
113 'Numeric',
114 'Other',
115 'Regional_Indicator',
116 'Single_Quote',
117 'UNKNOWN',
118 ],
119);
120
99f21fb9
KW
121my @a2n;
122
123sub uniques {
124 # Returns non-duplicated input values. From "Perl Best Practices:
125 # Encapsulated Cleverness". p. 455 in first edition.
126
127 my %seen;
128 return grep { ! $seen{$_}++ } @_;
129}
130
131sub a2n($) {
132 my $cp = shift;
133
134 # Returns the input Unicode code point translated to native.
135
136 return $cp if $cp !~ $numeric_re || $cp > 255;
137 return $a2n[$cp];
138}
139
bffc0129
KW
140sub end_file_pound_if {
141 if ($in_file_pound_if) {
142 print $out_fh "\n#endif\t/* $in_file_pound_if */\n";
143 $in_file_pound_if = 0;
144 }
145}
146
147sub switch_pound_if ($$) {
148 my $name = shift;
149 my $new_pound_if = shift;
150
151 # Switch to new #if given by the 2nd argument. If there is an override
152 # for this, it instead switches to that. The 1st argument is the
153 # static's name, used to look up the overrides
154
155 if (exists $exceptions_to_where_to_define{$name}) {
156 $new_pound_if = $exceptions_to_where_to_define{$name};
157 }
158
159 # Exit current #if if the new one is different from the old
160 if ($in_file_pound_if
161 && $in_file_pound_if !~ /$new_pound_if/)
162 {
163 end_file_pound_if;
164 }
165
166 # Enter new #if, if not already in it.
167 if (! $in_file_pound_if) {
168 $in_file_pound_if = "defined($new_pound_if)";
169 print $out_fh "\n#if $in_file_pound_if\n";
43b443dd
KW
170 }
171}
172
0c4ecf42 173sub output_invlist ($$;$) {
9d9177be
KW
174 my $name = shift;
175 my $invlist = shift; # Reference to inversion list array
0c4ecf42 176 my $charset = shift // ""; # name of character set for comment
9d9177be 177
76d3994c 178 die "No inversion list for $name" unless defined $invlist
ad85f59a 179 && ref $invlist eq 'ARRAY';
76d3994c 180
9d9177be
KW
181 # Output the inversion list $invlist using the name $name for it.
182 # It is output in the exact internal form for inversion lists.
183
a0316a6c
KW
184 # Is the last element of the header 0, or 1 ?
185 my $zero_or_one = 0;
ad85f59a 186 if (@$invlist && $invlist->[0] != 0) {
a0316a6c 187 unshift @$invlist, 0;
9d9177be
KW
188 $zero_or_one = 1;
189 }
0a07b44b 190 my $count = @$invlist;
9d9177be 191
bffc0129 192 switch_pound_if ($name, 'PERL_IN_PERL_C');
43b443dd 193
0c4ecf42
KW
194 print $out_fh "\nstatic const UV ${name}_invlist[] = {";
195 print $out_fh " /* for $charset */" if $charset;
196 print $out_fh "\n";
9d9177be 197
a0316a6c 198 print $out_fh "\t$count,\t/* Number of elements */\n";
9d9177be
KW
199 print $out_fh "\t$VERSION_DATA_STRUCTURE_TYPE, /* Version and data structure type */\n";
200 print $out_fh "\t", $zero_or_one,
a0316a6c
KW
201 ",\t/* 0 if the list starts at 0;",
202 "\n\t\t 1 if it starts at the element beyond 0 */\n";
9d9177be
KW
203
204 # The main body are the UVs passed in to this routine. Do the final
205 # element separately
47d53124
KW
206 for my $i (0 .. @$invlist - 1) {
207 printf $out_fh "\t0x%X", $invlist->[$i];
208 print $out_fh "," if $i < @$invlist - 1;
209 print $out_fh "\n";
9d9177be
KW
210 }
211
9d9177be
KW
212 print $out_fh "};\n";
213}
214
99f21fb9
KW
215sub output_invmap ($$$$$$$) {
216 my $name = shift;
217 my $invmap = shift; # Reference to inversion map array
218 my $prop_name = shift;
219 my $input_format = shift; # The inversion map's format
220 my $default = shift; # The property value for code points who
221 # otherwise don't have a value specified.
222 my $extra_enums = shift; # comma-separated list of our additions to the
223 # property's standard possible values
224 my $charset = shift // ""; # name of character set for comment
225
226 # Output the inversion map $invmap for property $prop_name, but use $name
227 # as the actual data structure's name.
228
229 my $count = @$invmap;
230
231 my $output_format;
232 my $declaration_type;
233 my %enums;
234 my $name_prefix;
235
236 if ($input_format eq 's') {
237 $prop_name = (prop_aliases($prop_name))[1]; # Get full name
f79a09fc 238 my $short_name = (prop_aliases($prop_name))[0];
99f21fb9
KW
239 my @enums = prop_values($prop_name);
240 if (! @enums) {
241 die "Only enum properties are currently handled; '$prop_name' isn't one";
242 }
243 else {
244
f79a09fc 245 # Convert short names to long
99f21fb9 246 @enums = map { (prop_value_aliases($prop_name, $_))[1] } @enums;
f79a09fc
KW
247
248 my @expected_enums = @{$hard_coded_enums{lc $short_name}};
249 die 'You need to update %hard_coded_enums to reflect new entries in this Unicode version'
250 if @expected_enums < @enums;
251
252 # Remove the enums found in the input from the ones we expect
253 for (my $i = @expected_enums - 1; $i >= 0; $i--) {
254 splice(@expected_enums, $i, 1)
255 if grep { $expected_enums[$i] eq $_ } @enums;
256 }
257
258 # The ones remaining must be because we're using an older
259 # Unicode version. Add them to the list.
260 push @enums, @expected_enums;
261
262 # Add in the extra values coded into this program, and sort.
99f21fb9
KW
263 push @enums, split /,/, $extra_enums if $extra_enums ne "";
264 @enums = sort @enums;
265
266 # Assign a value to each element of the enum. The default
267 # value always gets 0; the others are arbitrarily assigned.
268 my $enum_val = 0;
269 $default = prop_value_aliases($prop_name, $default);
270 $enums{$default} = $enum_val++;
271 for my $enum (@enums) {
272 $enums{$enum} = $enum_val++ unless exists $enums{$enum};
273 }
274 }
275
bffc0129
KW
276 # Inversion map stuff is currently used only by regexec
277 switch_pound_if($name, 'PERL_IN_REGEXEC_C');
99f21fb9
KW
278 {
279
99f21fb9
KW
280 # The short names tend to be two lower case letters, but it looks
281 # better for those if they are upper. XXX
282 $short_name = uc($short_name) if length($short_name) < 3
283 || substr($short_name, 0, 1) =~ /[[:lower:]]/;
85e5f08b 284 $name_prefix = "${short_name}_";
99f21fb9
KW
285 my $enum_count = keys %enums;
286 print $out_fh "\n#define ${name_prefix}ENUM_COUNT ", scalar keys %enums, "\n";
287
288 print $out_fh "\ntypedef enum {\n";
289 print $out_fh "\t${name_prefix}$default = $enums{$default},\n";
290 delete $enums{$default};
291 foreach my $enum (sort { $a cmp $b } keys %enums) {
292 print $out_fh "\t${name_prefix}$enum = $enums{$enum}";
293 print $out_fh "," if $enums{$enum} < $enum_count - 1;
294 print $out_fh "\n";
295 }
296 $declaration_type = "${name_prefix}enum";
297 print $out_fh "} $declaration_type;\n";
298
299 $output_format = "${name_prefix}%s";
300 }
301 }
302 else {
303 die "'$input_format' invmap() format for '$prop_name' unimplemented";
304 }
305
306 die "No inversion map for $prop_name" unless defined $invmap
307 && ref $invmap eq 'ARRAY'
308 && $count;
309
310 print $out_fh "\nstatic const $declaration_type ${name}_invmap[] = {";
311 print $out_fh " /* for $charset */" if $charset;
312 print $out_fh "\n";
313
314 # The main body are the scalars passed in to this routine.
315 for my $i (0 .. $count - 1) {
316 my $element = $invmap->[$i];
317 $element = $name_prefix . prop_value_aliases($prop_name, $element);
318 print $out_fh "\t$element";
319 print $out_fh "," if $i < $count - 1;
320 print $out_fh "\n";
321 }
322 print $out_fh "};\n";
99f21fb9
KW
323}
324
5a7e5385 325sub mk_invlist_from_sorted_cp_list {
a02047bf
KW
326
327 # Returns an inversion list constructed from the sorted input array of
328 # code points
329
330 my $list_ref = shift;
331
99f21fb9
KW
332 return unless @$list_ref;
333
a02047bf
KW
334 # Initialize to just the first element
335 my @invlist = ( $list_ref->[0], $list_ref->[0] + 1);
336
337 # For each succeeding element, if it extends the previous range, adjust
338 # up, otherwise add it.
339 for my $i (1 .. @$list_ref - 1) {
340 if ($invlist[-1] == $list_ref->[$i]) {
341 $invlist[-1]++;
342 }
343 else {
344 push @invlist, $list_ref->[$i], $list_ref->[$i] + 1;
345 }
346 }
347 return @invlist;
348}
349
350# Read in the Case Folding rules, and construct arrays of code points for the
351# properties we need.
352my ($cp_ref, $folds_ref, $format) = prop_invmap("Case_Folding");
353die "Could not find inversion map for Case_Folding" unless defined $format;
354die "Incorrect format '$format' for Case_Folding inversion map"
355 unless $format eq 'al';
356my @has_multi_char_fold;
357my @is_non_final_fold;
358
359for my $i (0 .. @$folds_ref - 1) {
360 next unless ref $folds_ref->[$i]; # Skip single-char folds
361 push @has_multi_char_fold, $cp_ref->[$i];
362
b6a6e956 363 # Add to the non-finals list each code point that is in a non-final
a02047bf
KW
364 # position
365 for my $j (0 .. @{$folds_ref->[$i]} - 2) {
366 push @is_non_final_fold, $folds_ref->[$i][$j]
367 unless grep { $folds_ref->[$i][$j] == $_ } @is_non_final_fold;
368 }
369}
370
a02047bf
KW
371sub _Perl_Non_Final_Folds {
372 @is_non_final_fold = sort { $a <=> $b } @is_non_final_fold;
5a7e5385 373 return mk_invlist_from_sorted_cp_list(\@is_non_final_fold);
a02047bf
KW
374}
375
99f21fb9
KW
376sub prop_name_for_cmp ($) { # Sort helper
377 my $name = shift;
378
379 # Returns the input lowercased, with non-alphas removed, as well as
380 # everything starting with a comma
381
382 $name =~ s/,.*//;
383 $name =~ s/[[:^alpha:]]//g;
384 return lc $name;
385}
386
892d8259 387sub UpperLatin1 {
5a7e5385 388 return mk_invlist_from_sorted_cp_list([ 128 .. 255 ]);
892d8259
KW
389}
390
9d9177be
KW
391output_invlist("Latin1", [ 0, 256 ]);
392output_invlist("AboveLatin1", [ 256 ]);
393
bffc0129 394end_file_pound_if;
43b443dd 395
3f427fd9
KW
396# We construct lists for all the POSIX and backslash sequence character
397# classes in two forms:
398# 1) ones which match only in the ASCII range
399# 2) ones which match either in the Latin1 range, or the entire Unicode range
400#
401# These get compiled in, and hence affect the memory footprint of every Perl
402# program, even those not using Unicode. To minimize the size, currently
403# the Latin1 version is generated for the beyond ASCII range except for those
404# lists that are quite small for the entire range, such as for \s, which is 22
405# UVs long plus 4 UVs (currently) for the header.
406#
407# To save even more memory, the ASCII versions could be derived from the
408# larger ones at runtime, saving some memory (minus the expense of the machine
409# instructions to do so), but these are all small anyway, so their total is
410# about 100 UVs.
411#
412# In the list of properties below that get generated, the L1 prefix is a fake
413# property that means just the Latin1 range of the full property (whose name
414# has an X prefix instead of L1).
a02047bf
KW
415#
416# An initial & means to use the subroutine from this file instead of an
417# official inversion list.
3f427fd9 418
0c4ecf42
KW
419for my $charset (get_supported_code_pages()) {
420 print $out_fh "\n" . get_conditional_compile_line_start($charset);
421
99f21fb9
KW
422 @a2n = @{get_a2n($charset)};
423 no warnings 'qw';
424 # Ignore non-alpha in sort
425 for my $prop (sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) } qw(
1c8c3428
KW
426 ASCII
427 Cased
428 VertSpace
429 XPerlSpace
430 XPosixAlnum
431 XPosixAlpha
432 XPosixBlank
433 XPosixCntrl
434 XPosixDigit
435 XPosixGraph
436 XPosixLower
437 XPosixPrint
438 XPosixPunct
439 XPosixSpace
440 XPosixUpper
441 XPosixWord
442 XPosixXDigit
443 _Perl_Any_Folds
444 &NonL1_Perl_Non_Final_Folds
445 _Perl_Folds_To_Multi_Char
446 &UpperLatin1
447 _Perl_IDStart
448 _Perl_IDCont
0e0b9356 449 Grapheme_Cluster_Break,EDGE
53255578 450 Word_Break,EDGE,UNKNOWN
d3e558c4 451 Sentence_Break,EDGE
1c8c3428 452 )
0f5e3c71
KW
453 ) {
454
455 # For the Latin1 properties, we change to use the eXtended version of the
456 # base property, then go through the result and get rid of everything not
457 # in Latin1 (above 255). Actually, we retain the element for the range
458 # that crosses the 255/256 boundary if it is one that matches the
459 # property. For example, in the Word property, there is a range of code
460 # points that start at U+00F8 and goes through U+02C1. Instead of
461 # artificially cutting that off at 256 because 256 is the first code point
462 # above Latin1, we let the range go to its natural ending. That gives us
463 # extra information with no added space taken. But if the range that
464 # crosses the boundary is one that doesn't match the property, we don't
465 # start a new range above 255, as that could be construed as going to
466 # infinity. For example, the Upper property doesn't include the character
467 # at 255, but does include the one at 256. We don't include the 256 one.
468 my $prop_name = $prop;
469 my $is_local_sub = $prop_name =~ s/^&//;
99f21fb9
KW
470 my $extra_enums = "";
471 $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x;
0f5e3c71
KW
472 my $lookup_prop = $prop_name;
473 my $l1_only = ($lookup_prop =~ s/^L1Posix/XPosix/
474 or $lookup_prop =~ s/^L1//);
475 my $nonl1_only = 0;
476 $nonl1_only = $lookup_prop =~ s/^NonL1// unless $l1_only;
99f21fb9 477 ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x;
0f5e3c71
KW
478
479 my @invlist;
99f21fb9
KW
480 my @invmap;
481 my $map_format;
482 my $map_default;
483 my $maps_to_code_point;
484 my $to_adjust;
0f5e3c71
KW
485 if ($is_local_sub) {
486 @invlist = eval $lookup_prop;
487 }
488 else {
489 @invlist = prop_invlist($lookup_prop, '_perl_core_internal_ok');
99f21fb9 490 if (! @invlist) {
99f21fb9 491
ad85f59a
KW
492 # If couldn't find a non-empty inversion list, see if it is
493 # instead an inversion map
494 my ($list_ref, $map_ref, $format, $default)
99f21fb9 495 = prop_invmap($lookup_prop, '_perl_core_internal_ok');
ad85f59a
KW
496 if (! $list_ref) {
497 # An empty return here could mean an unknown property, or
498 # merely that the original inversion list is empty. Call
499 # in scalar context to differentiate
500 my $count = prop_invlist($lookup_prop,
501 '_perl_core_internal_ok');
502 die "Could not find inversion list for '$lookup_prop'"
503 unless defined $count;
504 }
505 else {
18b852b3
KW
506 @invlist = @$list_ref;
507 @invmap = @$map_ref;
508 $map_format = $format;
509 $map_default = $default;
510 $maps_to_code_point = $map_format =~ /x/;
511 $to_adjust = $map_format =~ /a/;
ad85f59a 512 }
99f21fb9 513 }
0f5e3c71 514 }
ad85f59a
KW
515
516
517 # Short-circuit an empty inversion list.
518 if (! @invlist) {
519 output_invlist($prop_name, \@invlist, $charset);
520 next;
521 }
ceb1de32 522
99f21fb9
KW
523 # Re-order the Unicode code points to native ones for this platform.
524 # This is only needed for code points below 256, because native code
525 # points are only in that range. For inversion maps of properties
526 # where the mappings are adjusted (format =~ /a/), this reordering
527 # could mess up the adjustment pattern that was in the input, so that
528 # has to be dealt with.
529 #
530 # And inversion maps that map to code points need to eventually have
531 # all those code points remapped to native, and it's better to do that
532 # here, going through the whole list not just those below 256. This
533 # is because some inversion maps have adjustments (format =~ /a/)
534 # which may be affected by the reordering. This code needs to be done
535 # both for when we are translating the inversion lists for < 256, and
536 # for the inversion maps for everything. By doing both in this loop,
537 # we can share that code.
538 #
539 # So, we go through everything for an inversion map to code points;
540 # otherwise, we can skip any remapping at all if we are going to
541 # output only the above-Latin1 values, or if the range spans the whole
542 # of 0..256, as the remap will also include all of 0..256 (256 not
543 # 255 because a re-ordering could cause 256 to need to be in the same
544 # range as 255.)
545 if ((@invmap && $maps_to_code_point)
546 || (! $nonl1_only || ($invlist[0] < 256
547 && ! ($invlist[0] == 0 && $invlist[1] > 256))))
ceb1de32 548 {
fb4554ea 549
99f21fb9 550 if (! @invmap) { # Straight inversion list
fb4554ea
KW
551 # Look at all the ranges that start before 257.
552 my @latin1_list;
553 while (@invlist) {
554 last if $invlist[0] > 256;
555 my $upper = @invlist > 1
556 ? $invlist[1] - 1 # In range
8a6c81cf
KW
557
558 # To infinity. You may want to stop much much
559 # earlier; going this high may expose perl
560 # deficiencies with very large numbers.
561 : $Unicode::UCD::MAX_CP;
fb4554ea 562 for my $j ($invlist[0] .. $upper) {
99f21fb9 563 push @latin1_list, a2n($j);
0f5e3c71 564 }
fb4554ea
KW
565
566 shift @invlist; # Shift off the range that's in the list
567 shift @invlist; # Shift off the range not in the list
0c4ecf42 568 }
fb4554ea
KW
569
570 # Here @invlist contains all the ranges in the original that start
571 # at code points above 256, and @latin1_list contains all the
572 # native code points for ranges that start with a Unicode code
573 # point below 257. We sort the latter and convert it to inversion
574 # list format. Then simply prepend it to the list of the higher
575 # code points.
576 @latin1_list = sort { $a <=> $b } @latin1_list;
5a7e5385 577 @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list);
fb4554ea 578 unshift @invlist, @latin1_list;
99f21fb9
KW
579 }
580 else { # Is an inversion map
581
582 # This is a similar procedure as plain inversion list, but has
583 # multiple buckets. A plain inversion list just has two
584 # buckets, 1) 'in' the list; and 2) 'not' in the list, and we
585 # pretty much can ignore the 2nd bucket, as it is completely
586 # defined by the 1st. But here, what we do is create buckets
587 # which contain the code points that map to each, translated
588 # to native and turned into an inversion list. Thus each
589 # bucket is an inversion list of native code points that map
590 # to it or don't map to it. We use these to create an
591 # inversion map for the whole property.
592
593 # As mentioned earlier, we use this procedure to not just
594 # remap the inversion list to native values, but also the maps
595 # of code points to native ones. In the latter case we have
596 # to look at the whole of the inversion map (or at least to
597 # above Unicode; as the maps of code points above that should
598 # all be to the default).
599 my $upper_limit = ($maps_to_code_point) ? 0x10FFFF : 256;
600
601 my %mapped_lists; # A hash whose keys are the buckets.
602 while (@invlist) {
603 last if $invlist[0] > $upper_limit;
604
605 # This shouldn't actually happen, as prop_invmap() returns
606 # an extra element at the end that is beyond $upper_limit
607 die "inversion map that extends to infinity is unimplemented" unless @invlist > 1;
608
609 my $bucket;
610
611 # A hash key can't be a ref (we are only expecting arrays
612 # of scalars here), so convert any such to a string that
613 # will be converted back later (using a vertical tab as
614 # the separator). Even if the mapping is to code points,
615 # we don't translate to native here because the code
616 # output_map() calls to output these arrays assumes the
617 # input is Unicode, not native.
618 if (ref $invmap[0]) {
619 $bucket = join "\cK", @{$invmap[0]};
620 }
621 elsif ($maps_to_code_point && $invmap[0] =~ $numeric_re) {
622
623 # Do convert to native for maps to single code points.
624 # There are some properties that have a few outlier
625 # maps that aren't code points, so the above test
626 # skips those.
627 $bucket = a2n($invmap[0]);
628 } else {
629 $bucket = $invmap[0];
630 }
631
632 # We now have the bucket that all code points in the range
633 # map to, though possibly they need to be adjusted. Go
634 # through the range and put each translated code point in
635 # it into its bucket.
636 my $base_map = $invmap[0];
637 for my $j ($invlist[0] .. $invlist[1] - 1) {
638 if ($to_adjust
639 # The 1st code point doesn't need adjusting
640 && $j > $invlist[0]
641
642 # Skip any non-numeric maps: these are outliers
643 # that aren't code points.
644 && $base_map =~ $numeric_re
645
646 # 'ne' because the default can be a string
647 && $base_map ne $map_default)
648 {
649 # We adjust, by incrementing each the bucket and
650 # the map. For code point maps, translate to
651 # native
652 $base_map++;
653 $bucket = ($maps_to_code_point)
654 ? a2n($base_map)
655 : $base_map;
656 }
657
658 # Add the native code point to the bucket for the
659 # current map
660 push @{$mapped_lists{$bucket}}, a2n($j);
661 } # End of loop through all code points in the range
662
663 # Get ready for the next range
664 shift @invlist;
665 shift @invmap;
666 } # End of loop through all ranges in the map.
667
668 # Here, @invlist and @invmap retain all the ranges from the
669 # originals that start with code points above $upper_limit.
670 # Each bucket in %mapped_lists contains all the code points
671 # that map to that bucket. If the bucket is for a map to a
672 # single code point is a single code point, the bucket has
673 # been converted to native. If something else (including
674 # multiple code points), no conversion is done.
675 #
676 # Now we recreate the inversion map into %xlated, but this
677 # time for the native character set.
678 my %xlated;
679 foreach my $bucket (keys %mapped_lists) {
680
681 # Sort and convert this bucket to an inversion list. The
682 # result will be that ranges that start with even-numbered
683 # indexes will be for code points that map to this bucket;
684 # odd ones map to some other bucket, and are discarded
685 # below.
686 @{$mapped_lists{$bucket}}
687 = sort{ $a <=> $b} @{$mapped_lists{$bucket}};
688 @{$mapped_lists{$bucket}}
689 = mk_invlist_from_sorted_cp_list(\@{$mapped_lists{$bucket}});
690
691 # Add each even-numbered range in the bucket to %xlated;
692 # so that the keys of %xlated become the range start code
693 # points, and the values are their corresponding maps.
694 while (@{$mapped_lists{$bucket}}) {
695 my $range_start = $mapped_lists{$bucket}->[0];
696 if ($bucket =~ /\cK/) {
697 @{$xlated{$range_start}} = split /\cK/, $bucket;
698 }
699 else {
700 $xlated{$range_start} = $bucket;
701 }
702 shift @{$mapped_lists{$bucket}}; # Discard odd ranges
703 shift @{$mapped_lists{$bucket}}; # Get ready for next
704 # iteration
705 }
706 } # End of loop through all the buckets.
707
708 # Here %xlated's keys are the range starts of all the code
709 # points in the inversion map. Construct an inversion list
710 # from them.
711 my @new_invlist = sort { $a <=> $b } keys %xlated;
712
713 # If the list is adjusted, we want to munge this list so that
714 # we only have one entry for where consecutive code points map
715 # to consecutive values. We just skip the subsequent entries
716 # where this is the case.
717 if ($to_adjust) {
718 my @temp;
719 for my $i (0 .. @new_invlist - 1) {
720 next if $i > 0
721 && $new_invlist[$i-1] + 1 == $new_invlist[$i]
722 && $xlated{$new_invlist[$i-1]} =~ $numeric_re
723 && $xlated{$new_invlist[$i]} =~ $numeric_re
724 && $xlated{$new_invlist[$i-1]} + 1 == $xlated{$new_invlist[$i]};
725 push @temp, $new_invlist[$i];
726 }
727 @new_invlist = @temp;
728 }
729
730 # The inversion map comes from %xlated's values. We can
731 # unshift each onto the front of the untouched portion, in
732 # reverse order of the portion we did process.
733 foreach my $start (reverse @new_invlist) {
734 unshift @invmap, $xlated{$start};
735 }
736
737 # Finally prepend the inversion list we have just constructed to the
738 # one that contains anything we didn't process.
739 unshift @invlist, @new_invlist;
740 }
741 }
742
743 # prop_invmap() returns an extra final entry, which we can now
744 # discard.
745 if (@invmap) {
746 pop @invlist;
747 pop @invmap;
ceb1de32 748 }
0f5e3c71
KW
749
750 if ($l1_only) {
99f21fb9 751 die "Unimplemented to do a Latin-1 only inversion map" if @invmap;
0f5e3c71
KW
752 for my $i (0 .. @invlist - 1 - 1) {
753 if ($invlist[$i] > 255) {
754
755 # In an inversion list, even-numbered elements give the code
756 # points that begin ranges that match the property;
757 # odd-numbered give ones that begin ranges that don't match.
758 # If $i is odd, we are at the first code point above 255 that
759 # doesn't match, which means the range it is ending does
760 # match, and crosses the 255/256 boundary. We want to include
761 # this ending point, so increment $i, so the splice below
762 # includes it. Conversely, if $i is even, it is the first
763 # code point above 255 that matches, which means there was no
764 # matching range that crossed the boundary, and we don't want
765 # to include this code point, so splice before it.
766 $i++ if $i % 2 != 0;
767
768 # Remove everything past this.
769 splice @invlist, $i;
99f21fb9 770 splice @invmap, $i if @invmap;
0f5e3c71
KW
771 last;
772 }
0c4ecf42
KW
773 }
774 }
0f5e3c71
KW
775 elsif ($nonl1_only) {
776 my $found_nonl1 = 0;
777 for my $i (0 .. @invlist - 1 - 1) {
778 next if $invlist[$i] < 256;
779
780 # Here, we have the first element in the array that indicates an
781 # element above Latin1. Get rid of all previous ones.
782 splice @invlist, 0, $i;
99f21fb9 783 splice @invmap, 0, $i if @invmap;
0f5e3c71
KW
784
785 # If this one's index is not divisible by 2, it means that this
786 # element is inverting away from being in the list, which means
99f21fb9
KW
787 # all code points from 256 to this one are in this list (or
788 # map to the default for inversion maps)
789 if ($i % 2 != 0) {
790 unshift @invlist, 256;
791 unshift @invmap, $map_default if @invmap;
792 }
0f5e3c71 793 $found_nonl1 = 1;
3f427fd9
KW
794 last;
795 }
0f5e3c71 796 die "No non-Latin1 code points in $lookup_prop" unless $found_nonl1;
3f427fd9 797 }
3f427fd9 798
0f5e3c71 799 output_invlist($prop_name, \@invlist, $charset);
99f21fb9 800 output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, $map_default, $extra_enums, $charset) if @invmap;
0f5e3c71 801 }
bffc0129 802 end_file_pound_if;
0c4ecf42 803 print $out_fh "\n" . get_conditional_compile_line_end();
9d9177be
KW
804}
805
2308ab83 806my $sources_list = "lib/unicore/mktables.lst";
216b41c2
KW
807my @sources = ($0, qw(lib/unicore/mktables
808 lib/Unicode/UCD.pm
809 regen/charset_translations.pl
810 ));
9a3da3ad
FC
811{
812 # Depend on mktables’ own sources. It’s a shorter list of files than
813 # those that Unicode::UCD uses.
2308ab83
KW
814 if (! open my $mktables_list, $sources_list) {
815
816 # This should force a rebuild once $sources_list exists
817 push @sources, $sources_list;
818 }
819 else {
820 while(<$mktables_list>) {
821 last if /===/;
822 chomp;
823 push @sources, "lib/unicore/$_" if /^[^#]/;
824 }
9a3da3ad
FC
825 }
826}
827read_only_bottom_close_and_rename($out_fh, \@sources)