This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Port lib/unicore/mktables to VMS.
[perl5.git] / lib / unicore / mktables
1 #!/usr/bin/perl -w
2
3 # !!!!!!!!!!!!!!       IF YOU MODIFY THIS FILE       !!!!!!!!!!!!!!!!!!!!!!!!!
4 # Any files created or read by this program should be listed in 'mktables.lst'
5 # Use -makelist to regenerate it.
6
7 # Needs 'no overloading' to run faster on miniperl.  Code commented out at the
8 # subroutine objaddr can be used instead to work as far back (untested) as
9 # 5.8: needs pack "U".
10 require 5.010_001;
11 use strict;
12 use warnings;
13 use Carp;
14 use File::Find;
15 use File::Path;
16 use File::Spec;
17 use Text::Tabs;
18
19 sub DEBUG () { 0 }  # Set to 0 for production; 1 for development
20
21 ##########################################################################
22 #
23 # mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
24 # from the Unicode database files (lib/unicore/.../*.txt),  It also generates
25 # a pod file and a .t file
26 #
27 # The structure of this file is:
28 #   First these introductory comments; then
29 #   code needed for everywhere, such as debugging stuff; then
30 #   code to handle input parameters; then
31 #   data structures likely to be of external interest (some of which depend on
32 #       the input parameters, so follows them; then
33 #   more data structures and subroutine and package (class) definitions; then
34 #   the small actual loop to process the input files and finish up; then
35 #   a __DATA__ section, for the .t tests
36 #
37 # This program works on all releases of Unicode through at least 5.2.  The
38 # outputs have been scrutinized most intently for release 5.1.  The others
39 # have been checked for somewhat more than just sanity.  It can handle all
40 # existing Unicode character properties in those releases.
41 #
42 # This program needs to be able to run under miniperl.  Therefore, it uses a
43 # minimum of other modules, and hence implements some things itself that could
44 # be gotten from CPAN
45 #
46 # This program uses inputs published by the Unicode Consortium.  These can
47 # change incompatibly between releases without the Perl maintainers realizing
48 # it.  Therefore this program is now designed to try to flag these.  It looks
49 # at the directories where the inputs are, and flags any unrecognized files.
50 # It keeps track of all the properties in the files it handles, and flags any
51 # that it doesn't know how to handle.  It also flags any input lines that
52 # don't match the expected syntax, among other checks.
53 # It is also designed so if a new input file matches one of the known
54 # templates, one hopefully just needs to add it to a list to have it
55 # processed.
56 #
57 # It tries to keep fatal errors to a minimum, to generate something usable for
58 # testing purposes.  It always looks for files that could be inputs, and will
59 # warn about any that it doesn't know how to handle (the -q option suppresses
60 # the warning).
61 #
62 # This program is mostly about Unicode character (or code point) properties.
63 # A property describes some attribute or quality of a code point, like if it
64 # is lowercase or not, its name, what version of Unicode it was first defined
65 # in, or what its uppercase equivalent is.  Unicode deals with these disparate
66 # possibilities by making all properties into mappings from each code point
67 # into some corresponding value.  In the case of it being lowercase or not,
68 # the mapping is either to 'Y' or 'N' (or various synonyms thereof).  Each
69 # property maps each Unicode code point to a single value, called a "property
70 # value".  (Hence each Unicode property is a true mathematical function with
71 # exactly one value per code point.)
72 #
73 # When using a property in a regular expression, what is desired isn't the
74 # mapping of the code point to its property's value, but the reverse (or the
75 # mathematical "inverse relation"): starting with the property value, "Does a
76 # code point map to it?"  These are written in a "compound" form:
77 # \p{property=value}, e.g., \p{category=punctuation}.  This program generates
78 # files containing the lists of code points that map to each such regular
79 # expression property value, one file per list
80 #
81 # There is also a single form shortcut that Perl adds for many of the commonly
82 # used properties.  This happens for all binary properties, plus script,
83 # general_category, and block properties.
84 #
85 # Thus the outputs of this program are files.  There are map files, mostly in
86 # the 'To' directory; and there are list files for use in regular expression
87 # matching, all in subdirectories of the 'lib' directory, with each
88 # subdirectory being named for the property that the lists in it are for.
89 # Bookkeeping, test, and documentation files are also generated.
90
91 my $matches_directory = 'lib';   # Where match (\p{}) files go.
92 my $map_directory = 'To';        # Where map files go.
93
94 # DATA STRUCTURES
95 #
96 # The major data structures of this program are Property, of course, but also
97 # Table.  There are two kinds of tables, very similar to each other.
98 # "Match_Table" is the data structure giving the list of code points that have
99 # a particular property value, mentioned above.  There is also a "Map_Table"
100 # data structure which gives the property's mapping from code point to value.
101 # There are two structures because the match tables need to be combined in
102 # various ways, such as constructing unions, intersections, complements, etc.,
103 # and the map ones don't.  And there would be problems, perhaps subtle, if
104 # a map table were inadvertently operated on in some of those ways.
105 # The use of separate classes with operations defined on one but not the other
106 # prevents accidentally confusing the two.
107 #
108 # At the heart of each table's data structure is a "Range_List", which is just
109 # an ordered list of "Ranges", plus ancillary information, and methods to
110 # operate on them.  A Range is a compact way to store property information.
111 # Each range has a starting code point, an ending code point, and a value that
112 # is meant to apply to all the code points between the two end points,
113 # inclusive.  For a map table, this value is the property value for those
114 # code points.  Two such ranges could be written like this:
115 #   0x41 .. 0x5A, 'Upper',
116 #   0x61 .. 0x7A, 'Lower'
117 #
118 # Each range also has a type used as a convenience to classify the values.
119 # Most ranges in this program will be Type 0, or normal, but there are some
120 # ranges that have a non-zero type.  These are used only in map tables, and
121 # are for mappings that don't fit into the normal scheme of things.  Mappings
122 # that require a hash entry to communicate with utf8.c are one example;
123 # another example is mappings for charnames.pm to use which indicate a name
124 # that is algorithmically determinable from its code point (and vice-versa).
125 # These are used to significantly compact these tables, instead of listing
126 # each one of the tens of thousands individually.
127 #
128 # In a match table, the value of a range is irrelevant (and hence the type as
129 # well, which will always be 0), and arbitrarily set to the null string.
130 # Using the example above, there would be two match tables for those two
131 # entries, one named Upper would contain the 0x41..0x5A range, and the other
132 # named Lower would contain 0x61..0x7A.
133 #
134 # Actually, there are two types of range lists, "Range_Map" is the one
135 # associated with map tables, and "Range_List" with match tables.
136 # Again, this is so that methods can be defined on one and not the other so as
137 # to prevent operating on them in incorrect ways.
138 #
139 # Eventually, most tables are written out to files to be read by utf8_heavy.pl
140 # in the perl core.  All tables could in theory be written, but some are
141 # suppressed because there is no current practical use for them.  It is easy
142 # to change which get written by changing various lists that are near the top
143 # of the actual code in this file.  The table data structures contain enough
144 # ancillary information to allow them to be treated as separate entities for
145 # writing, such as the path to each one's file.  There is a heading in each
146 # map table that gives the format of its entries, and what the map is for all
147 # the code points missing from it.  (This allows tables to be more compact.)
148
149 # The Property data structure contains one or more tables.  All properties
150 # contain a map table (except the $perl property which is a
151 # pseudo-property containing only match tables), and any properties that
152 # are usable in regular expression matches also contain various matching
153 # tables, one for each value the property can have.  A binary property can
154 # have two values, True and False (or Y and N, which are preferred by Unicode
155 # terminology).  Thus each of these properties will have a map table that
156 # takes every code point and maps it to Y or N (but having ranges cuts the
157 # number of entries in that table way down), and two match tables, one
158 # which has a list of all the code points that map to Y, and one for all the
159 # code points that map to N.  (For each of these, a third table is also
160 # generated for the pseudo Perl property.  It contains the identical code
161 # points as the Y table, but can be written, not in the compound form, but in
162 # a "single" form like \p{IsUppercase}.)  Many properties are binary, but some
163 # properties have several possible values, some have many, and properties like
164 # Name have a different value for every named code point.  Those will not,
165 # unless the controlling lists are changed, have their match tables written
166 # out.  But all the ones which can be used in regular expression \p{} and \P{}
167 # constructs will.  Generally a property will have either its map table or its
168 # match tables written but not both.  Again, what gets written is controlled
169 # by lists which can easily be changed.
170
171 # For information about the Unicode properties, see Unicode's UAX44 document:
172
173 my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
174
175 # As stated earlier, this program will work on any release of Unicode so far.
176 # Most obvious problems in earlier data have NOT been corrected except when
177 # necessary to make Perl or this program work reasonably.  For example, no
178 # folding information was given in early releases, so this program uses the
179 # substitute of lower case, just so that a regular expression with the /i
180 # option will do something that actually gives the right results in many
181 # cases.  There are also a couple other corrections for version 1.1.5,
182 # commented at the point they are made.  As an example of corrections that
183 # weren't made (but could be) is this statement from DerivedAge.txt: "The
184 # supplementary private use code points and the non-character code points were
185 # assigned in version 2.0, but not specifically listed in the UCD until
186 # versions 3.0 and 3.1 respectively."  (To be precise it was 3.0.1 not 3.0.0)
187 # More information on Unicode version glitches is further down in these
188 # introductory comments.
189 #
190 # This program works on all properties as of 5.2, though the files for some
191 # are suppressed from apparent lack of demand for.  You can change which are
192 # output by changing lists in this program.
193
194 # The old version of mktables emphasized the term "Fuzzy" to mean Unocde's
195 # loose matchings rules (from Unicode TR18):
196 #
197 #    The recommended names for UCD properties and property values are in
198 #    PropertyAliases.txt [Prop] and PropertyValueAliases.txt
199 #    [PropValue]. There are both abbreviated names and longer, more
200 #    descriptive names. It is strongly recommended that both names be
201 #    recognized, and that loose matching of property names be used,
202 #    whereby the case distinctions, whitespace, hyphens, and underbar
203 #    are ignored.
204 # The program still allows Fuzzy to override its determination of if loose
205 # matching should be used, but it isn't currently used, as it is no longer
206 # needed; the calculations it makes are good enough.
207
208 # SUMMARY OF HOW IT WORKS:
209 #
210 #   Process arguments
211 #
212 #   A list is constructed containing each input file that is to be processed
213 #
214 #   Each file on the list is processed in a loop, using the associated handler
215 #   code for each:
216 #        The PropertyAliases.txt and PropValueAliases.txt files are processed
217 #            first.  These files name the properties and property values.
218 #            Objects are created of all the property and property value names
219 #            that the rest of the input should expect, including all synonyms.
220 #        The other input files give mappings from properties to property
221 #           values.  That is, they list code points and say what the mapping
222 #           is under the given property.  Some files give the mappings for
223 #           just one property; and some for many.  This program goes through
224 #           each file and populates the properties from them.  Some properties
225 #           are listed in more than one file, and Unicode has set up a
226 #           precedence as to which has priority if there is a conflict.  Thus
227 #           the order of processing matters, and this program handles the
228 #           conflict possibility by processing the overriding input files
229 #           last, so that if necessary they replace earlier values.
230 #        After this is all done, the program creates the property mappings not
231 #            furnished by Unicode, but derivable from what it does give.
232 #        The tables of code points that match each property value in each
233 #            property that is accessible by regular expressions are created.
234 #        The Perl-defined properties are created and populated.  Many of these
235 #            require data determined from the earlier steps
236 #        Any Perl-defined synonyms are created, and name clashes between Perl
237 #            and Unicode are reconciled.
238 #        All the properties are written to files
239 #        Any other files are written, and final warnings issued.
240
241 # As mentioned above, some properties are given in more than one file.  In
242 # particular, the files in the extracted directory are supposedly just
243 # reformattings of the others.  But they contain information not easily
244 # derivable from the other files, including results for Unihan, which this
245 # program doesn't ordinarily look at, and for unassigned code points.  They
246 # also have historically had errors or been incomplete.  In an attempt to
247 # create the best possible data, this program thus processes them first to
248 # glean information missing from the other files; then processes those other
249 # files to override any errors in the extracted ones.
250
251 # For clarity, a number of operators have been overloaded to work on tables:
252 #   ~ means invert (take all characters not in the set).  The more
253 #       conventional '!' is not used because of the possibility of confusing
254 #       it with the actual boolean operation.
255 #   + means union
256 #   - means subtraction
257 #   & means intersection
258 # The precedence of these is the order listed.  Parentheses should be
259 # copiously used.  These are not a general scheme.  The operations aren't
260 # defined for a number of things, deliberately, to avoid getting into trouble.
261 # Operations are done on references and affect the underlying structures, so
262 # that the copy constructors for them have been overloaded to not return a new
263 # clone, but the input object itself.
264
265 # The bool operator is deliberately not overloaded to avoid confusion with
266 # "should it mean if the object merely exists, or also is non-empty?".
267
268 #
269 # WHY CERTAIN DESIGN DECISIONS WERE MADE
270
271 # XXX These comments need more work.
272 #
273 # Why have files written out for binary 'N' matches?
274 #   For binary properties, if you know the mapping for either Y or N; the
275 #   other is trivial to construct, so could be done at Perl run-time instead
276 #   of having a file for it.  That is, if someone types in \p{foo: N}, Perl
277 #   could translate that to \P{foo: Y} and not need a file.   The problem is
278 #   communicating to Perl that a given property is binary.  Perl can't figure
279 #   it out from looking at the N (or No), as some non-binary properties have
280 #   these as property values.
281 # Why
282 # There are several types of properties, based on what form their values can
283 # take on.  These are described in more detail below in the DATA STRUCTURES
284 # section of these comments, but for now, you should know that there are
285 # string properties, whose values are strings of one or more code points (such
286 # as the Uppercase_mapping property); every other property maps to some other
287 # form, like true or false, or a number, or a name, etc.  The reason there are
288 # two directories for map files is because of the way utf8.c works.  It
289 # expects that any files there are string properties, that is that the
290 # mappings are each to one code point, with mappings in multiple code points
291 # handled specially in an extra hash data structure.  Digit.pl is a table that
292 # is written there for historical reasons, even though it doesn't fit that
293 # mold.  Thus it can't currently be looked at by the Perl core.
294 #
295 # There are no match tables generated for matches of the null string.  These
296 # would like like \p{JSN=}.  Perhaps something like them could be added if
297 # necessary.  The JSN does have a real code point U+110B that maps to the null
298 # string, but it is a contributory property, and therefore not output by
299 # default.
300 #
301 # DEBUGGING
302 #
303 # XXX Add more stuff here.   use perl instead of miniperl to find problems with
304 # Scalar::Util
305
306 # FUTURE ISSUES
307 #
308 # The program would break if Unicode were to change its names so that
309 # interior white space, underscores, or dashes differences were significant
310 # within property and property value names.
311 #
312 # It might be easier to use the xml versions of the UCD if this program ever
313 # would need heavy revision, and the ability to handle old versions was not
314 # required.
315 #
316 # There is the potential for name collisions, in that Perl has chosen names
317 # that Unicode could decide it also likes.  There have been such collisions in
318 # the past, with mostly Perl deciding to adopt the Unicode definition of the
319 # name.  However in the 5.2 Unicode beta testing, there were a number of such
320 # collisions, which were withdrawn before the final release, because of Perl's
321 # and other's protests.  These all involved new properties which began with
322 # 'Is'.  Based on the protests, Unicode is unlikely to try that again.  Also,
323 # many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
324 # Unicode document, so they are unlikely to be used by Unicode for another
325 # purpose.  However, they might try something beginning with 'In', or use any
326 # of the other Perl-defined properties.  This program will warn you of name
327 # collisions, and refuse to generate tables with them, but manual intervention
328 # will be required in this event.  One scheme that could be implemented, if
329 # necessary, would be to have this program generate another file, or add a
330 # field to mktables.lst that gives the date of first definition of a property.
331 # Each new release of Unicode would use that file as a basis for the next
332 # iteration.  And the Perl synonym addition code could sort based on the age
333 # of the property, so older properties get priority, and newer ones that clash
334 # would be refused; hence existing code would not be impacted, and some other
335 # synonym would have to be used for the new property.  This is ugly, and
336 # manual intervention would certainly be easier to do in the short run; lets
337 # hope it never comes to this.
338
339 # A NOTE ON UNIHAN
340 #
341 # This program can generate tables from the Unihan database.  But it doesn't
342 # by default, letting the CPAN module Unicode::Unihan handle them.  Prior to
343 # version 5.2, this database was in a single file, Unihan.txt.  In 5.2 the
344 # database was split into 8 different files, all beginning with the letters
345 # 'Unihan'.  This program will read those file(s) if present, but it needs to
346 # know which of the many properties in the file(s) should have tables created
347 # for them.  It will create tables for any properties listed in
348 # PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
349 # @cjk_properties array and the @cjk_property_values array.  Thus, if a
350 # property you want is not in those files of the release you are building
351 # against, you must add it to those two arrays.  Starting in 4.0, the
352 # Unicode_Radical_Stroke was listed in those files, so if the Unihan database
353 # is present in the directory, a table will be generated for that property.
354 # In 5.2, several more properties were added.  For your convenience, the two
355 # arrays are initialized with all the 5.2 listed properties that are also in
356 # earlier releases.  But these are commented out.  You can just uncomment the
357 # ones you want, or use them as a template for adding entries for other
358 # properties.
359 #
360 # You may need to adjust the entries to suit your purposes.  setup_unihan(),
361 # and filter_unihan_line() are the functions where this is done.  This program
362 # already does some adjusting to make the lines look more like the rest of the
363 # Unicode DB;  You can see what that is in filter_unihan_line()
364 #
365 # There is a bug in the 3.2 data file in which some values for the
366 # kPrimaryNumeric property have commas and an unexpected comment.  A filter
367 # could be added for these; or for a particular installation, the Unihan.txt
368 # file could be edited to fix them.
369 # have to be
370 #
371 # HOW TO ADD A FILE
372
373 # Unicode Versions Notes
374
375 # alpha's numbers halve in 2.1.9, answer cjk block at 4E00 were removed from PropList; not changed, could add gc Letter, put back in in 3.1.0
376 # Some versions of 2.1.x Jamo.txt have the wrong value for 1105, which causes
377 # real problems for the algorithms for Jamo calculations, so it is changed
378 # here.
379 #   White space vs Space.  in 3.2 perl has +205F=medium math space, fixed in 4.0, and ok in 3.1.1 because not there in unicode. synonym introduced in 4.1
380 # ATBL = 202.  202 changed to ATB, and all code points stayed there.  So if you were useing ATBL you were out of luck.
381 # Hrkt Katakana_Or_Hiragana came in 4.01, before was Unknown.
382 #
383 # The default for missing code points for BidiClass is complicated.  Starting
384 # in 3.1.1, the derived file DBidiClass.txt handles this, but this program
385 # tries to do the best it can for earlier releases.  It is done in
386 # process_PropertyAliases()
387 #
388 ##############################################################################
389
390 my $UNDEF = ':UNDEF:';  # String to print out for undefined values in tracing
391                         # and errors
392 my $MAX_LINE_WIDTH = 78;
393
394 # Debugging aid to skip most files so as to not be distracted by them when
395 # concentrating on the ones being debugged.  Add
396 # non_skip => 1,
397 # to the constructor for those files you want processed when you set this.
398 # Files with a first version number of 0 are special: they are always
399 # processed regardless of the state of this flag.
400 my $debug_skip = 0;
401
402 # Set to 1 to enable tracing.
403 our $to_trace = 0;
404
405 { # Closure for trace: debugging aid
406     my $print_caller = 1;        # ? Include calling subroutine name
407     my $main_with_colon = 'main::';
408     my $main_colon_length = length($main_with_colon);
409
410     sub trace {
411         return unless $to_trace;        # Do nothing if global flag not set
412
413         my @input = @_;
414
415         local $DB::trace = 0;
416         $DB::trace = 0;          # Quiet 'used only once' message
417
418         my $line_number;
419
420         # Loop looking up the stack to get the first non-trace caller
421         my $caller_line;
422         my $caller_name;
423         my $i = 0;
424         do {
425             $line_number = $caller_line;
426             (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
427             $caller = $main_with_colon unless defined $caller;
428
429             $caller_name = $caller;
430
431             # get rid of pkg
432             $caller_name =~ s/.*:://;
433             if (substr($caller_name, 0, $main_colon_length)
434                 eq $main_with_colon)
435             {
436                 $caller_name = substr($caller_name, $main_colon_length);
437             }
438
439         } until ($caller_name ne 'trace');
440
441         # If the stack was empty, we were called from the top level
442         $caller_name = 'main' if ($caller_name eq ""
443                                     || $caller_name eq 'trace');
444
445         my $output = "";
446         foreach my $string (@input) {
447             #print STDERR __LINE__, ": ", join ", ", @input, "\n";
448             if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
449                 $output .= simple_dumper($string);
450             }
451             else {
452                 $string = "$string" if ref $string;
453                 $string = $UNDEF unless defined $string;
454                 chomp $string;
455                 $string = '""' if $string eq "";
456                 $output .= " " if $output ne ""
457                                 && $string ne ""
458                                 && substr($output, -1, 1) ne " "
459                                 && substr($string, 0, 1) ne " ";
460                 $output .= $string;
461             }
462         }
463
464         print STDERR sprintf "%4d: ", $line_number if defined $line_number;
465         print STDERR "$caller_name: " if $print_caller;
466         print STDERR $output, "\n";
467         return;
468     }
469 }
470
471 # This is for a rarely used development feature that allows you to compare two
472 # versions of the Unicode standard without having to deal with changes caused
473 # by the code points introduced in the later verson.  Change the 0 to a SINGLE
474 # dotted Unicode release number (e.g. 2.1).  Only code points introduced in
475 # that release and earlier will be used; later ones are thrown away.  You use
476 # the version number of the earliest one you want to compare; then run this
477 # program on directory structures containing each release, and compare the
478 # outputs.  These outputs will therefore include only the code points common
479 # to both releases, and you can see the changes caused just by the underlying
480 # release semantic changes.  For versions earlier than 3.2, you must copy a
481 # version of DAge.txt into the directory.
482 my $string_compare_versions = DEBUG && 0; #  e.g., v2.1;
483 my $compare_versions = DEBUG
484                        && $string_compare_versions
485                        && pack "C*", split /\./, $string_compare_versions;
486
487 sub uniques {
488     # Returns non-duplicated input values.  From "Perl Best Practices:
489     # Encapsulated Cleverness".  p. 455 in first edition.
490
491     my %seen;
492     return grep { ! $seen{$_}++ } @_;
493 }
494
495 $0 = File::Spec->canonpath($0);
496
497 my $make_test_script = 0;      # ? Should we output a test script
498 my $write_unchanged_files = 0; # ? Should we update the output files even if
499                                #    we don't think they have changed
500 my $use_directory = "";        # ? Should we chdir somewhere.
501 my $pod_directory;             # input directory to store the pod file.
502 my $pod_file = 'perluniprops';
503 my $t_path;                     # Path to the .t test file
504 my $file_list = 'mktables.lst'; # File to store input and output file names.
505                                # This is used to speed up the build, by not
506                                # executing the main body of the program if
507                                # nothing on the list has changed since the
508                                # previous build
509 my $make_list = 1;             # ? Should we write $file_list.  Set to always
510                                # make a list so that when the pumpking is
511                                # preparing a release, s/he won't have to do
512                                # special things
513 my $glob_list = 0;             # ? Should we try to include unknown .txt files
514                                # in the input.
515 my $output_range_counts = 1;   # ? Should we include the number of code points
516                                # in ranges in the output
517 # Verbosity levels; 0 is quiet
518 my $NORMAL_VERBOSITY = 1;
519 my $PROGRESS = 2;
520 my $VERBOSE = 3;
521
522 my $verbosity = $NORMAL_VERBOSITY;
523
524 # Process arguments
525 while (@ARGV) {
526     my $arg = shift @ARGV;
527     if ($arg eq '-v') {
528         $verbosity = $VERBOSE;
529     }
530     elsif ($arg eq '-p') {
531         $verbosity = $PROGRESS;
532         $| = 1;     # Flush buffers as we go.
533     }
534     elsif ($arg eq '-q') {
535         $verbosity = 0;
536     }
537     elsif ($arg eq '-w') {
538         $write_unchanged_files = 1; # update the files even if havent changed
539     }
540     elsif ($arg eq '-check') {
541         my $this = shift @ARGV;
542         my $ok = shift @ARGV;
543         if ($this ne $ok) {
544             print "Skipping as check params are not the same.\n";
545             exit(0);
546         }
547     }
548     elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
549         -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
550     }
551     elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
552     {
553         $make_test_script = 1;
554     }
555     elsif ($arg eq '-makelist') {
556         $make_list = 1;
557     }
558     elsif ($arg eq '-C' && defined ($use_directory = shift)) {
559         -d $use_directory or croak "Unknown directory '$use_directory'";
560     }
561     elsif ($arg eq '-L') {
562
563         # Existence not tested until have chdir'd
564         $file_list = shift;
565     }
566     elsif ($arg eq '-globlist') {
567         $glob_list = 1;
568     }
569     elsif ($arg eq '-c') {
570         $output_range_counts = ! $output_range_counts
571     }
572     else {
573         my $with_c = 'with';
574         $with_c .= 'out' if $output_range_counts;   # Complements the state
575         croak <<END;
576 usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
577           [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
578           [-check A B ]
579   -c          : Output comments $with_c number of code points in ranges
580   -q          : Quiet Mode: Only output serious warnings.
581   -p          : Set verbosity level to normal plus show progress.
582   -v          : Set Verbosity level high:  Show progress and non-serious
583                 warnings
584   -w          : Write files regardless
585   -C dir      : Change to this directory before proceeding. All relative paths
586                 except those specified by the -P and -T options will be done
587                 with respect to this directory.
588   -P dir      : Output $pod_file file to directory 'dir'.
589   -T path     : Create a test script as 'path'; overrides -maketest
590   -L filelist : Use alternate 'filelist' instead of standard one
591   -globlist   : Take as input all non-Test *.txt files in current and sub
592                 directories
593   -maketest   : Make test script 'TestProp.pl' in current (or -C directory),
594                 overrides -T
595   -makelist   : Rewrite the file list $file_list based on current setup
596   -check A B  : Executes $0 only if A and B are the same
597 END
598     }
599 }
600
601 # Stores the most-recently changed file.  If none have changed, can skip the
602 # build
603 my $youngest = -M $0;   # Do this before the chdir!
604
605 # Change directories now, because need to read 'version' early.
606 if ($use_directory) {
607     if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
608         $pod_directory = File::Spec->rel2abs($pod_directory);
609     }
610     if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
611         $t_path = File::Spec->rel2abs($t_path);
612     }
613     chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
614     if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
615         $pod_directory = File::Spec->abs2rel($pod_directory);
616     }
617     if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
618         $t_path = File::Spec->abs2rel($t_path);
619     }
620 }
621
622 # Get Unicode version into regular and v-string.  This is done now because
623 # various tables below get populated based on it.  These tables are populated
624 # here to be near the top of the file, and so easily seeable by those needing
625 # to modify things.
626 open my $VERSION, "<", "version"
627                     or croak "$0: can't open required file 'version': $!\n";
628 my $string_version = <$VERSION>;
629 close $VERSION;
630 chomp $string_version;
631 my $v_version = pack "C*", split /\./, $string_version;        # v string
632
633 # The following are the complete names of properties with property values that
634 # are known to not match any code points in some versions of Unicode, but that
635 # may change in the future so they should be matchable, hence an empty file is
636 # generated for them.
637 my @tables_that_may_be_empty = (
638                                 'Joining_Type=Left_Joining',
639                                 );
640 push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
641 push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
642 push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
643                                                     if $v_version ge v4.1.0;
644
645 # The lists below are hashes, so the key is the item in the list, and the
646 # value is the reason why it is in the list.  This makes generation of
647 # documentation easier.
648
649 my %why_suppressed;  # No file generated for these.
650
651 # Files aren't generated for empty extraneous properties.  This is arguable.
652 # Extraneous properties generally come about because a property is no longer
653 # used in a newer version of Unicode.  If we generated a file without code
654 # points, programs that used to work on that property will still execute
655 # without errors.  It just won't ever match (or will always match, with \P{}).
656 # This means that the logic is now likely wrong.  I (khw) think its better to
657 # find this out by getting an error message.  Just move them to the table
658 # above to change this behavior
659 my %why_suppress_if_empty_warn_if_not = (
660
661    # It is the only property that has ever officially been removed from the
662    # Standard.  The database never contained any code points for it.
663    'Special_Case_Condition' => 'Obsolete',
664
665    # Apparently never official, but there were code points in some versions of
666    # old-style PropList.txt
667    'Non_Break' => 'Obsolete',
668 );
669
670 # These would normally go in the warn table just above, but they were changed
671 # a long time before this program was written, so warnings about them are
672 # moot.
673 if ($v_version gt v3.2.0) {
674     push @tables_that_may_be_empty,
675                                 'Canonical_Combining_Class=Attached_Below_Left'
676 }
677
678 # These are listed in the Property aliases file in 5.2, but Unihan is ignored
679 # unless explicitly added.
680 if ($v_version ge v5.2.0) {
681     my $unihan = 'Unihan; remove from list if using Unihan';
682     foreach my $table qw (
683                            kAccountingNumeric
684                            kOtherNumeric
685                            kPrimaryNumeric
686                            kCompatibilityVariant
687                            kIICore
688                            kIRG_GSource
689                            kIRG_HSource
690                            kIRG_JSource
691                            kIRG_KPSource
692                            kIRG_MSource
693                            kIRG_KSource
694                            kIRG_TSource
695                            kIRG_USource
696                            kIRG_VSource
697                            kRSUnicode
698                         )
699     {
700         $why_suppress_if_empty_warn_if_not{$table} = $unihan;
701     }
702 }
703
704 # Properties that this program ignores.
705 my @unimplemented_properties = (
706 'Unicode_Radical_Stroke'    # Remove if changing to handle this one.
707 );
708
709 # There are several types of obsolete properties defined by Unicode.  These
710 # must be hand-edited for every new Unicode release.
711 my %why_deprecated;  # Generates a deprecated warning message if used.
712 my %why_stabilized;  # Documentation only
713 my %why_obsolete;    # Documentation only
714
715 {   # Closure
716     my $simple = 'Perl uses the more complete version of this property';
717     my $unihan = 'Unihan properties are by default not enabled in the Perl core.  Instead use CPAN: Unicode::Unihan';
718
719     my $other_properties = 'other properties';
720     my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
721     my $why_no_expand  = "Easily computed, and yet doesn't cover the common encoding forms (UTF-16/8)",
722
723     %why_deprecated = (
724         'Grapheme_Link' => 'Deprecated by Unicode.  Use ccc=vr (Canonical_Combining_Class=Virama) instead',
725         'Jamo_Short_Name' => $contributory,
726         'Line_Break=Surrogate' => 'Deprecated by Unicode because surrogates should never appear in well-formed text, and therefore shouldn\'t be the basis for line breaking',
727         'Other_Alphabetic' => $contributory,
728         'Other_Default_Ignorable_Code_Point' => $contributory,
729         'Other_Grapheme_Extend' => $contributory,
730         'Other_ID_Continue' => $contributory,
731         'Other_ID_Start' => $contributory,
732         'Other_Lowercase' => $contributory,
733         'Other_Math' => $contributory,
734         'Other_Uppercase' => $contributory,
735     );
736
737     %why_suppressed = (
738         # There is a lib/unicore/Decomposition.pl (used by normalize.pm) which
739         # contains the same information, but without the algorithmically
740         # determinable Hangul syllables'.  This file is not published, so it's
741         # existence is not noted in the comment.
742         'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',
743
744         'ISO_Comment' => 'Apparently no demand for it, but can access it through Unicode::UCD::charinfo.  Obsoleted, and code points for it removed in Unicode 5.2',
745         'Unicode_1_Name' => "$simple, and no apparent demand for it, but can access it through Unicode::UCD::charinfo.  If there is no later name for a code point, then this one is used instead in charnames",
746
747         'Simple_Case_Folding' => "$simple.  Can access this through Unicode::UCD::casefold",
748         'Simple_Lowercase_Mapping' => "$simple.  Can access this through Unicode::UCD::charinfo",
749         'Simple_Titlecase_Mapping' => "$simple.  Can access this through Unicode::UCD::charinfo",
750         'Simple_Uppercase_Mapping' => "$simple.  Can access this through Unicode::UCD::charinfo",
751
752         'Name' => "Accessible via 'use charnames;'",
753         'Name_Alias' => "Accessible via 'use charnames;'",
754
755         # These are sort of jumping the gun; deprecation is proposed for
756         # Unicode version 6.0, but they have never been exposed by Perl, and
757         # likely are soon to be deprecated, so best not to expose them.
758         FC_NFKC_Closure => 'Use NFKC_Casefold instead',
759         Expands_On_NFC => $why_no_expand,
760         Expands_On_NFD => $why_no_expand,
761         Expands_On_NFKC => $why_no_expand,
762         Expands_On_NFKD => $why_no_expand,
763     );
764
765     # The following are suppressed because they were made contributory or
766     # deprecated by Unicode before Perl ever thought about supporting them.
767     foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
768         $why_suppressed{$property} = $why_deprecated{$property};
769     }
770
771     # Customize the message for all the 'Other_' properties
772     foreach my $property (keys %why_deprecated) {
773         next if (my $main_property = $property) !~ s/^Other_//;
774         $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
775     }
776 }
777
778 if ($v_version ge 4.0.0) {
779     $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
780 }
781 if ($v_version ge 5.2.0) {
782     $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
783 }
784
785 # Probably obsolete forever
786 if ($v_version ge v4.1.0) {
787     $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete.  All code points previously matched by this have been moved to "Script=Common"';
788 }
789
790 # This program can create files for enumerated-like properties, such as
791 # 'Numeric_Type'.  This file would be the same format as for a string
792 # property, with a mapping from code point to its value, so you could look up,
793 # for example, the script a code point is in.  But no one so far wants this
794 # mapping, or they have found another way to get it since this is a new
795 # feature.  So no file is generated except if it is in this list.
796 my @output_mapped_properties = split "\n", <<END;
797 END
798
799 # If you are using the Unihan database, you need to add the properties that
800 # you want to extract from it to this table.  For your convenience, the
801 # properties in the 5.2 PropertyAliases.txt file are listed, commented out
802 my @cjk_properties = split "\n", <<'END';
803 #cjkAccountingNumeric; kAccountingNumeric
804 #cjkOtherNumeric; kOtherNumeric
805 #cjkPrimaryNumeric; kPrimaryNumeric
806 #cjkCompatibilityVariant; kCompatibilityVariant
807 #cjkIICore ; kIICore
808 #cjkIRG_GSource; kIRG_GSource
809 #cjkIRG_HSource; kIRG_HSource
810 #cjkIRG_JSource; kIRG_JSource
811 #cjkIRG_KPSource; kIRG_KPSource
812 #cjkIRG_KSource; kIRG_KSource
813 #cjkIRG_TSource; kIRG_TSource
814 #cjkIRG_USource; kIRG_USource
815 #cjkIRG_VSource; kIRG_VSource
816 #cjkRSUnicode; kRSUnicode                ; Unicode_Radical_Stroke; URS
817 END
818
819 # Similarly for the property values.  For your convenience, the lines in the
820 # 5.2 PropertyAliases.txt file are listed.  Just remove the first BUT NOT both
821 # '#' marks
822 my @cjk_property_values = split "\n", <<'END';
823 ## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
824 ## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
825 ## @missing: 0000..10FFFF; cjkIICore; <none>
826 ## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
827 ## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
828 ## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
829 ## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
830 ## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
831 ## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
832 ## @missing: 0000..10FFFF; cjkIRG_USource; <none>
833 ## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
834 ## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
835 ## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
836 ## @missing: 0000..10FFFF; cjkRSUnicode; <none>
837 END
838
839 # The input files don't list every code point.  Those not listed are to be
840 # defaulted to some value.  Below are hard-coded what those values are for
841 # non-binary properties as of 5.1.  Starting in 5.0, there are
842 # machine-parsable comment lines in the files the give the defaults; so this
843 # list shouldn't have to be extended.  The claim is that all missing entries
844 # for binary properties will default to 'N'.  Unicode tried to change that in
845 # 5.2, but the beta period produced enough protest that they backed off.
846 #
847 # The defaults for the fields that appear in UnicodeData.txt in this hash must
848 # be in the form that it expects.  The others may be synonyms.
849 my $CODE_POINT = '<code point>';
850 my %default_mapping = (
851     Age => "Unassigned",
852     # Bidi_Class => Complicated; set in code
853     Bidi_Mirroring_Glyph => "",
854     Block => 'No_Block',
855     Canonical_Combining_Class => 0,
856     Case_Folding => $CODE_POINT,
857     Decomposition_Mapping => $CODE_POINT,
858     Decomposition_Type => 'None',
859     East_Asian_Width => "Neutral",
860     FC_NFKC_Closure => $CODE_POINT,
861     General_Category => 'Cn',
862     Grapheme_Cluster_Break => 'Other',
863     Hangul_Syllable_Type => 'NA',
864     ISO_Comment => "",
865     Jamo_Short_Name => "",
866     Joining_Group => "No_Joining_Group",
867     # Joining_Type => Complicated; set in code
868     kIICore => 'N',   #                       Is converted to binary
869     #Line_Break => Complicated; set in code
870     Lowercase_Mapping => $CODE_POINT,
871     Name => "",
872     Name_Alias => "",
873     NFC_QC => 'Yes',
874     NFD_QC => 'Yes',
875     NFKC_QC => 'Yes',
876     NFKD_QC => 'Yes',
877     Numeric_Type => 'None',
878     Numeric_Value => 'NaN',
879     Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
880     Sentence_Break => 'Other',
881     Simple_Case_Folding => $CODE_POINT,
882     Simple_Lowercase_Mapping => $CODE_POINT,
883     Simple_Titlecase_Mapping => $CODE_POINT,
884     Simple_Uppercase_Mapping => $CODE_POINT,
885     Titlecase_Mapping => $CODE_POINT,
886     Unicode_1_Name => "",
887     Unicode_Radical_Stroke => "",
888     Uppercase_Mapping => $CODE_POINT,
889     Word_Break => 'Other',
890 );
891
892 # Below are files that Unicode furnishes, but this program ignores, and why
893 my %ignored_files = (
894     'CJKRadicals.txt' => 'Unihan data',
895     'Index.txt' => 'An index, not actual data',
896     'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
897     'NamesList.txt' => 'Just adds commentary',
898     'NormalizationCorrections.txt' => 'Data is already in other files.',
899     'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
900     'ReadMe.txt' => 'Just comments',
901     'README.TXT' => 'Just comments',
902     'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property.  Does not fit into current scheme where one code point is mapped',
903 );
904
905 ################ End of externally interesting definitions ###############
906
907 my $HEADER=<<"EOF";
908 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
909 # This file is machine-generated by $0 from the Unicode
910 # database, Version $string_version.  Any changes made here will be lost!
911 EOF
912
913 my $INTERNAL_ONLY=<<"EOF";
914
915 # !!!!!!!   INTERNAL PERL USE ONLY   !!!!!!!
916 # This file is for internal use by the Perl program only.  The format and even
917 # the name or existence of this file are subject to change without notice.
918 # Don't use it directly.
919 EOF
920
921 my $DEVELOPMENT_ONLY=<<"EOF";
922 # !!!!!!!   DEVELOPMENT USE ONLY   !!!!!!!
923 # This file contains information artificially constrained to code points
924 # present in Unicode release $string_compare_versions.
925 # IT CANNOT BE RELIED ON.  It is for use during development only and should
926 # not be used for production.
927
928 EOF
929
930 my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
931 my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
932 my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;
933
934 # Matches legal code point.  4-6 hex numbers, If there are 6, the first
935 # two must be 10; if there are 5, the first must not be a 0.  Written this way
936 # to decrease backtracking
937 my $code_point_re =
938         qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
939
940 # This matches the beginning of the line in the Unicode db files that give the
941 # defaults for code points not listed (i.e., missing) in the file.  The code
942 # depends on this ending with a semi-colon, so it can assume it is a valid
943 # field when the line is split() by semi-colons
944 my $missing_defaults_prefix =
945             qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;
946
947 # Property types.  Unicode has more types, but these are sufficient for our
948 # purposes.
949 my $UNKNOWN = -1;   # initialized to illegal value
950 my $NON_STRING = 1; # Either binary or enum
951 my $BINARY = 2;
952 my $ENUM = 3;       # Include catalog
953 my $STRING = 4;     # Anything else: string or misc
954
955 # Some input files have lines that give default values for code points not
956 # contained in the file.  Sometimes these should be ignored.
957 my $NO_DEFAULTS = 0;        # Must evaluate to false
958 my $NOT_IGNORED = 1;
959 my $IGNORED = 2;
960
961 # Range types.  Each range has a type.  Most ranges are type 0, for normal,
962 # and will appear in the main body of the tables in the output files, but
963 # there are other types of ranges as well, listed below, that are specially
964 # handled.   There are pseudo-types as well that will never be stored as a
965 # type, but will affect the calculation of the type.
966
967 # 0 is for normal, non-specials
968 my $MULTI_CP = 1;           # Sequence of more than code point
969 my $HANGUL_SYLLABLE = 2;
970 my $CP_IN_NAME = 3;         # The NAME contains the code point appended to it.
971 my $NULL = 4;               # The map is to the null string; utf8.c can't
972                             # handle these, nor is there an accepted syntax
973                             # for them in \p{} constructs
974 my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
975                              # otherwise be $MULTI_CP type are instead type 0
976
977 # process_generic_property_file() can accept certain overrides in its input.
978 # Each of these must begin AND end with $CMD_DELIM.
979 my $CMD_DELIM = "\a";
980 my $REPLACE_CMD = 'replace';    # Override the Replace
981 my $MAP_TYPE_CMD = 'map_type';  # Override the Type
982
983 my $NO = 0;
984 my $YES = 1;
985
986 # Values for the Replace argument to add_range.
987 # $NO                      # Don't replace; add only the code points not
988                            # already present.
989 my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
990                            # the comments at the subroutine definition.
991 my $UNCONDITIONALLY = 2;   # Replace without conditions.
992 my $MULTIPLE = 4;          # Don't replace, but add a duplicate record if
993                            # already there
994
995 # Flags to give property statuses.  The phrases are to remind maintainers that
996 # if the flag is changed, the indefinite article referring to it in the
997 # documentation may need to be as well.
998 my $NORMAL = "";
999 my $SUPPRESSED = 'z';   # The character should never actually be seen, since
1000                         # it is suppressed
1001 my $DEPRECATED = 'D';
1002 my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
1003 my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
1004 my $DISCOURAGED = 'X';
1005 my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
1006 my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
1007 my $STRICTER = 'T';
1008 my $a_bold_stricter = "a 'B<$STRICTER>'";
1009 my $A_bold_stricter = "A 'B<$STRICTER>'";
1010 my $STABILIZED = 'S';
1011 my $a_bold_stabilized = "an 'B<$STABILIZED>'";
1012 my $A_bold_stabilized = "An 'B<$STABILIZED>'";
1013 my $OBSOLETE = 'O';
1014 my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
1015 my $A_bold_obsolete = "An 'B<$OBSOLETE>'";
1016
1017 my %status_past_participles = (
1018     $DISCOURAGED => 'discouraged',
1019     $SUPPRESSED => 'should never be generated',
1020     $STABILIZED => 'stabilized',
1021     $OBSOLETE => 'obsolete',
1022     $DEPRECATED => 'deprecated'
1023 );
1024
1025 # The format of the values of the map tables:
1026 my $BINARY_FORMAT = 'b';
1027 my $DECIMAL_FORMAT = 'd';
1028 my $FLOAT_FORMAT = 'f';
1029 my $INTEGER_FORMAT = 'i';
1030 my $HEX_FORMAT = 'x';
1031 my $RATIONAL_FORMAT = 'r';
1032 my $STRING_FORMAT = 's';
1033
1034 my %map_table_formats = (
1035     $BINARY_FORMAT => 'binary',
1036     $DECIMAL_FORMAT => 'single decimal digit',
1037     $FLOAT_FORMAT => 'floating point number',
1038     $INTEGER_FORMAT => 'integer',
1039     $HEX_FORMAT => 'positive hex whole number; a code point',
1040     $RATIONAL_FORMAT => 'rational: an integer or a fraction',
1041     $STRING_FORMAT => 'arbitrary string',
1042 );
1043
1044 # Unicode didn't put such derived files in a separate directory at first.
1045 my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
1046 my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
1047 my $AUXILIARY = 'auxiliary';
1048
1049 # Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
1050 my %loose_to_file_of;       # loosely maps table names to their respective
1051                             # files
1052 my %stricter_to_file_of;    # same; but for stricter mapping.
1053 my %nv_floating_to_rational; # maps numeric values floating point numbers to
1054                              # their rational equivalent
1055 my %loose_property_name_of; # Loosely maps property names to standard form
1056
1057 # These constants names and values were taken from the Unicode standard,
1058 # version 5.1, section 3.12.  They are used in conjunction with Hangul
1059 # syllables
1060 my $SBase = 0xAC00;
1061 my $LBase = 0x1100;
1062 my $VBase = 0x1161;
1063 my $TBase = 0x11A7;
1064 my $SCount = 11172;
1065 my $LCount = 19;
1066 my $VCount = 21;
1067 my $TCount = 28;
1068 my $NCount = $VCount * $TCount;
1069
1070 # For Hangul syllables;  These store the numbers from Jamo.txt in conjunction
1071 # with the above published constants.
1072 my %Jamo;
1073 my %Jamo_L;     # Leading consonants
1074 my %Jamo_V;     # Vowels
1075 my %Jamo_T;     # Trailing consonants
1076
1077 my @unhandled_properties;  # Will contain a list of properties found in
1078                            # the input that we didn't process.
1079 my @match_properties;      # Properties that have match tables, to be
1080                            # listed in the pod
1081 my @map_properties;        # Properties that get map files written
1082 my @named_sequences;       # NamedSequences.txt contents.
1083 my %potential_files;       # Generated list of all .txt files in the directory
1084                            # structure so we can warn if something is being
1085                            # ignored.
1086 my @files_actually_output; # List of files we generated.
1087 my @more_Names;            # Some code point names are compound; this is used
1088                            # to store the extra components of them.
1089 my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
1090                            # the minimum before we consider it equivalent to a
1091                            # candidate rational
1092 my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
1093
1094 # These store references to certain commonly used property objects
1095 my $gc;
1096 my $perl;
1097 my $block;
1098
1099 # Are there conflicting names because of beginning with 'In_', or 'Is_'
1100 my $has_In_conflicts = 0;
1101 my $has_Is_conflicts = 0;
1102
1103 sub internal_file_to_platform ($) {
1104     # Convert our file paths which have '/' separators to those of the
1105     # platform.
1106
1107     my $file = shift;
1108     return undef unless defined $file;
1109
1110     return File::Spec->join(split '/', $file);
1111 }
1112
1113 sub file_exists ($) {   # platform independent '-e'.  This program internally
1114                         # uses slash as a path separator.
1115     my $file = shift;
1116     return 0 if ! defined $file;
1117     return -e internal_file_to_platform($file);
1118 }
1119
1120 sub objaddr($) {
1121     # Returns the address of the blessed input object.
1122     # It doesn't check for blessedness because that would do a string eval
1123     # every call, and the program is structured so that this is never called
1124     # for a non-blessed object.
1125
1126     no overloading; # If overloaded, numifying below won't work.
1127
1128     # Numifying a ref gives its address.
1129     return 0 + $_[0];
1130 }
1131
1132 # Commented code below should work on Perl 5.8.
1133 ## This 'require' doesn't necessarily work in miniperl, and even if it does,
1134 ## the native perl version of it (which is what would operate under miniperl)
1135 ## is extremely slow, as it does a string eval every call.
1136 #my $has_fast_scalar_util = $\18 !~ /miniperl/
1137 #                            && defined eval "require Scalar::Util";
1138 #
1139 #sub objaddr($) {
1140 #    # Returns the address of the blessed input object.  Uses the XS version if
1141 #    # available.  It doesn't check for blessedness because that would do a
1142 #    # string eval every call, and the program is structured so that this is
1143 #    # never called for a non-blessed object.
1144 #
1145 #    return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
1146 #
1147 #    # Check at least that is a ref.
1148 #    my $pkg = ref($_[0]) or return undef;
1149 #
1150 #    # Change to a fake package to defeat any overloaded stringify
1151 #    bless $_[0], 'main::Fake';
1152 #
1153 #    # Numifying a ref gives its address.
1154 #    my $addr = 0 + $_[0];
1155 #
1156 #    # Return to original class
1157 #    bless $_[0], $pkg;
1158 #    return $addr;
1159 #}
1160
1161 sub max ($$) {
1162     my $a = shift;
1163     my $b = shift;
1164     return $a if $a >= $b;
1165     return $b;
1166 }
1167
1168 sub min ($$) {
1169     my $a = shift;
1170     my $b = shift;
1171     return $a if $a <= $b;
1172     return $b;
1173 }
1174
1175 sub clarify_number ($) {
1176     # This returns the input number with underscores inserted every 3 digits
1177     # in large (5 digits or more) numbers.  Input must be entirely digits, not
1178     # checked.
1179
1180     my $number = shift;
1181     my $pos = length($number) - 3;
1182     return $number if $pos <= 1;
1183     while ($pos > 0) {
1184         substr($number, $pos, 0) = '_';
1185         $pos -= 3;
1186     }
1187     return $number;
1188 }
1189
1190
1191 package Carp;
1192
1193 # These routines give a uniform treatment of messages in this program.  They
1194 # are placed in the Carp package to cause the stack trace to not include them,
1195 # although an alternative would be to use another package and set @CARP_NOT
1196 # for it.
1197
1198 our $Verbose = 1 if main::DEBUG;  # Useful info when debugging
1199
1200 # This is a work-around suggested by Nicholas Clark to fix a problem with Carp
1201 # and overload trying to load Scalar:Util under miniperl.  See
1202 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
1203 undef $overload::VERSION;
1204
1205 sub my_carp {
1206     my $message = shift || "";
1207     my $nofold = shift || 0;
1208
1209     if ($message) {
1210         $message = main::join_lines($message);
1211         $message =~ s/^$0: *//;     # Remove initial program name
1212         $message =~ s/[.;,]+$//;    # Remove certain ending punctuation
1213         $message = "\n$0: $message;";
1214
1215         # Fold the message with program name, semi-colon end punctuation
1216         # (which looks good with the message that carp appends to it), and a
1217         # hanging indent for continuation lines.
1218         $message = main::simple_fold($message, "", 4) unless $nofold;
1219         $message =~ s/\n$//;        # Remove the trailing nl so what carp
1220                                     # appends is to the same line
1221     }
1222
1223     return $message if defined wantarray;   # If a caller just wants the msg
1224
1225     carp $message;
1226     return;
1227 }
1228
1229 sub my_carp_bug {
1230     # This is called when it is clear that the problem is caused by a bug in
1231     # this program.
1232
1233     my $message = shift;
1234     $message =~ s/^$0: *//;
1235     $message = my_carp("Bug in $0.  Please report it by running perlbug or if that is unavailable, by sending email to perbug\@perl.org:\n$message");
1236     carp $message;
1237     return;
1238 }
1239
1240 sub carp_too_few_args {
1241     if (@_ != 2) {
1242         my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'.  No action taken.");
1243         return;
1244     }
1245
1246     my $args_ref = shift;
1247     my $count = shift;
1248
1249     my_carp_bug("Need at least $count arguments to "
1250         . (caller 1)[3]
1251         . ".  Instead got: '"
1252         . join ', ', @$args_ref
1253         . "'.  No action taken.");
1254     return;
1255 }
1256
1257 sub carp_extra_args {
1258     my $args_ref = shift;
1259     my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . ");  Extras ignored.") if @_;
1260
1261     unless (ref $args_ref) {
1262         my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref.  Not checking arguments.");
1263         return;
1264     }
1265     my ($package, $file, $line) = caller;
1266     my $subroutine = (caller 1)[3];
1267
1268     my $list;
1269     if (ref $args_ref eq 'HASH') {
1270         foreach my $key (keys %$args_ref) {
1271             $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
1272         }
1273         $list = join ', ', each %{$args_ref};
1274     }
1275     elsif (ref $args_ref eq 'ARRAY') {
1276         foreach my $arg (@$args_ref) {
1277             $arg = $UNDEF unless defined $arg;
1278         }
1279         $list = join ', ', @$args_ref;
1280     }
1281     else {
1282         my_carp_bug("Can't cope with ref "
1283                 . ref($args_ref)
1284                 . " . argument to 'carp_extra_args'.  Not checking arguments.");
1285         return;
1286     }
1287
1288     my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine.  Skipped.");
1289     return;
1290 }
1291
1292 package main;
1293
1294 { # Closure
1295
1296     # This program uses the inside-out method for objects, as recommended in
1297     # "Perl Best Practices".  This closure aids in generating those.  There
1298     # are two routines.  setup_package() is called once per package to set
1299     # things up, and then set_access() is called for each hash representing a
1300     # field in the object.  These routines arrange for the object to be
1301     # properly destroyed when no longer used, and for standard accessor
1302     # functions to be generated.  If you need more complex accessors, just
1303     # write your own and leave those accesses out of the call to set_access().
1304     # More details below.
1305
1306     my %constructor_fields; # fields that are to be used in constructors; see
1307                             # below
1308
1309     # The values of this hash will be the package names as keys to other
1310     # hashes containing the name of each field in the package as keys, and
1311     # references to their respective hashes as values.
1312     my %package_fields;
1313
1314     sub setup_package {
1315         # Sets up the package, creating standard DESTROY and dump methods
1316         # (unless already defined).  The dump method is used in debugging by
1317         # simple_dumper().
1318         # The optional parameters are:
1319         #   a)  a reference to a hash, that gets populated by later
1320         #       set_access() calls with one of the accesses being
1321         #       'constructor'.  The caller can then refer to this, but it is
1322         #       not otherwise used by these two routines.
1323         #   b)  a reference to a callback routine to call during destruction
1324         #       of the object, before any fields are actually destroyed
1325
1326         my %args = @_;
1327         my $constructor_ref = delete $args{'Constructor_Fields'};
1328         my $destroy_callback = delete $args{'Destroy_Callback'};
1329         Carp::carp_extra_args(\@_) if main::DEBUG && %args;
1330
1331         my %fields;
1332         my $package = (caller)[0];
1333
1334         $package_fields{$package} = \%fields;
1335         $constructor_fields{$package} = $constructor_ref;
1336
1337         unless ($package->can('DESTROY')) {
1338             my $destroy_name = "${package}::DESTROY";
1339             no strict "refs";
1340
1341             # Use typeglob to give the anonymous subroutine the name we want
1342             *$destroy_name = sub {
1343                 my $self = shift;
1344                 my $addr = main::objaddr($self);
1345
1346                 $self->$destroy_callback if $destroy_callback;
1347                 foreach my $field (keys %{$package_fields{$package}}) {
1348                     #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
1349                     delete $package_fields{$package}{$field}{$addr};
1350                 }
1351                 return;
1352             }
1353         }
1354
1355         unless ($package->can('dump')) {
1356             my $dump_name = "${package}::dump";
1357             no strict "refs";
1358             *$dump_name = sub {
1359                 my $self = shift;
1360                 return dump_inside_out($self, $package_fields{$package}, @_);
1361             }
1362         }
1363         return;
1364     }
1365
1366     sub set_access {
1367         # Arrange for the input field to be garbage collected when no longer
1368         # needed.  Also, creates standard accessor functions for the field
1369         # based on the optional parameters-- none if none of these parameters:
1370         #   'addable'    creates an 'add_NAME()' accessor function.
1371         #   'readable' or 'readable_array'   creates a 'NAME()' accessor
1372         #                function.
1373         #   'settable'   creates a 'set_NAME()' accessor function.
1374         #   'constructor' doesn't create an accessor function, but adds the
1375         #                field to the hash that was previously passed to
1376         #                setup_package();
1377         # Any of the accesses can be abbreviated down, so that 'a', 'ad',
1378         # 'add' etc. all mean 'addable'.
1379         # The read accessor function will work on both array and scalar
1380         # values.  If another accessor in the parameter list is 'a', the read
1381         # access assumes an array.  You can also force it to be array access
1382         # by specifying 'readable_array' instead of 'readable'
1383         #
1384         # A sort-of 'protected' access can be set-up by preceding the addable,
1385         # readable or settable with some initial portion of 'protected_' (but,
1386         # the underscore is required), like 'p_a', 'pro_set', etc.  The
1387         # "protection" is only by convention.  All that happens is that the
1388         # accessor functions' names begin with an underscore.  So instead of
1389         # calling set_foo, the call is _set_foo.  (Real protection could be
1390         # accomplished by having a new subroutine, end_package called at the
1391         # end of each package, and then storing the __LINE__ ranges and
1392         # checking them on every accessor.  But that is way overkill.)
1393
1394         # We create anonymous subroutines as the accessors and then use
1395         # typeglobs to assign them to the proper package and name
1396
1397         my $name = shift;   # Name of the field
1398         my $field = shift;  # Reference to the inside-out hash containing the
1399                             # field
1400
1401         my $package = (caller)[0];
1402
1403         if (! exists $package_fields{$package}) {
1404             croak "$0: Must call 'setup_package' before 'set_access'";
1405         }
1406
1407         # Stash the field so DESTROY can get it.
1408         $package_fields{$package}{$name} = $field;
1409
1410         # Remaining arguments are the accessors.  For each...
1411         foreach my $access (@_) {
1412             my $access = lc $access;
1413
1414             my $protected = "";
1415
1416             # Match the input as far as it goes.
1417             if ($access =~ /^(p[^_]*)_/) {
1418                 $protected = $1;
1419                 if (substr('protected_', 0, length $protected)
1420                     eq $protected)
1421                 {
1422
1423                     # Add 1 for the underscore not included in $protected
1424                     $access = substr($access, length($protected) + 1);
1425                     $protected = '_';
1426                 }
1427                 else {
1428                     $protected = "";
1429                 }
1430             }
1431
1432             if (substr('addable', 0, length $access) eq $access) {
1433                 my $subname = "${package}::${protected}add_$name";
1434                 no strict "refs";
1435
1436                 # add_ accessor.  Don't add if already there, which we
1437                 # determine using 'eq' for scalars and '==' otherwise.
1438                 *$subname = sub {
1439                     use strict "refs";
1440                     return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1441                     my $self = shift;
1442                     my $value = shift;
1443                     Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1444                     if (ref $value) {
1445                         return if grep { $value == $_ }
1446                                             @{$field->{main::objaddr $self}};
1447                     }
1448                     else {
1449                         return if grep { $value eq $_ }
1450                                             @{$field->{main::objaddr $self}};
1451                     }
1452                     push @{$field->{main::objaddr $self}}, $value;
1453                     return;
1454                 }
1455             }
1456             elsif (substr('constructor', 0, length $access) eq $access) {
1457                 if ($protected) {
1458                     Carp::my_carp_bug("Can't set-up 'protected' constructors")
1459                 }
1460                 else {
1461                     $constructor_fields{$package}{$name} = $field;
1462                 }
1463             }
1464             elsif (substr('readable_array', 0, length $access) eq $access) {
1465
1466                 # Here has read access.  If one of the other parameters for
1467                 # access is array, or this one specifies array (by being more
1468                 # than just 'readable_'), then create a subroutine that
1469                 # assumes the data is an array.  Otherwise just a scalar
1470                 my $subname = "${package}::${protected}$name";
1471                 if (grep { /^a/i } @_
1472                     or length($access) > length('readable_'))
1473                 {
1474                     no strict "refs";
1475                     *$subname = sub {
1476                         use strict "refs";
1477                         Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1478                         my $addr = main::objaddr $_[0];
1479                         if (ref $field->{$addr} ne 'ARRAY') {
1480                             my $type = ref $field->{$addr};
1481                             $type = 'scalar' unless $type;
1482                             Carp::my_carp_bug("Trying to read $name as an array when it is a $type.  Big problems.");
1483                             return;
1484                         }
1485                         return scalar @{$field->{$addr}} unless wantarray;
1486
1487                         # Make a copy; had problems with caller modifying the
1488                         # original otherwise
1489                         my @return = @{$field->{$addr}};
1490                         return @return;
1491                     }
1492                 }
1493                 else {
1494
1495                     # Here not an array value, a simpler function.
1496                     no strict "refs";
1497                     *$subname = sub {
1498                         use strict "refs";
1499                         Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1500                         return $field->{main::objaddr $_[0]};
1501                     }
1502                 }
1503             }
1504             elsif (substr('settable', 0, length $access) eq $access) {
1505                 my $subname = "${package}::${protected}set_$name";
1506                 no strict "refs";
1507                 *$subname = sub {
1508                     use strict "refs";
1509                     if (main::DEBUG) {
1510                         return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
1511                         Carp::carp_extra_args(\@_) if @_ > 2;
1512                     }
1513                     # $self is $_[0]; $value is $_[1]
1514                     $field->{main::objaddr $_[0]} = $_[1];
1515                     return;
1516                 }
1517             }
1518             else {
1519                 Carp::my_carp_bug("Unknown accessor type $access.  No accessor set.");
1520             }
1521         }
1522         return;
1523     }
1524 }
1525
1526 package Input_file;
1527
1528 # All input files use this object, which stores various attributes about them,
1529 # and provides for convenient, uniform handling.  The run method wraps the
1530 # processing.  It handles all the bookkeeping of opening, reading, and closing
1531 # the file, returning only significant input lines.
1532 #
1533 # Each object gets a handler which processes the body of the file, and is
1534 # called by run().  Most should use the generic, default handler, which has
1535 # code scrubbed to handle things you might not expect.  A handler should
1536 # basically be a while(next_line()) {...} loop.
1537 #
1538 # You can also set up handlers to
1539 #   1) call before the first line is read for pre processing
1540 #   2) call to adjust each line of the input before the main handler gets them
1541 #   3) call upon EOF before the main handler exits its loop
1542 #   4) call at the end for post processing
1543 #
1544 # $_ is used to store the input line, and is to be filtered by the
1545 # each_line_handler()s.  So, if the format of the line is not in the desired
1546 # format for the main handler, these are used to do that adjusting.  They can
1547 # be stacked (by enclosing them in an [ anonymous array ] in the constructor,
1548 # so the $_ output of one is used as the input to the next.  None of the other
1549 # handlers are stackable, but could easily be changed to be so.
1550 #
1551 # Most of the handlers can call insert_lines() or insert_adjusted_lines()
1552 # which insert the parameters as lines to be processed before the next input
1553 # file line is read.  This allows the EOF handler to flush buffers, for
1554 # example.  The difference between the two routines is that the lines inserted
1555 # by insert_lines() are subjected to the each_line_handler()s.  (So if you
1556 # called it from such a handler, you would get infinite recursion.)  Lines
1557 # inserted by insert_adjusted_lines() go directly to the main handler without
1558 # any adjustments.  If the  post-processing handler calls any of these, there
1559 # will be no effect.  Some error checking for these conditions could be added,
1560 # but it hasn't been done.
1561 #
1562 # carp_bad_line() should be called to warn of bad input lines, which clears $_
1563 # to prevent further processing of the line.  This routine will output the
1564 # message as a warning once, and then keep a count of the lines that have the
1565 # same message, and output that count at the end of the file's processing.
1566 # This keeps the number of messages down to a manageable amount.
1567 #
1568 # get_missings() should be called to retrieve any @missing input lines.
1569 # Messages will be raised if this isn't done if the options aren't to ignore
1570 # missings.
1571
1572 sub trace { return main::trace(@_); }
1573
1574 { # Closure
1575     # Keep track of fields that are to be put into the constructor.
1576     my %constructor_fields;
1577
1578     main::setup_package(Constructor_Fields => \%constructor_fields);
1579
1580     my %file; # Input file name, required
1581     main::set_access('file', \%file, qw{ c r });
1582
1583     my %first_released; # Unicode version file was first released in, required
1584     main::set_access('first_released', \%first_released, qw{ c r });
1585
1586     my %handler;    # Subroutine to process the input file, defaults to
1587                     # 'process_generic_property_file'
1588     main::set_access('handler', \%handler, qw{ c });
1589
1590     my %property;
1591     # name of property this file is for.  defaults to none, meaning not
1592     # applicable, or is otherwise determinable, for example, from each line.
1593     main::set_access('property', \%property, qw{ c });
1594
1595     my %optional;
1596     # If this is true, the file is optional.  If not present, no warning is
1597     # output.  If it is present, the string given by this parameter is
1598     # evaluated, and if false the file is not processed.
1599     main::set_access('optional', \%optional, 'c', 'r');
1600
1601     my %non_skip;
1602     # This is used for debugging, to skip processing of all but a few input
1603     # files.  Add 'non_skip => 1' to the constructor for those files you want
1604     # processed when you set the $debug_skip global.
1605     main::set_access('non_skip', \%non_skip, 'c');
1606
1607     my %each_line_handler;
1608     # list of subroutines to look at and filter each non-comment line in the
1609     # file.  defaults to none.  The subroutines are called in order, each is
1610     # to adjust $_ for the next one, and the final one adjusts it for
1611     # 'handler'
1612     main::set_access('each_line_handler', \%each_line_handler, 'c');
1613
1614     my %has_missings_defaults;
1615     # ? Are there lines in the file giving default values for code points
1616     # missing from it?.  Defaults to NO_DEFAULTS.  Otherwise NOT_IGNORED is
1617     # the norm, but IGNORED means it has such lines, but the handler doesn't
1618     # use them.  Having these three states allows us to catch changes to the
1619     # UCD that this program should track
1620     main::set_access('has_missings_defaults',
1621                                         \%has_missings_defaults, qw{ c r });
1622
1623     my %pre_handler;
1624     # Subroutine to call before doing anything else in the file.  If undef, no
1625     # such handler is called.
1626     main::set_access('pre_handler', \%pre_handler, qw{ c });
1627
1628     my %eof_handler;
1629     # Subroutine to call upon getting an EOF on the input file, but before
1630     # that is returned to the main handler.  This is to allow buffers to be
1631     # flushed.  The handler is expected to call insert_lines() or
1632     # insert_adjusted() with the buffered material
1633     main::set_access('eof_handler', \%eof_handler, qw{ c r });
1634
1635     my %post_handler;
1636     # Subroutine to call after all the lines of the file are read in and
1637     # processed.  If undef, no such handler is called.
1638     main::set_access('post_handler', \%post_handler, qw{ c });
1639
1640     my %progress_message;
1641     # Message to print to display progress in lieu of the standard one
1642     main::set_access('progress_message', \%progress_message, qw{ c });
1643
1644     my %handle;
1645     # cache open file handle, internal.  Is undef if file hasn't been
1646     # processed at all, empty if has;
1647     main::set_access('handle', \%handle);
1648
1649     my %added_lines;
1650     # cache of lines added virtually to the file, internal
1651     main::set_access('added_lines', \%added_lines);
1652
1653     my %errors;
1654     # cache of errors found, internal
1655     main::set_access('errors', \%errors);
1656
1657     my %missings;
1658     # storage of '@missing' defaults lines
1659     main::set_access('missings', \%missings);
1660
1661     sub new {
1662         my $class = shift;
1663
1664         my $self = bless \do{ my $anonymous_scalar }, $class;
1665         my $addr = main::objaddr($self);
1666
1667         # Set defaults
1668         $handler{$addr} = \&main::process_generic_property_file;
1669         $non_skip{$addr} = 0;
1670         $has_missings_defaults{$addr} = $NO_DEFAULTS;
1671         $handle{$addr} = undef;
1672         $added_lines{$addr} = [ ];
1673         $each_line_handler{$addr} = [ ];
1674         $errors{$addr} = { };
1675         $missings{$addr} = [ ];
1676
1677         # Two positional parameters.
1678         return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1679         $file{$addr} = main::internal_file_to_platform(shift);
1680         $first_released{$addr} = shift;
1681
1682         # The rest of the arguments are key => value pairs
1683         # %constructor_fields has been set up earlier to list all possible
1684         # ones.  Either set or push, depending on how the default has been set
1685         # up just above.
1686         my %args = @_;
1687         foreach my $key (keys %args) {
1688             my $argument = $args{$key};
1689
1690             # Note that the fields are the lower case of the constructor keys
1691             my $hash = $constructor_fields{lc $key};
1692             if (! defined $hash) {
1693                 Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self.  Skipped");
1694                 next;
1695             }
1696             if (ref $hash->{$addr} eq 'ARRAY') {
1697                 if (ref $argument eq 'ARRAY') {
1698                     foreach my $argument (@{$argument}) {
1699                         next if ! defined $argument;
1700                         push @{$hash->{$addr}}, $argument;
1701                     }
1702                 }
1703                 else {
1704                     push @{$hash->{$addr}}, $argument if defined $argument;
1705                 }
1706             }
1707             else {
1708                 $hash->{$addr} = $argument;
1709             }
1710             delete $args{$key};
1711         };
1712
1713         # If the file has a property for it, it means that the property is not
1714         # listed in the file's entries.  So add a handler to the list of line
1715         # handlers to insert the property name into the lines, to provide a
1716         # uniform interface to the final processing subroutine.
1717         # the final code doesn't have to worry about that.
1718         if ($property{$addr}) {
1719             push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
1720         }
1721
1722         if ($non_skip{$addr} && ! $debug_skip && $verbosity) {
1723             print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
1724         }
1725
1726         return $self;
1727     }
1728
1729
1730     use overload
1731         fallback => 0,
1732         qw("") => "_operator_stringify",
1733         "." => \&main::_operator_dot,
1734     ;
1735
1736     sub _operator_stringify {
1737         my $self = shift;
1738
1739         return __PACKAGE__ . " object for " . $self->file;
1740     }
1741
1742     # flag to make sure extracted files are processed early
1743     my $seen_non_extracted_non_age = 0;
1744
1745     sub run {
1746         # Process the input object $self.  This opens and closes the file and
1747         # calls all the handlers for it.  Currently,  this can only be called
1748         # once per file, as it destroy's the EOF handler
1749
1750         my $self = shift;
1751         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1752
1753         my $addr = main::objaddr $self;
1754
1755         my $file = $file{$addr};
1756
1757         # Don't process if not expecting this file (because released later
1758         # than this Unicode version), and isn't there.  This means if someone
1759         # copies it into an earlier version's directory, we will go ahead and
1760         # process it.
1761         return if $first_released{$addr} gt $v_version && ! -e $file;
1762
1763         # If in debugging mode and this file doesn't have the non-skip
1764         # flag set, and isn't one of the critical files, skip it.
1765         if ($debug_skip
1766             && $first_released{$addr} ne v0
1767             && ! $non_skip{$addr})
1768         {
1769             print "Skipping $file in debugging\n" if $verbosity;
1770             return;
1771         }
1772
1773         # File could be optional
1774         if ($optional{$addr}){
1775             return unless -e $file;
1776             my $result = eval $optional{$addr};
1777             if (! defined $result) {
1778                 Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}.  $file Skipped.");
1779                 return;
1780             }
1781             if (! $result) {
1782                 if ($verbosity) {
1783                     print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n";
1784                 }
1785                 return;
1786             }
1787         }
1788
1789         if (! defined $file || ! -e $file) {
1790
1791             # If the file doesn't exist, see if have internal data for it
1792             # (based on first_released being 0).
1793             if ($first_released{$addr} eq v0) {
1794                 $handle{$addr} = 'pretend_is_open';
1795             }
1796             else {
1797                 if (! $optional{$addr}  # File could be optional
1798                     && $v_version ge $first_released{$addr})
1799                 {
1800                     print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr};
1801                 }
1802                 return;
1803             }
1804         }
1805         else {
1806
1807             # Here, the file exists
1808             if ($seen_non_extracted_non_age) {
1809                 if ($file =~ /$EXTRACTED/i) {
1810                     Carp::my_carp_bug(join_lines(<<END
1811 $file should be processed just after the 'Prop...Alias' files, and before
1812 anything not in the $EXTRACTED_DIR directory.  Proceeding, but the results may
1813 have subtle problems
1814 END
1815                     ));
1816                 }
1817             }
1818             elsif ($EXTRACTED_DIR
1819                     && $first_released{$addr} ne v0
1820                     && $file !~ /$EXTRACTED/i
1821                     && lc($file) ne 'dage.txt')
1822             {
1823                 # We don't set this (by the 'if' above) if we have no
1824                 # extracted directory, so if running on an early version,
1825                 # this test won't work.  Not worth worrying about.
1826                 $seen_non_extracted_non_age = 1;
1827             }
1828
1829             # And mark the file as having being processed, and warn if it
1830             # isn't a file we are expecting.  As we process the files,
1831             # they are deleted from the hash, so any that remain at the
1832             # end of the program are files that we didn't process.
1833             my $fkey = File::Spec->rel2abs($file);
1834             my $expecting = delete $potential_files{$fkey};
1835             $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
1836             Carp::my_carp("Was not expecting '$file'.") if 
1837                     ! $expecting                    
1838                     && ! defined $handle{$addr};
1839
1840             # Open the file, converting the slashes used in this program
1841             # into the proper form for the OS
1842             my $file_handle;
1843             if (not open $file_handle, "<", $file) {
1844                 Carp::my_carp("Can't open $file.  Skipping: $!");
1845                 return 0;
1846             }
1847             $handle{$addr} = $file_handle; # Cache the open file handle
1848         }
1849
1850         if ($verbosity >= $PROGRESS) {
1851             if ($progress_message{$addr}) {
1852                 print "$progress_message{$addr}\n";
1853             }
1854             else {
1855                 # If using a virtual file, say so.
1856                 print "Processing ", (-e $file)
1857                                        ? $file
1858                                        : "substitute $file",
1859                                      "\n";
1860             }
1861         }
1862
1863
1864         # Call any special handler for before the file.
1865         &{$pre_handler{$addr}}($self) if $pre_handler{$addr};
1866
1867         # Then the main handler
1868         &{$handler{$addr}}($self);
1869
1870         # Then any special post-file handler.
1871         &{$post_handler{$addr}}($self) if $post_handler{$addr};
1872
1873         # If any errors have been accumulated, output the counts (as the first
1874         # error message in each class was output when it was encountered).
1875         if ($errors{$addr}) {
1876             my $total = 0;
1877             my $types = 0;
1878             foreach my $error (keys %{$errors{$addr}}) {
1879                 $total += $errors{$addr}->{$error};
1880                 delete $errors{$addr}->{$error};
1881                 $types++;
1882             }
1883             if ($total > 1) {
1884                 my $message
1885                         = "A total of $total lines had errors in $file.  ";
1886
1887                 $message .= ($types == 1)
1888                             ? '(Only the first one was displayed.)'
1889                             : '(Only the first of each type was displayed.)';
1890                 Carp::my_carp($message);
1891             }
1892         }
1893
1894         if (@{$missings{$addr}}) {
1895             Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines.  Generated tables likely are wrong");
1896         }
1897
1898         # If a real file handle, close it.
1899         close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
1900                                                         ref $handle{$addr};
1901         $handle{$addr} = "";   # Uses empty to indicate that has already seen
1902                                # the file, as opposed to undef
1903         return;
1904     }
1905
1906     sub next_line {
1907         # Sets $_ to be the next logical input line, if any.  Returns non-zero
1908         # if such a line exists.  'logical' means that any lines that have
1909         # been added via insert_lines() will be returned in $_ before the file
1910         # is read again.
1911
1912         my $self = shift;
1913         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1914
1915         my $addr = main::objaddr $self;
1916
1917         # Here the file is open (or if the handle is not a ref, is an open
1918         # 'virtual' file).  Get the next line; any inserted lines get priority
1919         # over the file itself.
1920         my $adjusted;
1921
1922         LINE:
1923         while (1) { # Loop until find non-comment, non-empty line
1924             #local $to_trace = 1 if main::DEBUG;
1925             my $inserted_ref = shift @{$added_lines{$addr}};
1926             if (defined $inserted_ref) {
1927                 ($adjusted, $_) = @{$inserted_ref};
1928                 trace $adjusted, $_ if main::DEBUG && $to_trace;
1929                 return 1 if $adjusted;
1930             }
1931             else {
1932                 last if ! ref $handle{$addr}; # Don't read unless is real file
1933                 last if ! defined ($_ = readline $handle{$addr});
1934             }
1935             chomp;
1936             trace $_ if main::DEBUG && $to_trace;
1937
1938             # See if this line is the comment line that defines what property
1939             # value that code points that are not listed in the file should
1940             # have.  The format or existence of these lines is not guaranteed
1941             # by Unicode since they are comments, but the documentation says
1942             # that this was added for machine-readability, so probably won't
1943             # change.  This works starting in Unicode Version 5.0.  They look
1944             # like:
1945             #
1946             # @missing: 0000..10FFFF; Not_Reordered
1947             # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
1948             # @missing: 0000..10FFFF; ; NaN
1949             #
1950             # Save the line for a later get_missings() call.
1951             if (/$missing_defaults_prefix/) {
1952                 if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
1953                     $self->carp_bad_line("Unexpected \@missing line.  Assuming no missing entries");
1954                 }
1955                 elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
1956                     my @defaults = split /\s* ; \s*/x, $_;
1957
1958                     # The first field is the @missing, which ends in a
1959                     # semi-colon, so can safely shift.
1960                     shift @defaults;
1961
1962                     # Some of these lines may have empty field placeholders
1963                     # which get in the way.  An example is:
1964                     # @missing: 0000..10FFFF; ; NaN
1965                     # Remove them.  Process starting from the top so the
1966                     # splice doesn't affect things still to be looked at.
1967                     for (my $i = @defaults - 1; $i >= 0; $i--) {
1968                         next if $defaults[$i] ne "";
1969                         splice @defaults, $i, 1;
1970                     }
1971
1972                     # What's left should be just the property (maybe) and the
1973                     # default.  Having only one element means it doesn't have
1974                     # the property.
1975                     my $default;
1976                     my $property;
1977                     if (@defaults >= 1) {
1978                         if (@defaults == 1) {
1979                             $default = $defaults[0];
1980                         }
1981                         else {
1982                             $property = $defaults[0];
1983                             $default = $defaults[1];
1984                         }
1985                     }
1986
1987                     if (@defaults < 1
1988                         || @defaults > 2
1989                         || ($default =~ /^</
1990                             && $default !~ /^<code *point>$/i
1991                             && $default !~ /^<none>$/i))
1992                     {
1993                         $self->carp_bad_line("Unrecognized \@missing line: $_.  Assuming no missing entries");
1994                     }
1995                     else {
1996
1997                         # If the property is missing from the line, it should
1998                         # be the one for the whole file
1999                         $property = $property{$addr} if ! defined $property;
2000
2001                         # Change <none> to the null string, which is what it
2002                         # really means.  If the default is the code point
2003                         # itself, set it to <code point>, which is what
2004                         # Unicode uses (but sometimes they've forgotten the
2005                         # space)
2006                         if ($default =~ /^<none>$/i) {
2007                             $default = "";
2008                         }
2009                         elsif ($default =~ /^<code *point>$/i) {
2010                             $default = $CODE_POINT;
2011                         }
2012
2013                         # Store them as a sub-arrays with both components.
2014                         push @{$missings{$addr}}, [ $default, $property ];
2015                     }
2016                 }
2017
2018                 # There is nothing for the caller to process on this comment
2019                 # line.
2020                 next;
2021             }
2022
2023             # Remove comments and trailing space, and skip this line if the
2024             # result is empty
2025             s/#.*//;
2026             s/\s+$//;
2027             next if /^$/;
2028
2029             # Call any handlers for this line, and skip further processing of
2030             # the line if the handler sets the line to null.
2031             foreach my $sub_ref (@{$each_line_handler{$addr}}) {
2032                 &{$sub_ref}($self);
2033                 next LINE if /^$/;
2034             }
2035
2036             # Here the line is ok.  return success.
2037             return 1;
2038         } # End of looping through lines.
2039
2040         # If there is an EOF handler, call it (only once) and if it generates
2041         # more lines to process go back in the loop to handle them.
2042         if ($eof_handler{$addr}) {
2043             &{$eof_handler{$addr}}($self);
2044             $eof_handler{$addr} = "";   # Currently only get one shot at it.
2045             goto LINE if $added_lines{$addr};
2046         }
2047
2048         # Return failure -- no more lines.
2049         return 0;
2050
2051     }
2052
2053 #   Not currently used, not fully tested.
2054 #    sub peek {
2055 #        # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
2056 #        # record.  Not callable from an each_line_handler(), nor does it call
2057 #        # an each_line_handler() on the line.
2058 #
2059 #        my $self = shift;
2060 #        my $addr = main::objaddr $self;
2061 #
2062 #        foreach my $inserted_ref (@{$added_lines{$addr}}) {
2063 #            my ($adjusted, $line) = @{$inserted_ref};
2064 #            next if $adjusted;
2065 #
2066 #            # Remove comments and trailing space, and return a non-empty
2067 #            # resulting line
2068 #            $line =~ s/#.*//;
2069 #            $line =~ s/\s+$//;
2070 #            return $line if $line ne "";
2071 #        }
2072 #
2073 #        return if ! ref $handle{$addr}; # Don't read unless is real file
2074 #        while (1) { # Loop until find non-comment, non-empty line
2075 #            local $to_trace = 1 if main::DEBUG;
2076 #            trace $_ if main::DEBUG && $to_trace;
2077 #            return if ! defined (my $line = readline $handle{$addr});
2078 #            chomp $line;
2079 #            push @{$added_lines{$addr}}, [ 0, $line ];
2080 #
2081 #            $line =~ s/#.*//;
2082 #            $line =~ s/\s+$//;
2083 #            return $line if $line ne "";
2084 #        }
2085 #
2086 #        return;
2087 #    }
2088
2089
2090     sub insert_lines {
2091         # Lines can be inserted so that it looks like they were in the input
2092         # file at the place it was when this routine is called.  See also
2093         # insert_adjusted_lines().  Lines inserted via this routine go through
2094         # any each_line_handler()
2095
2096         my $self = shift;
2097
2098         # Each inserted line is an array, with the first element being 0 to
2099         # indicate that this line hasn't been adjusted, and needs to be
2100         # processed.
2101         push @{$added_lines{main::objaddr $self}}, map { [ 0, $_ ] } @_;
2102         return;
2103     }
2104
2105     sub insert_adjusted_lines {
2106         # Lines can be inserted so that it looks like they were in the input
2107         # file at the place it was when this routine is called.  See also
2108         # insert_lines().  Lines inserted via this routine are already fully
2109         # adjusted, ready to be processed; each_line_handler()s handlers will
2110         # not be called.  This means this is not a completely general
2111         # facility, as only the last each_line_handler on the stack should
2112         # call this.  It could be made more general, by passing to each of the
2113         # line_handlers their position on the stack, which they would pass on
2114         # to this routine, and that would replace the boolean first element in
2115         # the anonymous array pushed here, so that the next_line routine could
2116         # use that to call only those handlers whose index is after it on the
2117         # stack.  But this is overkill for what is needed now.
2118
2119         my $self = shift;
2120         trace $_[0] if main::DEBUG && $to_trace;
2121
2122         # Each inserted line is an array, with the first element being 1 to
2123         # indicate that this line has been adjusted
2124         push @{$added_lines{main::objaddr $self}}, map { [ 1, $_ ] } @_;
2125         return;
2126     }
2127
2128     sub get_missings {
2129         # Returns the stored up @missings lines' values, and clears the list.
2130         # The values are in an array, consisting of the default in the first
2131         # element, and the property in the 2nd.  However, since these lines
2132         # can be stacked up, the return is an array of all these arrays.
2133
2134         my $self = shift;
2135         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2136
2137         my $addr = main::objaddr $self;
2138
2139         # If not accepting a list return, just return the first one.
2140         return shift @{$missings{$addr}} unless wantarray;
2141
2142         my @return = @{$missings{$addr}};
2143         undef @{$missings{$addr}};
2144         return @return;
2145     }
2146
2147     sub _insert_property_into_line {
2148         # Add a property field to $_, if this file requires it.
2149
2150         my $property = $property{main::objaddr shift};
2151         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2152
2153         $_ =~ s/(;|$)/; $property$1/;
2154         return;
2155     }
2156
2157     sub carp_bad_line {
2158         # Output consistent error messages, using either a generic one, or the
2159         # one given by the optional parameter.  To avoid gazillions of the
2160         # same message in case the syntax of a  file is way off, this routine
2161         # only outputs the first instance of each message, incrementing a
2162         # count so the totals can be output at the end of the file.
2163
2164         my $self = shift;
2165         my $message = shift;
2166         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2167
2168         my $addr = main::objaddr $self;
2169
2170         $message = 'Unexpected line' unless $message;
2171
2172         # No trailing punctuation so as to fit with our addenda.
2173         $message =~ s/[.:;,]$//;
2174
2175         # If haven't seen this exact message before, output it now.  Otherwise
2176         # increment the count of how many times it has occurred
2177         unless ($errors{$addr}->{$message}) {
2178             Carp::my_carp("$message in '$_' in "
2179                             . $file{main::objaddr $self}
2180                             . " at line $..  Skipping this line;");
2181             $errors{$addr}->{$message} = 1;
2182         }
2183         else {
2184             $errors{$addr}->{$message}++;
2185         }
2186
2187         # Clear the line to prevent any further (meaningful) processing of it.
2188         $_ = "";
2189
2190         return;
2191     }
2192 } # End closure
2193
2194 package Multi_Default;
2195
2196 # Certain properties in early versions of Unicode had more than one possible
2197 # default for code points missing from the files.  In these cases, one
2198 # default applies to everything left over after all the others are applied,
2199 # and for each of the others, there is a description of which class of code
2200 # points applies to it.  This object helps implement this by storing the
2201 # defaults, and for all but that final default, an eval string that generates
2202 # the class that it applies to.
2203
2204
2205 {   # Closure
2206
2207     main::setup_package();
2208
2209     my %class_defaults;
2210     # The defaults structure for the classes
2211     main::set_access('class_defaults', \%class_defaults);
2212
2213     my %other_default;
2214     # The default that applies to everything left over.
2215     main::set_access('other_default', \%other_default, 'r');
2216
2217
2218     sub new {
2219         # The constructor is called with default => eval pairs, terminated by
2220         # the left-over default. e.g.
2221         # Multi_Default->new(
2222         #        'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
2223         #               -  0x200D',
2224         #        'R' => 'some other expression that evaluates to code points',
2225         #        .
2226         #        .
2227         #        .
2228         #        'U'));
2229
2230         my $class = shift;
2231
2232         my $self = bless \do{my $anonymous_scalar}, $class;
2233         my $addr = main::objaddr($self);
2234
2235         while (@_ > 1) {
2236             my $default = shift;
2237             my $eval = shift;
2238             $class_defaults{$addr}->{$default} = $eval;
2239         }
2240
2241         $other_default{$addr} = shift;
2242
2243         return $self;
2244     }
2245
2246     sub get_next_defaults {
2247         # Iterates and returns the next class of defaults.
2248         my $self = shift;
2249         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2250
2251         my $addr = main::objaddr $self;
2252
2253         return each %{$class_defaults{$addr}};
2254     }
2255 }
2256
2257 package Alias;
2258
2259 # An alias is one of the names that a table goes by.  This class defines them
2260 # including some attributes.  Everything is currently setup in the
2261 # constructor.
2262
2263
2264 {   # Closure
2265
2266     main::setup_package();
2267
2268     my %name;
2269     main::set_access('name', \%name, 'r');
2270
2271     my %loose_match;
2272     # Determined by the constructor code if this name should match loosely or
2273     # not.  The constructor parameters can override this, but it isn't fully
2274     # implemented, as should have ability to override Unicode one's via
2275     # something like a set_loose_match()
2276     main::set_access('loose_match', \%loose_match, 'r');
2277
2278     my %make_pod_entry;
2279     # Some aliases should not get their own entries because they are covered
2280     # by a wild-card, and some we want to discourage use of.  Binary
2281     main::set_access('make_pod_entry', \%make_pod_entry, 'r');
2282
2283     my %status;
2284     # Aliases have a status, like deprecated, or even suppressed (which means
2285     # they don't appear in documentation).  Enum
2286     main::set_access('status', \%status, 'r');
2287
2288     my %externally_ok;
2289     # Similarly, some aliases should not be considered as usable ones for
2290     # external use, such as file names, or we don't want documentation to
2291     # recommend them.  Boolean
2292     main::set_access('externally_ok', \%externally_ok, 'r');
2293
2294     sub new {
2295         my $class = shift;
2296
2297         my $self = bless \do { my $anonymous_scalar }, $class;
2298         my $addr = main::objaddr($self);
2299
2300         $name{$addr} = shift;
2301         $loose_match{$addr} = shift;
2302         $make_pod_entry{$addr} = shift;
2303         $externally_ok{$addr} = shift;
2304         $status{$addr} = shift;
2305
2306         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2307
2308         # Null names are never ok externally
2309         $externally_ok{$addr} = 0 if $name{$addr} eq "";
2310
2311         return $self;
2312     }
2313 }
2314
2315 package Range;
2316
2317 # A range is the basic unit for storing code points, and is described in the
2318 # comments at the beginning of the program.  Each range has a starting code
2319 # point; an ending code point (not less than the starting one); a value
2320 # that applies to every code point in between the two end-points, inclusive;
2321 # and an enum type that applies to the value.  The type is for the user's
2322 # convenience, and has no meaning here, except that a non-zero type is
2323 # considered to not obey the normal Unicode rules for having standard forms.
2324 #
2325 # The same structure is used for both map and match tables, even though in the
2326 # latter, the value (and hence type) is irrelevant and could be used as a
2327 # comment.  In map tables, the value is what all the code points in the range
2328 # map to.  Type 0 values have the standardized version of the value stored as
2329 # well, so as to not have to recalculate it a lot.
2330
2331 sub trace { return main::trace(@_); }
2332
2333 {   # Closure
2334
2335     main::setup_package();
2336
2337     my %start;
2338     main::set_access('start', \%start, 'r', 's');
2339
2340     my %end;
2341     main::set_access('end', \%end, 'r', 's');
2342
2343     my %value;
2344     main::set_access('value', \%value, 'r');
2345
2346     my %type;
2347     main::set_access('type', \%type, 'r');
2348
2349     my %standard_form;
2350     # The value in internal standard form.  Defined only if the type is 0.
2351     main::set_access('standard_form', \%standard_form);
2352
2353     # Note that if these fields change, the dump() method should as well
2354
2355     sub new {
2356         return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
2357         my $class = shift;
2358
2359         my $self = bless \do { my $anonymous_scalar }, $class;
2360         my $addr = main::objaddr($self);
2361
2362         $start{$addr} = shift;
2363         $end{$addr} = shift;
2364
2365         my %args = @_;
2366
2367         my $value = delete $args{'Value'};  # Can be 0
2368         $value = "" unless defined $value;
2369         $value{$addr} = $value;
2370
2371         $type{$addr} = delete $args{'Type'} || 0;
2372
2373         Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2374
2375         if (! $type{$addr}) {
2376             $standard_form{$addr} = main::standardize($value);
2377         }
2378
2379         return $self;
2380     }
2381
2382     use overload
2383         fallback => 0,
2384         qw("") => "_operator_stringify",
2385         "." => \&main::_operator_dot,
2386     ;
2387
2388     sub _operator_stringify {
2389         my $self = shift;
2390         my $addr = main::objaddr $self;
2391
2392         # Output it like '0041..0065 (value)'
2393         my $return = sprintf("%04X", $start{$addr})
2394                         .  '..'
2395                         . sprintf("%04X", $end{$addr});
2396         my $value = $value{$addr};
2397         my $type = $type{$addr};
2398         $return .= ' (';
2399         $return .= "$value";
2400         $return .= ", Type=$type" if $type != 0;
2401         $return .= ')';
2402
2403         return $return;
2404     }
2405
2406     sub standard_form {
2407         # The standard form is the value itself if the standard form is
2408         # undefined (that is if the value is special)
2409
2410         my $self = shift;
2411         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2412
2413         my $addr = main::objaddr $self;
2414
2415         return $standard_form{$addr} if defined $standard_form{$addr};
2416         return $value{$addr};
2417     }
2418
2419     sub dump {
2420         # Human, not machine readable.  For machine readable, comment out this
2421         # entire routine and let the standard one take effect.
2422         my $self = shift;
2423         my $indent = shift;
2424         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2425
2426         my $addr = main::objaddr $self;
2427
2428         my $return = $indent
2429                     . sprintf("%04X", $start{$addr})
2430                     . '..'
2431                     . sprintf("%04X", $end{$addr})
2432                     . " '$value{$addr}';";
2433         if (! defined $standard_form{$addr}) {
2434             $return .= "(type=$type{$addr})";
2435         }
2436         elsif ($standard_form{$addr} ne $value{$addr}) {
2437             $return .= "(standard '$standard_form{$addr}')";
2438         }
2439         return $return;
2440     }
2441 } # End closure
2442
2443 package _Range_List_Base;
2444
2445 # Base class for range lists.  A range list is simply an ordered list of
2446 # ranges, so that the ranges with the lowest starting numbers are first in it.
2447 #
2448 # When a new range is added that is adjacent to an existing range that has the
2449 # same value and type, it merges with it to form a larger range.
2450 #
2451 # Ranges generally do not overlap, except that there can be multiple entries
2452 # of single code point ranges.  This is because of NameAliases.txt.
2453 #
2454 # In this program, there is a standard value such that if two different
2455 # values, have the same standard value, they are considered equivalent.  This
2456 # value was chosen so that it gives correct results on Unicode data
2457
2458 # There are a number of methods to manipulate range lists, and some operators
2459 # are overloaded to handle them.
2460
2461 # Because of the slowness of pure Perl objaddr() on miniperl, and measurements
2462 # showing this package was using a lot of real time calculating that, the code
2463 # was changed to only calculate it once per call stack.  This is done by
2464 # consistently using the package variable $addr in routines, and only calling
2465 # objaddr() if it isn't defined, and setting that to be local, so that callees
2466 # will have it already.  It would be a good thing to change this. XXX
2467
2468 sub trace { return main::trace(@_); }
2469
2470 { # Closure
2471
2472     our $addr;
2473
2474     main::setup_package();
2475
2476     my %ranges;
2477     # The list of ranges
2478     main::set_access('ranges', \%ranges, 'readable_array');
2479
2480     my %max;
2481     # The highest code point in the list.  This was originally a method, but
2482     # actual measurements said it was used a lot.
2483     main::set_access('max', \%max, 'r');
2484
2485     my %each_range_iterator;
2486     # Iterator position for each_range()
2487     main::set_access('each_range_iterator', \%each_range_iterator);
2488
2489     my %owner_name_of;
2490     # Name of parent this is attached to, if any.  Solely for better error
2491     # messages.
2492     main::set_access('owner_name_of', \%owner_name_of, 'p_r');
2493
2494     my %_search_ranges_cache;
2495     # A cache of the previous result from _search_ranges(), for better
2496     # performance
2497     main::set_access('_search_ranges_cache', \%_search_ranges_cache);
2498
2499     sub new {
2500         my $class = shift;
2501         my %args = @_;
2502
2503         # Optional initialization data for the range list.
2504         my $initialize = delete $args{'Initialize'};
2505
2506         my $self;
2507
2508         # Use _union() to initialize.  _union() returns an object of this
2509         # class, which means that it will call this constructor recursively.
2510         # But it won't have this $initialize parameter so that it won't
2511         # infinitely loop on this.
2512         return _union($class, $initialize, %args) if defined $initialize;
2513
2514         $self = bless \do { my $anonymous_scalar }, $class;
2515         local $addr = main::objaddr($self);
2516
2517         # Optional parent object, only for debug info.
2518         $owner_name_of{$addr} = delete $args{'Owner'};
2519         $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};
2520
2521         # Stringify, in case it is an object.
2522         $owner_name_of{$addr} = "$owner_name_of{$addr}";
2523
2524         # This is used only for error messages, and so a colon is added
2525         $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";
2526
2527         Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2528
2529         # Max is initialized to a negative value that isn't adjacent to 0,
2530         # for simpler tests
2531         $max{$addr} = -2;
2532
2533         $_search_ranges_cache{$addr} = 0;
2534         $ranges{$addr} = [];
2535
2536         return $self;
2537     }
2538
2539     use overload
2540         fallback => 0,
2541         qw("") => "_operator_stringify",
2542         "." => \&main::_operator_dot,
2543     ;
2544
2545     sub _operator_stringify {
2546         my $self = shift;
2547         local $addr = main::objaddr($self) if !defined $addr;
2548
2549         return "Range_List attached to '$owner_name_of{$addr}'"
2550                                                 if $owner_name_of{$addr};
2551         return "anonymous Range_List " . \$self;
2552     }
2553
2554     sub _union {
2555         # Returns the union of the input code points.  It can be called as
2556         # either a constructor or a method.  If called as a method, the result
2557         # will be a new() instance of the calling object, containing the union
2558         # of that object with the other parameter's code points;  if called as
2559         # a constructor, the first parameter gives the class the new object
2560         # should be, and the second parameter gives the code points to go into
2561         # it.
2562         # In either case, there are two parameters looked at by this routine;
2563         # any additional parameters are passed to the new() constructor.
2564         #
2565         # The code points can come in the form of some object that contains
2566         # ranges, and has a conventionally named method to access them; or
2567         # they can be an array of individual code points (as integers); or
2568         # just a single code point.
2569         #
2570         # If they are ranges, this routine doesn't make any effort to preserve
2571         # the range values of one input over the other.  Therefore this base
2572         # class should not allow _union to be called from other than
2573         # initialization code, so as to prevent two tables from being added
2574         # together where the range values matter.  The general form of this
2575         # routine therefore belongs in a derived class, but it was moved here
2576         # to avoid duplication of code.  The failure to overload this in this
2577         # class keeps it safe.
2578         #
2579
2580         my $self;
2581         my @args;   # Arguments to pass to the constructor
2582
2583         my $class = shift;
2584
2585         # If a method call, will start the union with the object itself, and
2586         # the class of the new object will be the same as self.
2587         if (ref $class) {
2588             $self = $class;
2589             $class = ref $self;
2590             push @args, $self;
2591         }
2592
2593         # Add the other required parameter.
2594         push @args, shift;
2595         # Rest of parameters are passed on to the constructor
2596
2597         # Accumulate all records from both lists.
2598         my @records;
2599         for my $arg (@args) {
2600             #local $to_trace = 0 if main::DEBUG;
2601             trace "argument = $arg" if main::DEBUG && $to_trace;
2602             if (! defined $arg) {
2603                 my $message = "";
2604                 if (defined $self) {
2605                     $message .= $owner_name_of{main::objaddr $self};
2606                 }
2607                 Carp::my_carp_bug($message .= "Undefined argument to _union.  No union done.");
2608                 return;
2609             }
2610             $arg = [ $arg ] if ! ref $arg;
2611             my $type = ref $arg;
2612             if ($type eq 'ARRAY') {
2613                 foreach my $element (@$arg) {
2614                     push @records, Range->new($element, $element);
2615                 }
2616             }
2617             elsif ($arg->isa('Range')) {
2618                 push @records, $arg;
2619             }
2620             elsif ($arg->can('ranges')) {
2621                 push @records, $arg->ranges;
2622             }
2623             else {
2624                 my $message = "";
2625                 if (defined $self) {
2626                     $message .= $owner_name_of{main::objaddr $self};
2627                 }
2628                 Carp::my_carp_bug($message . "Cannot take the union of a $type.  No union done.");
2629                 return;
2630             }
2631         }
2632
2633         # Sort with the range containing the lowest ordinal first, but if
2634         # two ranges start at the same code point, sort with the bigger range
2635         # of the two first, because it takes fewer cycles.
2636         @records = sort { ($a->start <=> $b->start)
2637                                       or
2638                                     # if b is shorter than a, b->end will be
2639                                     # less than a->end, and we want to select
2640                                     # a, so want to return -1
2641                                     ($b->end <=> $a->end)
2642                                    } @records;
2643
2644         my $new = $class->new(@_);
2645
2646         # Fold in records so long as they add new information.
2647         for my $set (@records) {
2648             my $start = $set->start;
2649             my $end   = $set->end;
2650             my $value   = $set->value;
2651             if ($start > $new->max) {
2652                 $new->_add_delete('+', $start, $end, $value);
2653             }
2654             elsif ($end > $new->max) {
2655                 $new->_add_delete('+', $new->max +1, $end, $value);
2656             }
2657         }
2658
2659         return $new;
2660     }
2661
2662     sub range_count {        # Return the number of ranges in the range list
2663         my $self = shift;
2664         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2665
2666         local $addr = main::objaddr($self) if ! defined $addr;
2667
2668         return scalar @{$ranges{$addr}};
2669     }
2670
2671     sub min {
2672         # Returns the minimum code point currently in the range list, or if
2673         # the range list is empty, 2 beyond the max possible.  This is a
2674         # method because used so rarely, that not worth saving between calls,
2675         # and having to worry about changing it as ranges are added and
2676         # deleted.
2677
2678         my $self = shift;
2679         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2680
2681         local $addr = main::objaddr($self) if ! defined $addr;
2682
2683         # If the range list is empty, return a large value that isn't adjacent
2684         # to any that could be in the range list, for simpler tests
2685         return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
2686         return $ranges{$addr}->[0]->start;
2687     }
2688
2689     sub contains {
2690         # Boolean: Is argument in the range list?  If so returns $i such that:
2691         #   range[$i]->end < $codepoint <= range[$i+1]->end
2692         # which is one beyond what you want; this is so that the 0th range
2693         # doesn't return false
2694         my $self = shift;
2695         my $codepoint = shift;
2696         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2697
2698         local $addr = main::objaddr $self if ! defined $addr;
2699
2700         my $i = $self->_search_ranges($codepoint);
2701         return 0 unless defined $i;
2702
2703         # The search returns $i, such that
2704         #   range[$i-1]->end < $codepoint <= range[$i]->end
2705         # So is in the table if and only iff it is at least the start position
2706         # of range $i.
2707         return 0 if $ranges{$addr}->[$i]->start > $codepoint;
2708         return $i + 1;
2709     }
2710
2711     sub value_of {
2712         # Returns the value associated with the code point, undef if none
2713
2714         my $self = shift;
2715         my $codepoint = shift;
2716         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2717
2718         local $addr = main::objaddr $self if ! defined $addr;
2719
2720         my $i = $self->contains($codepoint);
2721         return unless $i;
2722
2723         # contains() returns 1 beyond where we should look
2724         return $ranges{$addr}->[$i-1]->value;
2725     }
2726
2727     sub _search_ranges {
2728         # Find the range in the list which contains a code point, or where it
2729         # should go if were to add it.  That is, it returns $i, such that:
2730         #   range[$i-1]->end < $codepoint <= range[$i]->end
2731         # Returns undef if no such $i is possible (e.g. at end of table), or
2732         # if there is an error.
2733
2734         my $self = shift;
2735         my $code_point = shift;
2736         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2737
2738         local $addr = main::objaddr $self if ! defined $addr;
2739
2740         return if $code_point > $max{$addr};
2741         my $r = $ranges{$addr};                # The current list of ranges
2742         my $range_list_size = scalar @$r;
2743         my $i;
2744
2745         use integer;        # want integer division
2746
2747         # Use the cached result as the starting guess for this one, because,
2748         # an experiment on 5.1 showed that 90% of the time the cache was the
2749         # same as the result on the next call (and 7% it was one less).
2750         $i = $_search_ranges_cache{$addr};
2751         $i = 0 if $i >= $range_list_size;   # Reset if no longer valid (prob.
2752                                             # from an intervening deletion
2753         #local $to_trace = 1 if main::DEBUG;
2754         trace "previous \$i is still valid: $i" if main::DEBUG && $to_trace && $code_point <= $r->[$i]->end && ($i == 0 || $r->[$i-1]->end < $code_point);
2755         return $i if $code_point <= $r->[$i]->end
2756                      && ($i == 0 || $r->[$i-1]->end < $code_point);
2757
2758         # Here the cache doesn't yield the correct $i.  Try adding 1.
2759         if ($i < $range_list_size - 1
2760             && $r->[$i]->end < $code_point &&
2761             $code_point <= $r->[$i+1]->end)
2762         {
2763             $i++;
2764             trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
2765             $_search_ranges_cache{$addr} = $i;
2766             return $i;
2767         }
2768
2769         # Here, adding 1 also didn't work.  We do a binary search to
2770         # find the correct position, starting with current $i
2771         my $lower = 0;
2772         my $upper = $range_list_size - 1;
2773         while (1) {
2774             trace "top of loop i=$i:", sprintf("%04X", $r->[$lower]->start), "[$lower] .. ", sprintf("%04X", $r->[$i]->start), "[$i] .. ", sprintf("%04X", $r->[$upper]->start), "[$upper]" if main::DEBUG && $to_trace;
2775
2776             if ($code_point <= $r->[$i]->end) {
2777
2778                 # Here we have met the upper constraint.  We can quit if we
2779                 # also meet the lower one.
2780                 last if $i == 0 || $r->[$i-1]->end < $code_point;
2781
2782                 $upper = $i;        # Still too high.
2783
2784             }
2785             else {
2786
2787                 # Here, $r[$i]->end < $code_point, so look higher up.
2788                 $lower = $i;
2789             }
2790
2791             # Split search domain in half to try again.
2792             my $temp = ($upper + $lower) / 2;
2793
2794             # No point in continuing unless $i changes for next time
2795             # in the loop.
2796             if ($temp == $i) {
2797
2798                 # We can't reach the highest element because of the averaging.
2799                 # So if one below the upper edge, force it there and try one
2800                 # more time.
2801                 if ($i == $range_list_size - 2) {
2802
2803                     trace "Forcing to upper edge" if main::DEBUG && $to_trace;
2804                     $i = $range_list_size - 1;
2805
2806                     # Change $lower as well so if fails next time through,
2807                     # taking the average will yield the same $i, and we will
2808                     # quit with the error message just below.
2809                     $lower = $i;
2810                     next;
2811                 }
2812                 Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go.  No action taken.");
2813                 return;
2814             }
2815             $i = $temp;
2816         } # End of while loop
2817
2818         if (main::DEBUG && $to_trace) {
2819             trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i;
2820             trace "i=  [ $i ]", $r->[$i];
2821             trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1;
2822         }
2823
2824         # Here we have found the offset.  Cache it as a starting point for the
2825         # next call.
2826         $_search_ranges_cache{$addr} = $i;
2827         return $i;
2828     }
2829
2830     sub _add_delete {
2831         # Add, replace or delete ranges to or from a list.  The $type
2832         # parameter gives which:
2833         #   '+' => insert or replace a range, returning a list of any changed
2834         #          ranges.
2835         #   '-' => delete a range, returning a list of any deleted ranges.
2836         #
2837         # The next three parameters give respectively the start, end, and
2838         # value associated with the range.  'value' should be null unless the
2839         # operation is '+';
2840         #
2841         # The range list is kept sorted so that the range with the lowest
2842         # starting position is first in the list, and generally, adjacent
2843         # ranges with the same values are merged into single larger one (see
2844         # exceptions below).
2845         #
2846         # There are more parameters, all are key => value pairs:
2847         #   Type    gives the type of the value.  It is only valid for '+'.
2848         #           All ranges have types; if this parameter is omitted, 0 is
2849         #           assumed.  Ranges with type 0 are assumed to obey the
2850         #           Unicode rules for casing, etc; ranges with other types are
2851         #           not.  Otherwise, the type is arbitrary, for the caller's
2852         #           convenience, and looked at only by this routine to keep
2853         #           adjacent ranges of different types from being merged into
2854         #           a single larger range, and when Replace =>
2855         #           $IF_NOT_EQUIVALENT is specified (see just below).
2856         #   Replace  determines what to do if the range list already contains
2857         #            ranges which coincide with all or portions of the input
2858         #            range.  It is only valid for '+':
2859         #       => $NO            means that the new value is not to replace
2860         #                         any existing ones, but any empty gaps of the
2861         #                         range list coinciding with the input range
2862         #                         will be filled in with the new value.
2863         #       => $UNCONDITIONALLY  means to replace the existing values with
2864         #                         this one unconditionally.  However, if the
2865         #                         new and old values are identical, the
2866         #                         replacement is skipped to save cycles
2867         #       => $IF_NOT_EQUIVALENT means to replace the existing values
2868         #                         with this one if they are not equivalent.
2869         #                         Ranges are equivalent if their types are the
2870         #                         same, and they are the same string, or if
2871         #                         both are type 0 ranges, if their Unicode
2872         #                         standard forms are identical.  In this last
2873         #                         case, the routine chooses the more "modern"
2874         #                         one to use.  This is because some of the
2875         #                         older files are formatted with values that
2876         #                         are, for example, ALL CAPs, whereas the
2877         #                         derived files have a more modern style,
2878         #                         which looks better.  By looking for this
2879         #                         style when the pre-existing and replacement
2880         #                         standard forms are the same, we can move to
2881         #                         the modern style
2882         #       => $MULTIPLE      means that if this range duplicates an
2883         #                         existing one, but has a different value,
2884         #                         don't replace the existing one, but insert
2885         #                         this, one so that the same range can occur
2886         #                         multiple times.
2887         #       => anything else  is the same as => $IF_NOT_EQUIVALENT
2888         #
2889         # "same value" means identical for type-0 ranges, and it means having
2890         # the same standard forms for non-type-0 ranges.
2891
2892         return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;
2893
2894         my $self = shift;
2895         my $operation = shift;   # '+' for add/replace; '-' for delete;
2896         my $start = shift;
2897         my $end   = shift;
2898         my $value = shift;
2899
2900         my %args = @_;
2901
2902         $value = "" if not defined $value;        # warning: $value can be "0"
2903
2904         my $replace = delete $args{'Replace'};
2905         $replace = $IF_NOT_EQUIVALENT unless defined $replace;
2906
2907         my $type = delete $args{'Type'};
2908         $type = 0 unless defined $type;
2909
2910         Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2911
2912         local $addr = main::objaddr($self) if ! defined $addr;
2913
2914         if ($operation ne '+' && $operation ne '-') {
2915             Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'.  No action taken.");
2916             return;
2917         }
2918         unless (defined $start && defined $end) {
2919             Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete.  No action taken.");
2920             return;
2921         }
2922         unless ($end >= $start) {
2923             Carp::my_carp_bug("$owner_name_of{$addr}End of range (" . sprintf("%04X", $end) . ") must not be before start (" . sprintf("%04X", $start) . ").  No action taken.");
2924             return;
2925         }
2926         #local $to_trace = 1 if main::DEBUG;
2927
2928         if ($operation eq '-') {
2929             if ($replace != $IF_NOT_EQUIVALENT) {
2930                 Carp::my_carp_bug("$owner_name_of{$addr}Replace => \$IF_NOT_EQUIVALENT is required when deleting a range from a range list.  Assuming Replace => \$IF_NOT_EQUIVALENT.");
2931                 $replace = $IF_NOT_EQUIVALENT;
2932             }
2933             if ($type) {
2934                 Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list.  Assuming Type => 0.");
2935                 $type = 0;
2936             }
2937             if ($value ne "") {
2938                 Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list.  Assuming Value => \"\".");
2939                 $value = "";
2940             }
2941         }
2942
2943         my $r = $ranges{$addr};               # The current list of ranges
2944         my $range_list_size = scalar @$r;     # And its size
2945         my $max = $max{$addr};                # The current high code point in
2946                                               # the list of ranges
2947
2948         # Do a special case requiring fewer machine cycles when the new range
2949         # starts after the current highest point.  The Unicode input data is
2950         # structured so this is common.
2951         if ($start > $max) {
2952
2953             trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
2954             return if $operation eq '-'; # Deleting a non-existing range is a
2955                                          # no-op
2956
2957             # If the new range doesn't logically extend the current final one
2958             # in the range list, create a new range at the end of the range
2959             # list.  (max cleverly is initialized to a negative number not
2960             # adjacent to 0 if the range list is empty, so even adding a range
2961             # to an empty range list starting at 0 will have this 'if'
2962             # succeed.)
2963             if ($start > $max + 1        # non-adjacent means can't extend.
2964                 || @{$r}[-1]->value ne $value # values differ, can't extend.
2965                 || @{$r}[-1]->type != $type # types differ, can't extend.
2966             ) {
2967                 push @$r, Range->new($start, $end,
2968                                      Value => $value,
2969                                      Type => $type);
2970             }
2971             else {
2972
2973                 # Here, the new range starts just after the current highest in
2974                 # the range list, and they have the same type and value.
2975                 # Extend the current range to incorporate the new one.
2976                 @{$r}[-1]->set_end($end);
2977             }
2978
2979             # This becomes the new maximum.
2980             $max{$addr} = $end;
2981
2982             return;
2983         }
2984         #local $to_trace = 0 if main::DEBUG;
2985
2986         trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace;
2987
2988         # Here, the input range isn't after the whole rest of the range list.
2989         # Most likely 'splice' will be needed.  The rest of the routine finds
2990         # the needed splice parameters, and if necessary, does the splice.
2991         # First, find the offset parameter needed by the splice function for
2992         # the input range.  Note that the input range may span multiple
2993         # existing ones, but we'll worry about that later.  For now, just find
2994         # the beginning.  If the input range is to be inserted starting in a
2995         # position not currently in the range list, it must (obviously) come
2996         # just after the range below it, and just before the range above it.
2997         # Slightly less obviously, it will occupy the position currently
2998         # occupied by the range that is to come after it.  More formally, we
2999         # are looking for the position, $i, in the array of ranges, such that:
3000         #
3001         # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end
3002         #
3003         # (The ordered relationships within existing ranges are also shown in
3004         # the equation above).  However, if the start of the input range is
3005         # within an existing range, the splice offset should point to that
3006         # existing range's position in the list; that is $i satisfies a
3007         # somewhat different equation, namely:
3008         #
3009         #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end
3010         #
3011         # More briefly, $start can come before or after r[$i]->start, and at
3012         # this point, we don't know which it will be.  However, these
3013         # two equations share these constraints:
3014         #
3015         #   r[$i-1]->end < $start <= r[$i]->end
3016         #
3017         # And that is good enough to find $i.
3018
3019         my $i = $self->_search_ranges($start);
3020         if (! defined $i) {
3021             Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined.  Operation '$operation' not performed");
3022             return;
3023         }
3024
3025         # The search function returns $i such that:
3026         #
3027         # r[$i-1]->end < $start <= r[$i]->end
3028         #
3029         # That means that $i points to the first range in the range list
3030         # that could possibly be affected by this operation.  We still don't
3031         # know if the start of the input range is within r[$i], or if it
3032         # points to empty space between r[$i-1] and r[$i].
3033         trace "[$i] is the beginning splice point.  Existing range there is ", $r->[$i] if main::DEBUG && $to_trace;
3034
3035         # Special case the insertion of data that is not to replace any
3036         # existing data.
3037         if ($replace == $NO) {  # If $NO, has to be operation '+'
3038             #local $to_trace = 1 if main::DEBUG;
3039             trace "Doesn't replace" if main::DEBUG && $to_trace;
3040
3041             # Here, the new range is to take effect only on those code points
3042             # that aren't already in an existing range.  This can be done by
3043             # looking through the existing range list and finding the gaps in
3044             # the ranges that this new range affects, and then calling this
3045             # function recursively on each of those gaps, leaving untouched
3046             # anything already in the list.  Gather up a list of the changed
3047             # gaps first so that changes to the internal state as new ranges
3048             # are added won't be a problem.
3049             my @gap_list;
3050
3051             # First, if the starting point of the input range is outside an
3052             # existing one, there is a gap from there to the beginning of the
3053             # existing range -- add a span to fill the part that this new
3054             # range occupies
3055             if ($start < $r->[$i]->start) {
3056                 push @gap_list, Range->new($start,
3057                                            main::min($end,
3058                                                      $r->[$i]->start - 1),
3059                                            Type => $type);
3060                 trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace;
3061             }
3062
3063             # Then look through the range list for other gaps until we reach
3064             # the highest range affected by the input one.
3065             my $j;
3066             for ($j = $i+1; $j < $range_list_size; $j++) {
3067                 trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace;
3068                 last if $end < $r->[$j]->start;
3069
3070                 # If there is a gap between when this range starts and the
3071                 # previous one ends, add a span to fill it.  Note that just
3072                 # because there are two ranges doesn't mean there is a
3073                 # non-zero gap between them.  It could be that they have
3074                 # different values or types
3075                 if ($r->[$j-1]->end + 1 != $r->[$j]->start) {
3076                     push @gap_list,
3077                         Range->new($r->[$j-1]->end + 1,
3078                                    $r->[$j]->start - 1,
3079                                    Type => $type);
3080                     trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace;
3081                 }
3082             }
3083
3084             # Here, we have either found an existing range in the range list,
3085             # beyond the area affected by the input one, or we fell off the
3086             # end of the loop because the input range affects the whole rest
3087             # of the range list.  In either case, $j is 1 higher than the
3088             # highest affected range.  If $j == $i, it means that there are no
3089             # affected ranges, that the entire insertion is in the gap between
3090             # r[$i-1], and r[$i], which we already have taken care of before
3091             # the loop.
3092             # On the other hand, if there are affected ranges, it might be
3093             # that there is a gap that needs filling after the final such
3094             # range to the end of the input range
3095             if ($r->[$j-1]->end < $end) {
3096                     push @gap_list, Range->new(main::max($start,
3097                                                          $r->[$j-1]->end + 1),
3098                                                $end,
3099                                                Type => $type);
3100                     trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace;
3101             }
3102
3103             # Call recursively to fill in all the gaps.
3104             foreach my $gap (@gap_list) {
3105                 $self->_add_delete($operation,
3106                                    $gap->start,
3107                                    $gap->end,
3108                                    $value,
3109                                    Type => $type);
3110             }
3111
3112             return;
3113         }
3114
3115         # Here, we have taken care of the case where $replace is $NO, which
3116         # means that whatever action we now take is done unconditionally.  It
3117         # still could be that this call will result in a no-op, if duplicates
3118         # aren't allowed, and we are inserting a range that merely duplicates
3119         # data already in the range list; or also if deleting a non-existent
3120         # range.
3121         # $i still points to the first potential affected range.  Now find the
3122         # highest range affected, which will determine the length parameter to
3123         # splice.  (The input range can span multiple existing ones.)  While
3124         # we are looking through the range list, see also if this is an
3125         # insertion that will change the values of at least one of the
3126         # affected ranges.  We don't need to do this check unless this is an
3127         # insertion of non-multiples, and also since this is a boolean, we
3128         # don't need to do it if have already determined that it will make a
3129         # change; just unconditionally change them.  $cdm is created to be 1
3130         # if either of these is true. (The 'c' in the name comes from below)
3131         my $cdm = ($operation eq '-' || $replace == $MULTIPLE);
3132         my $j;        # This will point to the highest affected range
3133
3134         # For non-zero types, the standard form is the value itself;
3135         my $standard_form = ($type) ? $value : main::standardize($value);
3136
3137         for ($j = $i; $j < $range_list_size; $j++) {
3138             trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace;
3139
3140             # If find a range that it doesn't overlap into, we can stop
3141             # searching
3142             last if $end < $r->[$j]->start;
3143
3144             # Here, overlaps the range at $j.  If the value's don't match,
3145             # and this is supposedly an insertion, it becomes a change
3146             # instead.  This is what the 'c' stands for in $cdm.
3147             if (! $cdm) {
3148                 if ($r->[$j]->standard_form ne $standard_form) {
3149                     $cdm = 1;
3150                 }
3151                 else {
3152
3153                     # Here, the two values are essentially the same.  If the
3154                     # two are actually identical, replacing wouldn't change
3155                     # anything so skip it.
3156                     my $pre_existing = $r->[$j]->value;
3157                     if ($pre_existing ne $value) {
3158
3159                         # Here the new and old standardized values are the
3160                         # same, but the non-standardized values aren't.  If
3161                         # replacing unconditionally, then replace
3162                         if( $replace == $UNCONDITIONALLY) {
3163                             $cdm = 1;
3164                         }
3165                         else {
3166
3167                             # Here, are replacing conditionally.  Decide to
3168                             # replace or not based on which appears to look
3169                             # the "nicest".  If one is mixed case and the
3170                             # other isn't, choose the mixed case one.
3171                             my $new_mixed = $value =~ /[A-Z]/
3172                                             && $value =~ /[a-z]/;
3173                             my $old_mixed = $pre_existing =~ /[A-Z]/
3174                                             && $pre_existing =~ /[a-z]/;
3175
3176                             if ($old_mixed != $new_mixed) {
3177                                 $cdm = 1 if $new_mixed;
3178                                 if (main::DEBUG && $to_trace) {
3179                                     if ($cdm) {
3180                                         trace "Replacing $pre_existing with $value";
3181                                     }
3182                                     else {
3183                                         trace "Retaining $pre_existing over $value";
3184                                     }
3185                                 }
3186                             }
3187                             else {
3188
3189                                 # Here casing wasn't different between the two.
3190                                 # If one has hyphens or underscores and the
3191                                 # other doesn't, choose the one with the
3192                                 # punctuation.
3193                                 my $new_punct = $value =~ /[-_]/;
3194                                 my $old_punct = $pre_existing =~ /[-_]/;
3195
3196                                 if ($old_punct != $new_punct) {
3197                                     $cdm = 1 if $new_punct;
3198                                     if (main::DEBUG && $to_trace) {
3199                                         if ($cdm) {
3200                                             trace "Replacing $pre_existing with $value";
3201                                         }
3202                                         else {
3203                                             trace "Retaining $pre_existing over $value";
3204                                         }
3205                                     }
3206                                 }   # else existing one is just as "good";
3207                                     # retain it to save cycles.
3208                             }
3209                         }
3210                     }
3211                 }
3212             }
3213         } # End of loop looking for highest affected range.
3214
3215         # Here, $j points to one beyond the highest range that this insertion
3216         # affects (hence to beyond the range list if that range is the final
3217         # one in the range list).
3218
3219         # The splice length is all the affected ranges.  Get it before
3220         # subtracting, for efficiency, so we don't have to later add 1.
3221         my $length = $j - $i;
3222
3223         $j--;        # $j now points to the highest affected range.
3224         trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;
3225
3226         # If inserting a multiple record, this is where it goes, after all the
3227         # existing ones for this range.  This implies an insertion, and no
3228         # change to any existing ranges.  Note that $j can be -1 if this new
3229         # range doesn't actually duplicate any existing, and comes at the
3230         # beginning of the list, in which case we can handle it like any other
3231         # insertion, and is easier to do so.
3232         if ($replace == $MULTIPLE && $j >= 0) {
3233
3234             # This restriction could be remedied with a little extra work, but
3235             # it won't hopefully ever be necessary
3236             if ($r->[$j]->start != $r->[$j]->end) {
3237                 Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple when the other range ($r->[$j]) contains more than one code point.  No action taken.");
3238                 return;
3239             }
3240
3241             # Don't add an exact duplicate, as it isn't really a multiple
3242             return if $value eq $r->[$j]->value && $type eq $r->[$j]->type;
3243
3244             trace "Adding multiple record at $j+1 with $start..$end, $value" if main::DEBUG && $to_trace;
3245             my @return = splice @$r,
3246                                 $j+1,
3247                                 0,
3248                                 Range->new($start,
3249                                            $end,
3250                                            Value => $value,
3251                                            Type => $type);
3252             if (main::DEBUG && $to_trace) {
3253                 trace "After splice:";
3254                 trace 'j-2=[', $j-2, ']', $r->[$j-2] if $j >= 2;
3255                 trace 'j-1=[', $j-1, ']', $r->[$j-1] if $j >= 1;
3256                 trace "j  =[", $j, "]", $r->[$j] if $j >= 0;
3257                 trace 'j+1=[', $j+1, ']', $r->[$j+1] if $j < @$r - 1;
3258                 trace 'j+2=[', $j+2, ']', $r->[$j+2] if $j < @$r - 2;
3259                 trace 'j+3=[', $j+3, ']', $r->[$j+3] if $j < @$r - 3;
3260             }
3261             return @return;
3262         }
3263
3264         # Here, have taken care of $NO and $MULTIPLE replaces.
3265         # $j points to the highest affected range.  But it can be < $i or even
3266         # -1.  These happen only if the insertion is entirely in the gap
3267         # between r[$i-1] and r[$i].  Here's why: j < i means that the j loop
3268         # above exited first time through with $end < $r->[$i]->start.  (And
3269         # then we subtracted one from j)  This implies also that $start <
3270         # $r->[$i]->start, but we know from above that $r->[$i-1]->end <
3271         # $start, so the entire input range is in the gap.
3272         if ($j < $i) {
3273
3274             # Here the entire input range is in the gap before $i.
3275
3276             if (main::DEBUG && $to_trace) {
3277                 if ($i) {
3278                     trace "Entire range is between $r->[$i-1] and $r->[$i]";
3279                 }
3280                 else {
3281                     trace "Entire range is before $r->[$i]";
3282                 }
3283             }
3284             return if $operation ne '+'; # Deletion of a non-existent range is
3285                                          # a no-op
3286         }
3287         else {
3288
3289             # Here the entire input range is not in the gap before $i.  There
3290             # is an affected one, and $j points to the highest such one.
3291
3292             # At this point, here is the situation:
3293             # This is not an insertion of a multiple, nor of tentative ($NO)
3294             # data.
3295             #   $i  points to the first element in the current range list that
3296             #            may be affected by this operation.  In fact, we know
3297             #            that the range at $i is affected because we are in
3298             #            the else branch of this 'if'
3299             #   $j  points to the highest affected range.
3300             # In other words,
3301             #   r[$i-1]->end < $start <= r[$i]->end
3302             # And:
3303             #   r[$i-1]->end < $start <= $end <= r[$j]->end
3304             #
3305             # Also:
3306             #   $cdm is a boolean which is set true if and only if this is a
3307             #        change or deletion (multiple was handled above).  In
3308             #        other words, it could be renamed to be just $cd.
3309
3310             # We now have enough information to decide if this call is a no-op
3311             # or not.  It is a no-op if it is a deletion of a non-existent
3312             # range, or an insertion of already existing data.
3313
3314             if (main::DEBUG && $to_trace && ! $cdm
3315                                          && $i == $j
3316                                          && $start >= $r->[$i]->start)
3317             {
3318                     trace "no-op";
3319             }
3320             return if ! $cdm      # change or delete => not no-op
3321                       && $i == $j # more than one affected range => not no-op
3322
3323                       # Here, r[$i-1]->end < $start <= $end <= r[$i]->end
3324                       # Further, $start and/or $end is >= r[$i]->start
3325                       # The test below hence guarantees that
3326                       #     r[$i]->start < $start <= $end <= r[$i]->end
3327                       # This means the input range is contained entirely in
3328                       # the one at $i, so is a no-op
3329                       && $start >= $r->[$i]->start;
3330         }
3331
3332         # Here, we know that some action will have to be taken.  We have
3333         # calculated the offset and length (though adjustments may be needed)
3334         # for the splice.  Now start constructing the replacement list.
3335         my @replacement;
3336         my $splice_start = $i;
3337
3338         my $extends_below;
3339         my $extends_above;
3340
3341         # See if should extend any adjacent ranges.
3342         if ($operation eq '-') { # Don't extend deletions
3343             $extends_below = $extends_above = 0;
3344         }
3345         else {  # Here, should extend any adjacent ranges.  See if there are
3346                 # any.
3347             $extends_below = ($i > 0
3348                             # can't extend unless adjacent
3349                             && $r->[$i-1]->end == $start -1
3350                             # can't extend unless are same standard value
3351                             && $r->[$i-1]->standard_form eq $standard_form
3352                             # can't extend unless share type
3353                             && $r->[$i-1]->type == $type);
3354             $extends_above = ($j+1 < $range_list_size
3355                             && $r->[$j+1]->start == $end +1
3356                             && $r->[$j+1]->standard_form eq $standard_form
3357                             && $r->[$j-1]->type == $type);
3358         }
3359         if ($extends_below && $extends_above) { # Adds to both
3360             $splice_start--;     # start replace at element below
3361             $length += 2;        # will replace on both sides
3362             trace "Extends both below and above ranges" if main::DEBUG && $to_trace;
3363
3364             # The result will fill in any gap, replacing both sides, and
3365             # create one large range.
3366             @replacement = Range->new($r->[$i-1]->start,
3367                                       $r->[$j+1]->end,
3368                                       Value => $value,
3369                                       Type => $type);
3370         }
3371         else {
3372
3373             # Here we know that the result won't just be the conglomeration of
3374             # a new range with both its adjacent neighbors.  But it could
3375             # extend one of them.
3376
3377             if ($extends_below) {
3378
3379                 # Here the new element adds to the one below, but not to the
3380                 # one above.  If inserting, and only to that one range,  can
3381                 # just change its ending to include the new one.
3382                 if ($length == 0 && ! $cdm) {
3383                     $r->[$i-1]->set_end($end);
3384                     trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace;
3385                     return;
3386                 }
3387                 else {
3388                     trace "Changing inserted range to start at ", sprintf("%04X",  $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace;
3389                     $splice_start--;        # start replace at element below
3390                     $length++;              # will replace the element below
3391                     $start = $r->[$i-1]->start;
3392                 }
3393             }
3394             elsif ($extends_above) {
3395
3396                 # Here the new element adds to the one above, but not below.
3397                 # Mirror the code above
3398                 if ($length == 0 && ! $cdm) {
3399                     $r->[$j+1]->set_start($start);
3400                     trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace;
3401                     return;
3402                 }
3403                 else {
3404                     trace "Changing inserted range to end at ", sprintf("%04X",  $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace;
3405                     $length++;        # will replace the element above
3406                     $end = $r->[$j+1]->end;
3407                 }
3408             }
3409
3410             trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace;
3411
3412             # Finally, here we know there will have to be a splice.
3413             # If the change or delete affects only the highest portion of the
3414             # first affected range, the range will have to be split.  The
3415             # splice will remove the whole range, but will replace it by a new
3416             # range containing just the unaffected part.  So, in this case,
3417             # add to the replacement list just this unaffected portion.
3418             if (! $extends_below
3419                 && $start > $r->[$i]->start && $start <= $r->[$i]->end)
3420             {
3421                 push @replacement,
3422                     Range->new($r->[$i]->start,
3423                                $start - 1,
3424                                Value => $r->[$i]->value,
3425                                Type => $r->[$i]->type);
3426             }
3427
3428             # In the case of an insert or change, but not a delete, we have to
3429             # put in the new stuff;  this comes next.
3430             if ($operation eq '+') {
3431                 push @replacement, Range->new($start,
3432                                               $end,
3433                                               Value => $value,
3434                                               Type => $type);
3435             }
3436
3437             trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i;
3438             #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace;
3439
3440             # And finally, if we're changing or deleting only a portion of the
3441             # highest affected range, it must be split, as the lowest one was.
3442             if (! $extends_above
3443                 && $j >= 0  # Remember that j can be -1 if before first
3444                             # current element
3445                 && $end >= $r->[$j]->start
3446                 && $end < $r->[$j]->end)
3447             {
3448                 push @replacement,
3449                     Range->new($end + 1,
3450                                $r->[$j]->end,
3451                                Value => $r->[$j]->value,
3452                                Type => $r->[$j]->type);
3453             }
3454         }
3455
3456         # And do the splice, as calculated above
3457         if (main::DEBUG && $to_trace) {
3458             trace "replacing $length element(s) at $i with ";
3459             foreach my $replacement (@replacement) {
3460                 trace "    $replacement";
3461             }
3462             trace "Before splice:";
3463             trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3464             trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3465             trace "i  =[", $i, "]", $r->[$i];
3466             trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3467             trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3468         }
3469
3470         my @return = splice @$r, $splice_start, $length, @replacement;
3471
3472         if (main::DEBUG && $to_trace) {
3473             trace "After splice:";
3474             trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3475             trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3476             trace "i  =[", $i, "]", $r->[$i];
3477             trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3478             trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3479             trace "removed @return";
3480         }
3481
3482         # An actual deletion could have changed the maximum in the list.
3483         # There was no deletion if the splice didn't return something, but
3484         # otherwise recalculate it.  This is done too rarely to worry about
3485         # performance.
3486         if ($operation eq '-' && @return) {
3487             $max{$addr} = $r->[-1]->end;
3488         }
3489         return @return;
3490     }
3491
3492     sub reset_each_range {  # reset the iterator for each_range();
3493         my $self = shift;
3494         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3495
3496         local $addr = main::objaddr $self if ! defined $addr;
3497
3498         undef $each_range_iterator{$addr};
3499         return;
3500     }
3501
3502     sub each_range {
3503         # Iterate over each range in a range list.  Results are undefined if
3504         # the range list is changed during the iteration.
3505
3506         my $self = shift;
3507         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3508
3509         local $addr = main::objaddr($self) if ! defined $addr;
3510
3511         return if $self->is_empty;
3512
3513         $each_range_iterator{$addr} = -1
3514                                 if ! defined $each_range_iterator{$addr};
3515         $each_range_iterator{$addr}++;
3516         return $ranges{$addr}->[$each_range_iterator{$addr}]
3517                         if $each_range_iterator{$addr} < @{$ranges{$addr}};
3518         undef $each_range_iterator{$addr};
3519         return;
3520     }
3521
3522     sub count {        # Returns count of code points in range list
3523         my $self = shift;
3524         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3525
3526         local $addr = main::objaddr($self) if ! defined $addr;
3527
3528         my $count = 0;
3529         foreach my $range (@{$ranges{$addr}}) {
3530             $count += $range->end - $range->start + 1;
3531         }
3532         return $count;
3533     }
3534
3535     sub delete_range {    # Delete a range
3536         my $self = shift;
3537         my $start = shift;
3538         my $end = shift;
3539
3540         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3541
3542         return $self->_add_delete('-', $start, $end, "");
3543     }
3544
3545     sub is_empty { # Returns boolean as to if a range list is empty
3546         my $self = shift;
3547         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3548
3549         local $addr = main::objaddr($self) if ! defined $addr;
3550         return scalar @{$ranges{$addr}} == 0;
3551     }
3552
3553     sub hash {
3554         # Quickly returns a scalar suitable for separating tables into
3555         # buckets, i.e. it is a hash function of the contents of a table, so
3556         # there are relatively few conflicts.
3557
3558         my $self = shift;
3559         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3560
3561         local $addr = main::objaddr($self) if ! defined $addr;
3562
3563         # These are quickly computable.  Return looks like 'min..max;count'
3564         return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
3565     }
3566 } # End closure for _Range_List_Base
3567
3568 package Range_List;
3569 use base '_Range_List_Base';
3570
3571 # A Range_List is a range list for match tables; i.e. the range values are
3572 # not significant.  Thus a number of operations can be safely added to it,
3573 # such as inversion, intersection.  Note that union is also an unsafe
3574 # operation when range values are cared about, and that method is in the base
3575 # class, not here.  But things are set up so that that method is callable only
3576 # during initialization.  Only in this derived class, is there an operation
3577 # that combines two tables.  A Range_Map can thus be used to initialize a
3578 # Range_List, and its mappings will be in the list, but are not significant to
3579 # this class.
3580
3581 sub trace { return main::trace(@_); }
3582
3583 { # Closure
3584
3585     use overload
3586         fallback => 0,
3587         '+' => sub { my $self = shift;
3588                     my $other = shift;
3589
3590                     return $self->_union($other)
3591                 },
3592         '&' => sub { my $self = shift;
3593                     my $other = shift;
3594
3595                     return $self->_intersect($other, 0);
3596                 },
3597         '~' => "_invert",
3598         '-' => "_subtract",
3599     ;
3600
3601     sub _invert {
3602         # Returns a new Range_List that gives all code points not in $self.
3603
3604         my $self = shift;
3605
3606         my $new = Range_List->new;
3607
3608         # Go through each range in the table, finding the gaps between them
3609         my $max = -1;   # Set so no gap before range beginning at 0
3610         for my $range ($self->ranges) {
3611             my $start = $range->start;
3612             my $end   = $range->end;
3613
3614             # If there is a gap before this range, the inverse will contain
3615             # that gap.
3616             if ($start > $max + 1) {
3617                 $new->add_range($max + 1, $start - 1);
3618             }
3619             $max = $end;
3620         }
3621
3622         # And finally, add the gap from the end of the table to the max
3623         # possible code point
3624         if ($max < $LAST_UNICODE_CODEPOINT) {
3625             $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
3626         }
3627         return $new;
3628     }
3629
3630     sub _subtract {
3631         # Returns a new Range_List with the argument deleted from it.  The
3632         # argument can be a single code point, a range, or something that has
3633         # a range, with the _range_list() method on it returning them
3634
3635         my $self = shift;
3636         my $other = shift;
3637         my $reversed = shift;
3638         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3639
3640         if ($reversed) {
3641             Carp::my_carp_bug("Can't cope with a "
3642              .  __PACKAGE__
3643              . " being the second parameter in a '-'.  Subtraction ignored.");
3644             return $self;
3645         }
3646
3647         my $new = Range_List->new(Initialize => $self);
3648
3649         if (! ref $other) { # Single code point
3650             $new->delete_range($other, $other);
3651         }
3652         elsif ($other->isa('Range')) {
3653             $new->delete_range($other->start, $other->end);
3654         }
3655         elsif ($other->can('_range_list')) {
3656             foreach my $range ($other->_range_list->ranges) {
3657                 $new->delete_range($range->start, $range->end);
3658             }
3659         }
3660         else {
3661             Carp::my_carp_bug("Can't cope with a "
3662                         . ref($other)
3663                         . " argument to '-'.  Subtraction ignored."
3664                         );
3665             return $self;
3666         }
3667
3668         return $new;
3669     }
3670
3671     sub _intersect {
3672         # Returns either a boolean giving whether the two inputs' range lists
3673         # intersect (overlap), or a new Range_List containing the intersection
3674         # of the two lists.  The optional final parameter being true indicates
3675         # to do the check instead of the intersection.
3676
3677         my $a_object = shift;
3678         my $b_object = shift;
3679         my $check_if_overlapping = shift;
3680         $check_if_overlapping = 0 unless defined $check_if_overlapping;
3681         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3682
3683         if (! defined $b_object) {
3684             my $message = "";
3685             $message .= $a_object->_owner_name_of if defined $a_object;
3686             Carp::my_carp_bug($message .= "Called with undefined value.  Intersection not done.");
3687             return;
3688         }
3689
3690         # a & b = !(!a | !b), or in our terminology = ~ ( ~a + -b )
3691         # Thus the intersection could be much more simply be written:
3692         #   return ~(~$a_object + ~$b_object);
3693         # But, this is slower, and when taking the inverse of a large
3694         # range_size_1 table, back when such tables were always stored that
3695         # way, it became prohibitively slow, hence the code was changed to the
3696         # below
3697
3698         if ($b_object->isa('Range')) {
3699             $b_object = Range_List->new(Initialize => $b_object,
3700                                         Owner => $a_object->_owner_name_of);
3701         }
3702         $b_object = $b_object->_range_list if $b_object->can('_range_list');
3703
3704         my @a_ranges = $a_object->ranges;
3705         my @b_ranges = $b_object->ranges;
3706
3707         #local $to_trace = 1 if main::DEBUG;
3708         trace "intersecting $a_object with ", scalar @a_ranges, "ranges and $b_object with", scalar @b_ranges, " ranges" if main::DEBUG && $to_trace;
3709
3710         # Start with the first range in each list
3711         my $a_i = 0;
3712         my $range_a = $a_ranges[$a_i];
3713         my $b_i = 0;
3714         my $range_b = $b_ranges[$b_i];
3715
3716         my $new = __PACKAGE__->new(Owner => $a_object->_owner_name_of)
3717                                                 if ! $check_if_overlapping;
3718
3719         # If either list is empty, there is no intersection and no overlap
3720         if (! defined $range_a || ! defined $range_b) {
3721             return $check_if_overlapping ? 0 : $new;
3722         }
3723         trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
3724
3725         # Otherwise, must calculate the intersection/overlap.  Start with the
3726         # very first code point in each list
3727         my $a = $range_a->start;
3728         my $b = $range_b->start;
3729
3730         # Loop through all the ranges of each list; in each iteration, $a and
3731         # $b are the current code points in their respective lists
3732         while (1) {
3733
3734             # If $a and $b are the same code point, ...
3735             if ($a == $b) {
3736
3737                 # it means the lists overlap.  If just checking for overlap
3738                 # know the answer now,
3739                 return 1 if $check_if_overlapping;
3740
3741                 # The intersection includes this code point plus anything else
3742                 # common to both current ranges.
3743                 my $start = $a;
3744                 my $end = main::min($range_a->end, $range_b->end);
3745                 if (! $check_if_overlapping) {
3746                     trace "adding intersection range ", sprintf("%04X", $start) . ".." . sprintf("%04X", $end) if main::DEBUG && $to_trace;
3747                     $new->add_range($start, $end);
3748                 }
3749
3750                 # Skip ahead to the end of the current intersect
3751                 $a = $b = $end;
3752
3753                 # If the current intersect ends at the end of either range (as
3754                 # it must for at least one of them), the next possible one
3755                 # will be the beginning code point in it's list's next range.
3756                 if ($a == $range_a->end) {
3757                     $range_a = $a_ranges[++$a_i];
3758                     last unless defined $range_a;
3759                     $a = $range_a->start;
3760                 }
3761                 if ($b == $range_b->end) {
3762                     $range_b = $b_ranges[++$b_i];
3763                     last unless defined $range_b;
3764                     $b = $range_b->start;
3765                 }
3766
3767                 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
3768             }
3769             elsif ($a < $b) {
3770
3771                 # Not equal, but if the range containing $a encompasses $b,
3772                 # change $a to be the middle of the range where it does equal
3773                 # $b, so the next iteration will get the intersection
3774                 if ($range_a->end >= $b) {
3775                     $a = $b;
3776                 }
3777                 else {
3778
3779                     # Here, the current range containing $a is entirely below
3780                     # $b.  Go try to find a range that could contain $b.
3781                     $a_i = $a_object->_search_ranges($b);
3782
3783                     # If no range found, quit.
3784                     last unless defined $a_i;
3785
3786                     # The search returns $a_i, such that
3787                     #   range_a[$a_i-1]->end < $b <= range_a[$a_i]->end
3788                     # Set $a to the beginning of this new range, and repeat.
3789                     $range_a = $a_ranges[$a_i];
3790                     $a = $range_a->start;
3791                 }
3792             }
3793             else { # Here, $b < $a.
3794
3795                 # Mirror image code to the leg just above
3796                 if ($range_b->end >= $a) {
3797                     $b = $a;
3798                 }
3799                 else {
3800                     $b_i = $b_object->_search_ranges($a);
3801                     last unless defined $b_i;
3802                     $range_b = $b_ranges[$b_i];
3803                     $b = $range_b->start;
3804                 }
3805             }
3806         } # End of looping through ranges.
3807
3808         # Intersection fully computed, or now know that there is no overlap
3809         return $check_if_overlapping ? 0 : $new;
3810     }
3811
3812     sub overlaps {
3813         # Returns boolean giving whether the two arguments overlap somewhere
3814
3815         my $self = shift;
3816         my $other = shift;
3817         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3818
3819         return $self->_intersect($other, 1);
3820     }
3821
3822     sub add_range {
3823         # Add a range to the list.
3824
3825         my $self = shift;
3826         my $start = shift;
3827         my $end = shift;
3828         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3829
3830         return $self->_add_delete('+', $start, $end, "");
3831     }
3832
3833     my $non_ASCII = (ord('A') != 65);   # Assumes test on same platform
3834
3835     sub is_code_point_usable {
3836         # This used only for making the test script.  See if the input
3837         # proposed trial code point is one that Perl will handle.  If second
3838         # parameter is 0, it won't select some code points for various
3839         # reasons, noted below.
3840
3841         my $code = shift;
3842         my $try_hard = shift;
3843         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3844
3845         return 0 if $code < 0;                # Never use a negative
3846
3847         # For non-ASCII, we shun the characters that don't have Perl encoding-
3848         # independent symbols for them.  'A' is such a symbol, so is "\n".
3849         # Note, this program hopefully will work on 5.8 Perls, and \v is not
3850         # such a symbol in them.
3851         return $try_hard if $non_ASCII
3852                             && $code <= 0xFF
3853                             && ($code >= 0x7F
3854                                 || ($code >= 0x0E && $code <= 0x1F)
3855                                 || ($code >= 0x01 && $code <= 0x06)
3856                                 || $code == 0x0B);  # \v introduced after 5.8
3857
3858         # shun null.  I'm (khw) not sure why this was done, but NULL would be
3859         # the character very frequently used.
3860         return $try_hard if $code == 0x0000;
3861
3862         return 0 if $try_hard;  # XXX Temporary until fix utf8.c
3863
3864         # shun non-character code points.
3865         return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
3866         return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
3867
3868         return $try_hard if $code > $LAST_UNICODE_CODEPOINT;   # keep in range
3869         return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
3870
3871         return 1;
3872     }
3873
3874     sub get_valid_code_point {
3875         # Return a code point that's part of the range list.  Returns nothing
3876         # if the table is empty or we can't find a suitable code point.  This
3877         # used only for making the test script.
3878
3879         my $self = shift;
3880         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3881
3882         my $addr = main::objaddr($self);
3883
3884         # On first pass, don't choose less desirable code points; if no good
3885         # one is found, repeat, allowing a less desirable one to be selected.
3886         for my $try_hard (0, 1) {
3887
3888             # Look through all the ranges for a usable code point.
3889             for my $set ($self->ranges) {
3890
3891                 # Try the edge cases first, starting with the end point of the
3892                 # range.
3893                 my $end = $set->end;
3894                 return $end if is_code_point_usable($end, $try_hard);
3895
3896                 # End point didn't, work.  Start at the beginning and try
3897                 # every one until find one that does work.
3898                 for my $trial ($set->start .. $end - 1) {
3899                     return $trial if is_code_point_usable($trial, $try_hard);
3900                 }
3901             }
3902         }
3903         return ();  # If none found, give up.
3904     }
3905
3906     sub get_invalid_code_point {
3907         # Return a code point that's not part of the table.  Returns nothing
3908         # if the table covers all code points or a suitable code point can't
3909         # be found.  This used only for making the test script.
3910
3911         my $self = shift;
3912         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3913
3914         # Just find a valid code point of the inverse, if any.
3915         return Range_List->new(Initialize => ~ $self)->get_valid_code_point;
3916     }
3917 } # end closure for Range_List
3918
3919 package Range_Map;
3920 use base '_Range_List_Base';
3921
3922 # A Range_Map is a range list in which the range values (called maps) are
3923 # significant, and hence shouldn't be manipulated by our other code, which
3924 # could be ambiguous or lose things.  For example, in taking the union of two
3925 # lists, which share code points, but which have differing values, which one
3926 # has precedence in the union?
3927 # It turns out that these operations aren't really necessary for map tables,
3928 # and so this class was created to make sure they aren't accidentally
3929 # applied to them.
3930
3931 { # Closure
3932
3933     sub add_map {
3934         # Add a range containing a mapping value to the list
3935
3936         my $self = shift;
3937         # Rest of parameters passed on
3938
3939         return $self->_add_delete('+', @_);
3940     }
3941
3942     sub add_duplicate {
3943         # Adds entry to a range list which can duplicate an existing entry
3944
3945         my $self = shift;
3946         my $code_point = shift;
3947         my $value = shift;
3948         Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3949
3950         return $self->add_map($code_point, $code_point,
3951                                 $value, Replace => $MULTIPLE);
3952     }
3953 } # End of closure for package Range_Map
3954
3955 package _Base_Table;
3956
3957 # A table is the basic data structure that gets written out into a file for
3958 # use by the Perl core.  This is the abstract base class implementing the
3959 # common elements from the derived ones.  A list of the methods to be
3960 # furnished by an implementing class is just after the constructor.
3961
3962 sub standardize { return main::standardize($_[0]); }
3963 sub trace { return main::trace(@_); }
3964
3965 { # Closure
3966
3967     main::setup_package();
3968
3969     my %range_list;
3970     # Object containing the ranges of the table.
3971     main::set_access('range_list', \%range_list, 'p_r', 'p_s');
3972
3973     my %full_name;
3974     # The full table name.
3975     main::set_access('full_name', \%full_name, 'r');
3976
3977     my %name;
3978     # The table name, almost always shorter
3979     main::set_access('name', \%name, 'r');
3980
3981     my %short_name;
3982     # The shortest of all the aliases for this table, with underscores removed
3983     main::set_access('short_name', \%short_name);
3984
3985     my %nominal_short_name_length;
3986     # The length of short_name before removing underscores
3987     main::set_access('nominal_short_name_length',
3988                     \%nominal_short_name_length);
3989
3990     my %complete_name;
3991     # The complete name, including property.
3992     main::set_access('complete_name', \%complete_name, 'r');
3993
3994     my %property;
3995     # Parent property this table is attached to.
3996     main::set_access('property', \%property, 'r');
3997
3998     my %aliases;
3999     # Ordered list of aliases of the table's name.  The first ones in the list
4000     # are output first in comments
4001     main::set_access('aliases', \%aliases, 'readable_array');
4002
4003     my %comment;
4004     # A comment associated with the table for human readers of the files
4005     main::set_access('comment', \%comment, 's');
4006
4007     my %description;
4008     # A comment giving a short description of the table's meaning for human
4009     # readers of the files.
4010