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