This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/mk_invlists.pl: Handle early Unicodes CF
[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"
347b9066
KW
355 unless $format eq 'al'
356 || $format eq 'a';
a02047bf
KW
357my @has_multi_char_fold;
358my @is_non_final_fold;
359
360for my $i (0 .. @$folds_ref - 1) {
361 next unless ref $folds_ref->[$i]; # Skip single-char folds
362 push @has_multi_char_fold, $cp_ref->[$i];
363
b6a6e956 364 # Add to the non-finals list each code point that is in a non-final
a02047bf
KW
365 # position
366 for my $j (0 .. @{$folds_ref->[$i]} - 2) {
367 push @is_non_final_fold, $folds_ref->[$i][$j]
368 unless grep { $folds_ref->[$i][$j] == $_ } @is_non_final_fold;
369 }
370}
371
a02047bf
KW
372sub _Perl_Non_Final_Folds {
373 @is_non_final_fold = sort { $a <=> $b } @is_non_final_fold;
5a7e5385 374 return mk_invlist_from_sorted_cp_list(\@is_non_final_fold);
a02047bf
KW
375}
376
99f21fb9
KW
377sub prop_name_for_cmp ($) { # Sort helper
378 my $name = shift;
379
380 # Returns the input lowercased, with non-alphas removed, as well as
381 # everything starting with a comma
382
383 $name =~ s/,.*//;
384 $name =~ s/[[:^alpha:]]//g;
385 return lc $name;
386}
387
892d8259 388sub UpperLatin1 {
5a7e5385 389 return mk_invlist_from_sorted_cp_list([ 128 .. 255 ]);
892d8259
KW
390}
391
9d9177be
KW
392output_invlist("Latin1", [ 0, 256 ]);
393output_invlist("AboveLatin1", [ 256 ]);
394
bffc0129 395end_file_pound_if;
43b443dd 396
3f427fd9
KW
397# We construct lists for all the POSIX and backslash sequence character
398# classes in two forms:
399# 1) ones which match only in the ASCII range
400# 2) ones which match either in the Latin1 range, or the entire Unicode range
401#
402# These get compiled in, and hence affect the memory footprint of every Perl
403# program, even those not using Unicode. To minimize the size, currently
404# the Latin1 version is generated for the beyond ASCII range except for those
405# lists that are quite small for the entire range, such as for \s, which is 22
406# UVs long plus 4 UVs (currently) for the header.
407#
408# To save even more memory, the ASCII versions could be derived from the
409# larger ones at runtime, saving some memory (minus the expense of the machine
410# instructions to do so), but these are all small anyway, so their total is
411# about 100 UVs.
412#
413# In the list of properties below that get generated, the L1 prefix is a fake
414# property that means just the Latin1 range of the full property (whose name
415# has an X prefix instead of L1).
a02047bf
KW
416#
417# An initial & means to use the subroutine from this file instead of an
418# official inversion list.
3f427fd9 419
0c4ecf42
KW
420for my $charset (get_supported_code_pages()) {
421 print $out_fh "\n" . get_conditional_compile_line_start($charset);
422
99f21fb9
KW
423 @a2n = @{get_a2n($charset)};
424 no warnings 'qw';
425 # Ignore non-alpha in sort
426 for my $prop (sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) } qw(
1c8c3428
KW
427 ASCII
428 Cased
429 VertSpace
430 XPerlSpace
431 XPosixAlnum
432 XPosixAlpha
433 XPosixBlank
434 XPosixCntrl
435 XPosixDigit
436 XPosixGraph
437 XPosixLower
438 XPosixPrint
439 XPosixPunct
440 XPosixSpace
441 XPosixUpper
442 XPosixWord
443 XPosixXDigit
444 _Perl_Any_Folds
445 &NonL1_Perl_Non_Final_Folds
446 _Perl_Folds_To_Multi_Char
447 &UpperLatin1
448 _Perl_IDStart
449 _Perl_IDCont
0e0b9356 450 Grapheme_Cluster_Break,EDGE
53255578 451 Word_Break,EDGE,UNKNOWN
d3e558c4 452 Sentence_Break,EDGE
1c8c3428 453 )
0f5e3c71
KW
454 ) {
455
456 # For the Latin1 properties, we change to use the eXtended version of the
457 # base property, then go through the result and get rid of everything not
458 # in Latin1 (above 255). Actually, we retain the element for the range
459 # that crosses the 255/256 boundary if it is one that matches the
460 # property. For example, in the Word property, there is a range of code
461 # points that start at U+00F8 and goes through U+02C1. Instead of
462 # artificially cutting that off at 256 because 256 is the first code point
463 # above Latin1, we let the range go to its natural ending. That gives us
464 # extra information with no added space taken. But if the range that
465 # crosses the boundary is one that doesn't match the property, we don't
466 # start a new range above 255, as that could be construed as going to
467 # infinity. For example, the Upper property doesn't include the character
468 # at 255, but does include the one at 256. We don't include the 256 one.
469 my $prop_name = $prop;
470 my $is_local_sub = $prop_name =~ s/^&//;
99f21fb9
KW
471 my $extra_enums = "";
472 $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x;
0f5e3c71
KW
473 my $lookup_prop = $prop_name;
474 my $l1_only = ($lookup_prop =~ s/^L1Posix/XPosix/
475 or $lookup_prop =~ s/^L1//);
476 my $nonl1_only = 0;
477 $nonl1_only = $lookup_prop =~ s/^NonL1// unless $l1_only;
99f21fb9 478 ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x;
0f5e3c71
KW
479
480 my @invlist;
99f21fb9
KW
481 my @invmap;
482 my $map_format;
483 my $map_default;
484 my $maps_to_code_point;
485 my $to_adjust;
0f5e3c71
KW
486 if ($is_local_sub) {
487 @invlist = eval $lookup_prop;
488 }
489 else {
490 @invlist = prop_invlist($lookup_prop, '_perl_core_internal_ok');
99f21fb9 491 if (! @invlist) {
99f21fb9 492
ad85f59a
KW
493 # If couldn't find a non-empty inversion list, see if it is
494 # instead an inversion map
495 my ($list_ref, $map_ref, $format, $default)
99f21fb9 496 = prop_invmap($lookup_prop, '_perl_core_internal_ok');
ad85f59a
KW
497 if (! $list_ref) {
498 # An empty return here could mean an unknown property, or
499 # merely that the original inversion list is empty. Call
500 # in scalar context to differentiate
501 my $count = prop_invlist($lookup_prop,
502 '_perl_core_internal_ok');
503 die "Could not find inversion list for '$lookup_prop'"
504 unless defined $count;
505 }
506 else {
18b852b3
KW
507 @invlist = @$list_ref;
508 @invmap = @$map_ref;
509 $map_format = $format;
510 $map_default = $default;
511 $maps_to_code_point = $map_format =~ /x/;
512 $to_adjust = $map_format =~ /a/;
ad85f59a 513 }
99f21fb9 514 }
0f5e3c71 515 }
ad85f59a
KW
516
517
518 # Short-circuit an empty inversion list.
519 if (! @invlist) {
520 output_invlist($prop_name, \@invlist, $charset);
521 next;
522 }
ceb1de32 523
99f21fb9
KW
524 # Re-order the Unicode code points to native ones for this platform.
525 # This is only needed for code points below 256, because native code
526 # points are only in that range. For inversion maps of properties
527 # where the mappings are adjusted (format =~ /a/), this reordering
528 # could mess up the adjustment pattern that was in the input, so that
529 # has to be dealt with.
530 #
531 # And inversion maps that map to code points need to eventually have
532 # all those code points remapped to native, and it's better to do that
533 # here, going through the whole list not just those below 256. This
534 # is because some inversion maps have adjustments (format =~ /a/)
535 # which may be affected by the reordering. This code needs to be done
536 # both for when we are translating the inversion lists for < 256, and
537 # for the inversion maps for everything. By doing both in this loop,
538 # we can share that code.
539 #
540 # So, we go through everything for an inversion map to code points;
541 # otherwise, we can skip any remapping at all if we are going to
542 # output only the above-Latin1 values, or if the range spans the whole
543 # of 0..256, as the remap will also include all of 0..256 (256 not
544 # 255 because a re-ordering could cause 256 to need to be in the same
545 # range as 255.)
546 if ((@invmap && $maps_to_code_point)
547 || (! $nonl1_only || ($invlist[0] < 256
548 && ! ($invlist[0] == 0 && $invlist[1] > 256))))
ceb1de32 549 {
fb4554ea 550
99f21fb9 551 if (! @invmap) { # Straight inversion list
fb4554ea
KW
552 # Look at all the ranges that start before 257.
553 my @latin1_list;
554 while (@invlist) {
555 last if $invlist[0] > 256;
556 my $upper = @invlist > 1
557 ? $invlist[1] - 1 # In range
8a6c81cf
KW
558
559 # To infinity. You may want to stop much much
560 # earlier; going this high may expose perl
561 # deficiencies with very large numbers.
562 : $Unicode::UCD::MAX_CP;
fb4554ea 563 for my $j ($invlist[0] .. $upper) {
99f21fb9 564 push @latin1_list, a2n($j);
0f5e3c71 565 }
fb4554ea
KW
566
567 shift @invlist; # Shift off the range that's in the list
568 shift @invlist; # Shift off the range not in the list
0c4ecf42 569 }
fb4554ea
KW
570
571 # Here @invlist contains all the ranges in the original that start
572 # at code points above 256, and @latin1_list contains all the
573 # native code points for ranges that start with a Unicode code
574 # point below 257. We sort the latter and convert it to inversion
575 # list format. Then simply prepend it to the list of the higher
576 # code points.
577 @latin1_list = sort { $a <=> $b } @latin1_list;
5a7e5385 578 @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list);
fb4554ea 579 unshift @invlist, @latin1_list;
99f21fb9
KW
580 }
581 else { # Is an inversion map
582
583 # This is a similar procedure as plain inversion list, but has
584 # multiple buckets. A plain inversion list just has two
585 # buckets, 1) 'in' the list; and 2) 'not' in the list, and we
586 # pretty much can ignore the 2nd bucket, as it is completely
587 # defined by the 1st. But here, what we do is create buckets
588 # which contain the code points that map to each, translated
589 # to native and turned into an inversion list. Thus each
590 # bucket is an inversion list of native code points that map
591 # to it or don't map to it. We use these to create an
592 # inversion map for the whole property.
593
594 # As mentioned earlier, we use this procedure to not just
595 # remap the inversion list to native values, but also the maps
596 # of code points to native ones. In the latter case we have
597 # to look at the whole of the inversion map (or at least to
598 # above Unicode; as the maps of code points above that should
599 # all be to the default).
600 my $upper_limit = ($maps_to_code_point) ? 0x10FFFF : 256;
601
602 my %mapped_lists; # A hash whose keys are the buckets.
603 while (@invlist) {
604 last if $invlist[0] > $upper_limit;
605
606 # This shouldn't actually happen, as prop_invmap() returns
607 # an extra element at the end that is beyond $upper_limit
608 die "inversion map that extends to infinity is unimplemented" unless @invlist > 1;
609
610 my $bucket;
611
612 # A hash key can't be a ref (we are only expecting arrays
613 # of scalars here), so convert any such to a string that
614 # will be converted back later (using a vertical tab as
615 # the separator). Even if the mapping is to code points,
616 # we don't translate to native here because the code
617 # output_map() calls to output these arrays assumes the
618 # input is Unicode, not native.
619 if (ref $invmap[0]) {
620 $bucket = join "\cK", @{$invmap[0]};
621 }
622 elsif ($maps_to_code_point && $invmap[0] =~ $numeric_re) {
623
624 # Do convert to native for maps to single code points.
625 # There are some properties that have a few outlier
626 # maps that aren't code points, so the above test
627 # skips those.
628 $bucket = a2n($invmap[0]);
629 } else {
630 $bucket = $invmap[0];
631 }
632
633 # We now have the bucket that all code points in the range
634 # map to, though possibly they need to be adjusted. Go
635 # through the range and put each translated code point in
636 # it into its bucket.
637 my $base_map = $invmap[0];
638 for my $j ($invlist[0] .. $invlist[1] - 1) {
639 if ($to_adjust
640 # The 1st code point doesn't need adjusting
641 && $j > $invlist[0]
642
643 # Skip any non-numeric maps: these are outliers
644 # that aren't code points.
645 && $base_map =~ $numeric_re
646
647 # 'ne' because the default can be a string
648 && $base_map ne $map_default)
649 {
650 # We adjust, by incrementing each the bucket and
651 # the map. For code point maps, translate to
652 # native
653 $base_map++;
654 $bucket = ($maps_to_code_point)
655 ? a2n($base_map)
656 : $base_map;
657 }
658
659 # Add the native code point to the bucket for the
660 # current map
661 push @{$mapped_lists{$bucket}}, a2n($j);
662 } # End of loop through all code points in the range
663
664 # Get ready for the next range
665 shift @invlist;
666 shift @invmap;
667 } # End of loop through all ranges in the map.
668
669 # Here, @invlist and @invmap retain all the ranges from the
670 # originals that start with code points above $upper_limit.
671 # Each bucket in %mapped_lists contains all the code points
672 # that map to that bucket. If the bucket is for a map to a
673 # single code point is a single code point, the bucket has
674 # been converted to native. If something else (including
675 # multiple code points), no conversion is done.
676 #
677 # Now we recreate the inversion map into %xlated, but this
678 # time for the native character set.
679 my %xlated;
680 foreach my $bucket (keys %mapped_lists) {
681
682 # Sort and convert this bucket to an inversion list. The
683 # result will be that ranges that start with even-numbered
684 # indexes will be for code points that map to this bucket;
685 # odd ones map to some other bucket, and are discarded
686 # below.
687 @{$mapped_lists{$bucket}}
688 = sort{ $a <=> $b} @{$mapped_lists{$bucket}};
689 @{$mapped_lists{$bucket}}
690 = mk_invlist_from_sorted_cp_list(\@{$mapped_lists{$bucket}});
691
692 # Add each even-numbered range in the bucket to %xlated;
693 # so that the keys of %xlated become the range start code
694 # points, and the values are their corresponding maps.
695 while (@{$mapped_lists{$bucket}}) {
696 my $range_start = $mapped_lists{$bucket}->[0];
697 if ($bucket =~ /\cK/) {
698 @{$xlated{$range_start}} = split /\cK/, $bucket;
699 }
700 else {
701 $xlated{$range_start} = $bucket;
702 }
703 shift @{$mapped_lists{$bucket}}; # Discard odd ranges
704 shift @{$mapped_lists{$bucket}}; # Get ready for next
705 # iteration
706 }
707 } # End of loop through all the buckets.
708
709 # Here %xlated's keys are the range starts of all the code
710 # points in the inversion map. Construct an inversion list
711 # from them.
712 my @new_invlist = sort { $a <=> $b } keys %xlated;
713
714 # If the list is adjusted, we want to munge this list so that
715 # we only have one entry for where consecutive code points map
716 # to consecutive values. We just skip the subsequent entries
717 # where this is the case.
718 if ($to_adjust) {
719 my @temp;
720 for my $i (0 .. @new_invlist - 1) {
721 next if $i > 0
722 && $new_invlist[$i-1] + 1 == $new_invlist[$i]
723 && $xlated{$new_invlist[$i-1]} =~ $numeric_re
724 && $xlated{$new_invlist[$i]} =~ $numeric_re
725 && $xlated{$new_invlist[$i-1]} + 1 == $xlated{$new_invlist[$i]};
726 push @temp, $new_invlist[$i];
727 }
728 @new_invlist = @temp;
729 }
730
731 # The inversion map comes from %xlated's values. We can
732 # unshift each onto the front of the untouched portion, in
733 # reverse order of the portion we did process.
734 foreach my $start (reverse @new_invlist) {
735 unshift @invmap, $xlated{$start};
736 }
737
738 # Finally prepend the inversion list we have just constructed to the
739 # one that contains anything we didn't process.
740 unshift @invlist, @new_invlist;
741 }
742 }
743
744 # prop_invmap() returns an extra final entry, which we can now
745 # discard.
746 if (@invmap) {
747 pop @invlist;
748 pop @invmap;
ceb1de32 749 }
0f5e3c71
KW
750
751 if ($l1_only) {
99f21fb9 752 die "Unimplemented to do a Latin-1 only inversion map" if @invmap;
0f5e3c71
KW
753 for my $i (0 .. @invlist - 1 - 1) {
754 if ($invlist[$i] > 255) {
755
756 # In an inversion list, even-numbered elements give the code
757 # points that begin ranges that match the property;
758 # odd-numbered give ones that begin ranges that don't match.
759 # If $i is odd, we are at the first code point above 255 that
760 # doesn't match, which means the range it is ending does
761 # match, and crosses the 255/256 boundary. We want to include
762 # this ending point, so increment $i, so the splice below
763 # includes it. Conversely, if $i is even, it is the first
764 # code point above 255 that matches, which means there was no
765 # matching range that crossed the boundary, and we don't want
766 # to include this code point, so splice before it.
767 $i++ if $i % 2 != 0;
768
769 # Remove everything past this.
770 splice @invlist, $i;
99f21fb9 771 splice @invmap, $i if @invmap;
0f5e3c71
KW
772 last;
773 }
0c4ecf42
KW
774 }
775 }
0f5e3c71
KW
776 elsif ($nonl1_only) {
777 my $found_nonl1 = 0;
778 for my $i (0 .. @invlist - 1 - 1) {
779 next if $invlist[$i] < 256;
780
781 # Here, we have the first element in the array that indicates an
782 # element above Latin1. Get rid of all previous ones.
783 splice @invlist, 0, $i;
99f21fb9 784 splice @invmap, 0, $i if @invmap;
0f5e3c71
KW
785
786 # If this one's index is not divisible by 2, it means that this
787 # element is inverting away from being in the list, which means
99f21fb9
KW
788 # all code points from 256 to this one are in this list (or
789 # map to the default for inversion maps)
790 if ($i % 2 != 0) {
791 unshift @invlist, 256;
792 unshift @invmap, $map_default if @invmap;
793 }
0f5e3c71 794 $found_nonl1 = 1;
3f427fd9
KW
795 last;
796 }
0f5e3c71 797 die "No non-Latin1 code points in $lookup_prop" unless $found_nonl1;
3f427fd9 798 }
3f427fd9 799
0f5e3c71 800 output_invlist($prop_name, \@invlist, $charset);
99f21fb9 801 output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, $map_default, $extra_enums, $charset) if @invmap;
0f5e3c71 802 }
bffc0129 803 end_file_pound_if;
0c4ecf42 804 print $out_fh "\n" . get_conditional_compile_line_end();
9d9177be
KW
805}
806
2308ab83 807my $sources_list = "lib/unicore/mktables.lst";
216b41c2
KW
808my @sources = ($0, qw(lib/unicore/mktables
809 lib/Unicode/UCD.pm
810 regen/charset_translations.pl
811 ));
9a3da3ad
FC
812{
813 # Depend on mktables’ own sources. It’s a shorter list of files than
814 # those that Unicode::UCD uses.
2308ab83
KW
815 if (! open my $mktables_list, $sources_list) {
816
817 # This should force a rebuild once $sources_list exists
818 push @sources, $sources_list;
819 }
820 else {
821 while(<$mktables_list>) {
822 last if /===/;
823 chomp;
824 push @sources, "lib/unicore/$_" if /^[^#]/;
825 }
9a3da3ad
FC
826 }
827}
828read_only_bottom_close_and_rename($out_fh, \@sources)