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