This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/mk_invlists.pl: Properly handle empty properties
[perl5.git] / regen / mk_invlists.pl
1 #!perl -w
2 use 5.015;
3 use strict;
4 use warnings;
5 use Unicode::UCD qw(prop_aliases
6                     prop_values
7                     prop_value_aliases
8                     prop_invlist
9                     prop_invmap search_invlist
10                    );
11 require 'regen/regen_lib.pl';
12 require 'regen/charset_translations.pl';
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:
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
28 my $VERSION_DATA_STRUCTURE_TYPE = 148565664;
29
30 # integer or float
31 my $numeric_re = qr/ ^ -? \d+ (:? \. \d+ )? $ /ax;
32
33 # Matches valid C language enum names: begins with ASCII alphabetic, then any
34 # ASCII \w
35 my $enum_name_re = qr / ^ [[:alpha:]] \w* $ /ax;
36
37 my $out_fh = open_new('charclass_invlists.h', '>',
38                       {style => '*', by => $0,
39                       from => "Unicode::UCD"});
40
41 my $in_file_pound_if = 0;
42
43 print $out_fh "/* See the generating file for comments */\n\n";
44
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
48 my %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                         );
58
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.
66 my %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
121 my @a2n;
122
123 sub 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
131 sub 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
140 sub 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
147 sub 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";
170     }
171 }
172
173 sub output_invlist ($$;$) {
174     my $name = shift;
175     my $invlist = shift;     # Reference to inversion list array
176     my $charset = shift // "";  # name of character set for comment
177
178     die "No inversion list for $name" unless defined $invlist
179                                              && ref $invlist eq 'ARRAY';
180
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
184     # Is the last element of the header 0, or 1 ?
185     my $zero_or_one = 0;
186     if (@$invlist && $invlist->[0] != 0) {
187         unshift @$invlist, 0;
188         $zero_or_one = 1;
189     }
190     my $count = @$invlist;
191
192     switch_pound_if ($name, 'PERL_IN_PERL_C');
193
194     print $out_fh "\nstatic const UV ${name}_invlist[] = {";
195     print $out_fh " /* for $charset */" if $charset;
196     print $out_fh "\n";
197
198     print $out_fh "\t$count,\t/* Number of elements */\n";
199     print $out_fh "\t$VERSION_DATA_STRUCTURE_TYPE, /* Version and data structure type */\n";
200     print $out_fh "\t", $zero_or_one,
201                   ",\t/* 0 if the list starts at 0;",
202                   "\n\t\t   1 if it starts at the element beyond 0 */\n";
203
204     # The main body are the UVs passed in to this routine.  Do the final
205     # element separately
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";
210     }
211
212     print $out_fh "};\n";
213 }
214
215 sub 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
238         my $short_name = (prop_aliases($prop_name))[0];
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
245                 # Convert short names to long
246                 @enums = map { (prop_value_aliases($prop_name, $_))[1] } @enums;
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.
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
276             # Inversion map stuff is currently used only by regexec
277             switch_pound_if($name, 'PERL_IN_REGEXEC_C');
278         {
279
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:]]/;
284             $name_prefix = "${short_name}_";
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";
323 }
324
325 sub mk_invlist_from_sorted_cp_list {
326
327     # Returns an inversion list constructed from the sorted input array of
328     # code points
329
330     my $list_ref = shift;
331
332     return unless @$list_ref;
333
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.
352 my ($cp_ref, $folds_ref, $format) = prop_invmap("Case_Folding");
353 die "Could not find inversion map for Case_Folding" unless defined $format;
354 die "Incorrect format '$format' for Case_Folding inversion map"
355                                                     unless $format eq 'al';
356 my @has_multi_char_fold;
357 my @is_non_final_fold;
358
359 for 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
363     # Add to the non-finals list each code point that is in a non-final
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
371 sub _Perl_Non_Final_Folds {
372     @is_non_final_fold = sort { $a <=> $b } @is_non_final_fold;
373     return mk_invlist_from_sorted_cp_list(\@is_non_final_fold);
374 }
375
376 sub 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
387 sub UpperLatin1 {
388     return mk_invlist_from_sorted_cp_list([ 128 .. 255 ]);
389 }
390
391 output_invlist("Latin1", [ 0, 256 ]);
392 output_invlist("AboveLatin1", [ 256 ]);
393
394 end_file_pound_if;
395
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).
415 #
416 # An initial & means to use the subroutine from this file instead of an
417 # official inversion list.
418
419 for my $charset (get_supported_code_pages()) {
420     print $out_fh "\n" . get_conditional_compile_line_start($charset);
421
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(
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
449                              Grapheme_Cluster_Break,EDGE
450                              Word_Break,EDGE,UNKNOWN
451                              Sentence_Break,EDGE
452                            )
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/^&//;
470         my $extra_enums = "";
471         $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x;
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;
477         ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x;
478
479         my @invlist;
480         my @invmap;
481         my $map_format;
482         my $map_default;
483         my $maps_to_code_point;
484         my $to_adjust;
485         if ($is_local_sub) {
486             @invlist = eval $lookup_prop;
487         }
488         else {
489             @invlist = prop_invlist($lookup_prop, '_perl_core_internal_ok');
490             if (! @invlist) {
491
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)
495                           = prop_invmap($lookup_prop, '_perl_core_internal_ok');
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 {
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/;
512                 }
513             }
514         }
515
516
517         # Short-circuit an empty inversion list.
518         if (! @invlist) {
519             output_invlist($prop_name, \@invlist, $charset);
520             next;
521         }
522
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))))
548         {
549
550             if (! @invmap) {    # Straight inversion list
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
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;
562                 for my $j ($invlist[0] .. $upper) {
563                     push @latin1_list, a2n($j);
564                 }
565
566                 shift @invlist; # Shift off the range that's in the list
567                 shift @invlist; # Shift off the range not in the list
568             }
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;
577             @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list);
578             unshift @invlist, @latin1_list;
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;
748         }
749
750         if ($l1_only) {
751             die "Unimplemented to do a Latin-1 only inversion map" if @invmap;
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;
770                     splice @invmap, $i if @invmap;
771                     last;
772                 }
773             }
774         }
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;
783                 splice @invmap, 0, $i if @invmap;
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
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                 }
793                 $found_nonl1 = 1;
794                 last;
795             }
796             die "No non-Latin1 code points in $lookup_prop" unless $found_nonl1;
797         }
798
799         output_invlist($prop_name, \@invlist, $charset);
800         output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, $map_default, $extra_enums, $charset) if @invmap;
801     }
802     end_file_pound_if;
803     print $out_fh "\n" . get_conditional_compile_line_end();
804 }
805
806 my $sources_list = "lib/unicore/mktables.lst";
807 my @sources = ($0, qw(lib/unicore/mktables
808                       lib/Unicode/UCD.pm
809                       regen/charset_translations.pl
810                       ));
811 {
812     # Depend on mktables’ own sources.  It’s a shorter list of files than
813     # those that Unicode::UCD uses.
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         }
825     }
826 }
827 read_only_bottom_close_and_rename($out_fh, \@sources)