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
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                                                            || $format eq 'a';
357 my @has_multi_char_fold;
358 my @is_non_final_fold;
359
360 for 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
364     # Add to the non-finals list each code point that is in a non-final
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
372 sub _Perl_Non_Final_Folds {
373     @is_non_final_fold = sort { $a <=> $b } @is_non_final_fold;
374     return mk_invlist_from_sorted_cp_list(\@is_non_final_fold);
375 }
376
377 sub 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
388 sub UpperLatin1 {
389     return mk_invlist_from_sorted_cp_list([ 128 .. 255 ]);
390 }
391
392 output_invlist("Latin1", [ 0, 256 ]);
393 output_invlist("AboveLatin1", [ 256 ]);
394
395 end_file_pound_if;
396
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).
416 #
417 # An initial & means to use the subroutine from this file instead of an
418 # official inversion list.
419
420 for my $charset (get_supported_code_pages()) {
421     print $out_fh "\n" . get_conditional_compile_line_start($charset);
422
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(
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
450                              Grapheme_Cluster_Break,EDGE
451                              Word_Break,EDGE,UNKNOWN
452                              Sentence_Break,EDGE
453                            )
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/^&//;
471         my $extra_enums = "";
472         $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x;
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;
478         ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x;
479
480         my @invlist;
481         my @invmap;
482         my $map_format;
483         my $map_default;
484         my $maps_to_code_point;
485         my $to_adjust;
486         if ($is_local_sub) {
487             @invlist = eval $lookup_prop;
488         }
489         else {
490             @invlist = prop_invlist($lookup_prop, '_perl_core_internal_ok');
491             if (! @invlist) {
492
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)
496                           = prop_invmap($lookup_prop, '_perl_core_internal_ok');
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 {
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/;
513                 }
514             }
515         }
516
517
518         # Short-circuit an empty inversion list.
519         if (! @invlist) {
520             output_invlist($prop_name, \@invlist, $charset);
521             next;
522         }
523
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))))
549         {
550
551             if (! @invmap) {    # Straight inversion list
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
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;
563                 for my $j ($invlist[0] .. $upper) {
564                     push @latin1_list, a2n($j);
565                 }
566
567                 shift @invlist; # Shift off the range that's in the list
568                 shift @invlist; # Shift off the range not in the list
569             }
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;
578             @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list);
579             unshift @invlist, @latin1_list;
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;
749         }
750
751         if ($l1_only) {
752             die "Unimplemented to do a Latin-1 only inversion map" if @invmap;
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;
771                     splice @invmap, $i if @invmap;
772                     last;
773                 }
774             }
775         }
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;
784                 splice @invmap, 0, $i if @invmap;
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
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                 }
794                 $found_nonl1 = 1;
795                 last;
796             }
797             die "No non-Latin1 code points in $lookup_prop" unless $found_nonl1;
798         }
799
800         output_invlist($prop_name, \@invlist, $charset);
801         output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, $map_default, $extra_enums, $charset) if @invmap;
802     }
803     end_file_pound_if;
804     print $out_fh "\n" . get_conditional_compile_line_end();
805 }
806
807 my $sources_list = "lib/unicore/mktables.lst";
808 my @sources = ($0, qw(lib/unicore/mktables
809                       lib/Unicode/UCD.pm
810                       regen/charset_translations.pl
811                       ));
812 {
813     # Depend on mktables’ own sources.  It’s a shorter list of files than
814     # those that Unicode::UCD uses.
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         }
826     }
827 }
828 read_only_bottom_close_and_rename($out_fh, \@sources)