[perl5.git] / lib / unicore / mktables

#!/usr/bin/perl -w

# !!!!!!!!!!!!!!       IF YOU MODIFY THIS FILE       !!!!!!!!!!!!!!!!!!!!!!!!!
# Any files created or read by this program should be listed in 'mktables.lst'
# Use -makelist to regenerate it.

# Needs 'no overloading' to run faster on miniperl.  Code commented out at the
# subroutine objaddr can be used instead to work as far back (untested) as
# 5.8: needs pack "U".  But almost all occurrences of objaddr have been
# removed in favor of using 'no overloading'.  You also would have to go
# through and replace occurrences like:
#       my $addr = do { no overloading; pack 'J', $self; }
# with
#       my $addr = main::objaddr $self;
# (or reverse commit 9b01bafde4b022706c3d6f947a0963f821b2e50b
# that instituted the change to main::objaddr, and subsequent commits that
# changed 0+$self to pack 'J', $self.)

my $start_time;
BEGIN { # Get the time the script started running; do it at compilation to
        # get it as close as possible
    $start_time= time;
}


require 5.010_001;
use strict;
use warnings;
use Carp;
use Config;
use File::Find;
use File::Path;
use File::Spec;
use Text::Tabs;

sub DEBUG () { 0 }  # Set to 0 for production; 1 for development
my $debugging_build = $Config{"ccflags"} =~ /-DDEBUGGING/;

##########################################################################
#
# mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
# from the Unicode database files (lib/unicore/.../*.txt),  It also generates
# a pod file and a .t file
#
# The structure of this file is:
#   First these introductory comments; then
#   code needed for everywhere, such as debugging stuff; then
#   code to handle input parameters; then
#   data structures likely to be of external interest (some of which depend on
#       the input parameters, so follows them; then
#   more data structures and subroutine and package (class) definitions; then
#   the small actual loop to process the input files and finish up; then
#   a __DATA__ section, for the .t tests
#
# This program works on all releases of Unicode through at least 6.0.  The
# outputs have been scrutinized most intently for release 5.1.  The others
# have been checked for somewhat more than just sanity.  It can handle all
# existing Unicode character properties in those releases.
#
# This program is mostly about Unicode character (or code point) properties.
# A property describes some attribute or quality of a code point, like if it
# is lowercase or not, its name, what version of Unicode it was first defined
# in, or what its uppercase equivalent is.  Unicode deals with these disparate
# possibilities by making all properties into mappings from each code point
# into some corresponding value.  In the case of it being lowercase or not,
# the mapping is either to 'Y' or 'N' (or various synonyms thereof).  Each
# property maps each Unicode code point to a single value, called a "property
# value".  (Hence each Unicode property is a true mathematical function with
# exactly one value per code point.)
#
# When using a property in a regular expression, what is desired isn't the
# mapping of the code point to its property's value, but the reverse (or the
# mathematical "inverse relation"): starting with the property value, "Does a
# code point map to it?"  These are written in a "compound" form:
# \p{property=value}, e.g., \p{category=punctuation}.  This program generates
# files containing the lists of code points that map to each such regular
# expression property value, one file per list
#
# There is also a single form shortcut that Perl adds for many of the commonly
# used properties.  This happens for all binary properties, plus script,
# general_category, and block properties.
#
# Thus the outputs of this program are files.  There are map files, mostly in
# the 'To' directory; and there are list files for use in regular expression
# matching, all in subdirectories of the 'lib' directory, with each
# subdirectory being named for the property that the lists in it are for.
# Bookkeeping, test, and documentation files are also generated.

my $matches_directory = 'lib';   # Where match (\p{}) files go.
my $map_directory = 'To';        # Where map files go.

# DATA STRUCTURES
#
# The major data structures of this program are Property, of course, but also
# Table.  There are two kinds of tables, very similar to each other.
# "Match_Table" is the data structure giving the list of code points that have
# a particular property value, mentioned above.  There is also a "Map_Table"
# data structure which gives the property's mapping from code point to value.
# There are two structures because the match tables need to be combined in
# various ways, such as constructing unions, intersections, complements, etc.,
# and the map ones don't.  And there would be problems, perhaps subtle, if
# a map table were inadvertently operated on in some of those ways.
# The use of separate classes with operations defined on one but not the other
# prevents accidentally confusing the two.
#
# At the heart of each table's data structure is a "Range_List", which is just
# an ordered list of "Ranges", plus ancillary information, and methods to
# operate on them.  A Range is a compact way to store property information.
# Each range has a starting code point, an ending code point, and a value that
# is meant to apply to all the code points between the two end points,
# inclusive.  For a map table, this value is the property value for those
# code points.  Two such ranges could be written like this:
#   0x41 .. 0x5A, 'Upper',
#   0x61 .. 0x7A, 'Lower'
#
# Each range also has a type used as a convenience to classify the values.
# Most ranges in this program will be Type 0, or normal, but there are some
# ranges that have a non-zero type.  These are used only in map tables, and
# are for mappings that don't fit into the normal scheme of things.  Mappings
# that require a hash entry to communicate with utf8.c are one example;
# another example is mappings for charnames.pm to use which indicate a name
# that is algorithmically determinable from its code point (and vice-versa).
# These are used to significantly compact these tables, instead of listing
# each one of the tens of thousands individually.
#
# In a match table, the value of a range is irrelevant (and hence the type as
# well, which will always be 0), and arbitrarily set to the null string.
# Using the example above, there would be two match tables for those two
# entries, one named Upper would contain the 0x41..0x5A range, and the other
# named Lower would contain 0x61..0x7A.
#
# Actually, there are two types of range lists, "Range_Map" is the one
# associated with map tables, and "Range_List" with match tables.
# Again, this is so that methods can be defined on one and not the other so as
# to prevent operating on them in incorrect ways.
#
# Eventually, most tables are written out to files to be read by utf8_heavy.pl
# in the perl core.  All tables could in theory be written, but some are
# suppressed because there is no current practical use for them.  It is easy
# to change which get written by changing various lists that are near the top
# of the actual code in this file.  The table data structures contain enough
# ancillary information to allow them to be treated as separate entities for
# writing, such as the path to each one's file.  There is a heading in each
# map table that gives the format of its entries, and what the map is for all
# the code points missing from it.  (This allows tables to be more compact.)
#
# The Property data structure contains one or more tables.  All properties
# contain a map table (except the $perl property which is a
# pseudo-property containing only match tables), and any properties that
# are usable in regular expression matches also contain various matching
# tables, one for each value the property can have.  A binary property can
# have two values, True and False (or Y and N, which are preferred by Unicode
# terminology).  Thus each of these properties will have a map table that
# takes every code point and maps it to Y or N (but having ranges cuts the
# number of entries in that table way down), and two match tables, one
# which has a list of all the code points that map to Y, and one for all the
# code points that map to N.  (For each of these, a third table is also
# generated for the pseudo Perl property.  It contains the identical code
# points as the Y table, but can be written, not in the compound form, but in
# a "single" form like \p{IsUppercase}.)  Many properties are binary, but some
# properties have several possible values, some have many, and properties like
# Name have a different value for every named code point.  Those will not,
# unless the controlling lists are changed, have their match tables written
# out.  But all the ones which can be used in regular expression \p{} and \P{}
# constructs will.  Generally a property will have either its map table or its
# match tables written but not both.  Again, what gets written is controlled
# by lists which can easily be changed.  Properties have a 'Type', like
# binary, or string, or enum depending on how many match tables there are and
# the content of the maps.  This 'Type' is different than a range 'Type', so
# don't get confused by the two concepts having the same name.
#
# For information about the Unicode properties, see Unicode's UAX44 document:

my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';

# As stated earlier, this program will work on any release of Unicode so far.
# Most obvious problems in earlier data have NOT been corrected except when
# necessary to make Perl or this program work reasonably.  For example, no
# folding information was given in early releases, so this program uses the
# substitute of lower case, just so that a regular expression with the /i
# option will do something that actually gives the right results in many
# cases.  There are also a couple other corrections for version 1.1.5,
# commented at the point they are made.  As an example of corrections that
# weren't made (but could be) is this statement from DerivedAge.txt: "The
# supplementary private use code points and the non-character code points were
# assigned in version 2.0, but not specifically listed in the UCD until
# versions 3.0 and 3.1 respectively."  (To be precise it was 3.0.1 not 3.0.0)
# More information on Unicode version glitches is further down in these
# introductory comments.
#
# This program works on all non-provisional properties as of 6.0, though the
# files for some are suppressed from apparent lack of demand for them.  You
# can change which are output by changing lists in this program.
#
# The old version of mktables emphasized the term "Fuzzy" to mean Unicode's
# loose matchings rules (from Unicode TR18):
#
#    The recommended names for UCD properties and property values are in
#    PropertyAliases.txt [Prop] and PropertyValueAliases.txt
#    [PropValue]. There are both abbreviated names and longer, more
#    descriptive names. It is strongly recommended that both names be
#    recognized, and that loose matching of property names be used,
#    whereby the case distinctions, whitespace, hyphens, and underbar
#    are ignored.
# The program still allows Fuzzy to override its determination of if loose
# matching should be used, but it isn't currently used, as it is no longer
# needed; the calculations it makes are good enough.
#
# SUMMARY OF HOW IT WORKS:
#
#   Process arguments
#
#   A list is constructed containing each input file that is to be processed
#
#   Each file on the list is processed in a loop, using the associated handler
#   code for each:
#        The PropertyAliases.txt and PropValueAliases.txt files are processed
#            first.  These files name the properties and property values.
#            Objects are created of all the property and property value names
#            that the rest of the input should expect, including all synonyms.
#        The other input files give mappings from properties to property
#           values.  That is, they list code points and say what the mapping
#           is under the given property.  Some files give the mappings for
#           just one property; and some for many.  This program goes through
#           each file and populates the properties from them.  Some properties
#           are listed in more than one file, and Unicode has set up a
#           precedence as to which has priority if there is a conflict.  Thus
#           the order of processing matters, and this program handles the
#           conflict possibility by processing the overriding input files
#           last, so that if necessary they replace earlier values.
#        After this is all done, the program creates the property mappings not
#            furnished by Unicode, but derivable from what it does give.
#        The tables of code points that match each property value in each
#            property that is accessible by regular expressions are created.
#        The Perl-defined properties are created and populated.  Many of these
#            require data determined from the earlier steps
#        Any Perl-defined synonyms are created, and name clashes between Perl
#            and Unicode are reconciled and warned about.
#        All the properties are written to files
#        Any other files are written, and final warnings issued.
#
# For clarity, a number of operators have been overloaded to work on tables:
#   ~ means invert (take all characters not in the set).  The more
#       conventional '!' is not used because of the possibility of confusing
#       it with the actual boolean operation.
#   + means union
#   - means subtraction
#   & means intersection
# The precedence of these is the order listed.  Parentheses should be
# copiously used.  These are not a general scheme.  The operations aren't
# defined for a number of things, deliberately, to avoid getting into trouble.
# Operations are done on references and affect the underlying structures, so
# that the copy constructors for them have been overloaded to not return a new
# clone, but the input object itself.
#
# The bool operator is deliberately not overloaded to avoid confusion with
# "should it mean if the object merely exists, or also is non-empty?".
#
# WHY CERTAIN DESIGN DECISIONS WERE MADE
#
# This program needs to be able to run under miniperl.  Therefore, it uses a
# minimum of other modules, and hence implements some things itself that could
# be gotten from CPAN
#
# This program uses inputs published by the Unicode Consortium.  These can
# change incompatibly between releases without the Perl maintainers realizing
# it.  Therefore this program is now designed to try to flag these.  It looks
# at the directories where the inputs are, and flags any unrecognized files.
# It keeps track of all the properties in the files it handles, and flags any
# that it doesn't know how to handle.  It also flags any input lines that
# don't match the expected syntax, among other checks.
#
# It is also designed so if a new input file matches one of the known
# templates, one hopefully just needs to add it to a list to have it
# processed.
#
# As mentioned earlier, some properties are given in more than one file.  In
# particular, the files in the extracted directory are supposedly just
# reformattings of the others.  But they contain information not easily
# derivable from the other files, including results for Unihan, which this
# program doesn't ordinarily look at, and for unassigned code points.  They
# also have historically had errors or been incomplete.  In an attempt to
# create the best possible data, this program thus processes them first to
# glean information missing from the other files; then processes those other
# files to override any errors in the extracted ones.  Much of the design was
# driven by this need to store things and then possibly override them.
#
# It tries to keep fatal errors to a minimum, to generate something usable for
# testing purposes.  It always looks for files that could be inputs, and will
# warn about any that it doesn't know how to handle (the -q option suppresses
# the warning).
#
# Why have files written out for binary 'N' matches?
#   For binary properties, if you know the mapping for either Y or N; the
#   other is trivial to construct, so could be done at Perl run-time by just
#   complementing the result, instead of having a file for it.  That is, if
#   someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
#   not need a file.   The problem is communicating to Perl that a given
#   property is binary.  Perl can't figure it out from looking at the N (or
#   No), as some non-binary properties have these as property values.  So
#   rather than inventing a way to communicate this info back to the core,
#   which would have required changes there as well, it was simpler just to
#   add the extra tables.
#
# Why is there more than one type of range?
#   This simplified things.  There are some very specialized code points that
#   have to be handled specially for output, such as Hangul syllable names.
#   By creating a range type (done late in the development process), it
#   allowed this to be stored with the range, and overridden by other input.
#   Originally these were stored in another data structure, and it became a
#   mess trying to decide if a second file that was for the same property was
#   overriding the earlier one or not.
#
# Why are there two kinds of tables, match and map?
#   (And there is a base class shared by the two as well.)  As stated above,
#   they actually are for different things.  Development proceeded much more
#   smoothly when I (khw) realized the distinction.  Map tables are used to
#   give the property value for every code point (actually every code point
#   that doesn't map to a default value).  Match tables are used for regular
#   expression matches, and are essentially the inverse mapping.  Separating
#   the two allows more specialized methods, and error checks so that one
#   can't just take the intersection of two map tables, for example, as that
#   is nonsensical.
#
# There are no match tables generated for matches of the null string.  These
# would look like qr/\p{JSN=}/ currently without modifying the regex code.
# Perhaps something like them could be added if necessary.  The JSN does have
# a real code point U+110B that maps to the null string, but it is a
# contributory property, and therefore not output by default.  And it's easily
# handled so far by making the null string the default where it is a
# possibility.
#
# DEBUGGING
#
# This program is written so it will run under miniperl.  Occasionally changes
# will cause an error where the backtrace doesn't work well under miniperl.
# To diagnose the problem, you can instead run it under regular perl, if you
# have one compiled.
#
# There is a good trace facility.  To enable it, first sub DEBUG must be set
# to return true.  Then a line like
#
# local $to_trace = 1 if main::DEBUG;
#
# can be added to enable tracing in its lexical scope or until you insert
# another line:
#
# local $to_trace = 0 if main::DEBUG;
#
# then use a line like "trace $a, @b, %c, ...;
#
# Some of the more complex subroutines already have trace statements in them.
# Permanent trace statements should be like:
#
# trace ... if main::DEBUG && $to_trace;
#
# If there is just one or a few files that you're debugging, you can easily
# cause most everything else to be skipped.  Change the line
#
# my $debug_skip = 0;
#
# to 1, and every file whose object is in @input_file_objects and doesn't have
# a, 'non_skip => 1,' in its constructor will be skipped.
#
# To compare the output tables, it may be useful to specify the -annotate
# flag.  This causes the tables to expand so there is one entry for each
# non-algorithmically named code point giving, currently its name, and its
# graphic representation if printable (and you have a font that knows about
# it).  This makes it easier to see what the particular code points are in
# each output table.  The tables are usable, but because they don't have
# ranges (for the most part), a Perl using them will run slower.  Non-named
# code points are annotated with a description of their status, and contiguous
# ones with the same description will be output as a range rather than
# individually.  Algorithmically named characters are also output as ranges,
# except when there are just a few contiguous ones.
#
# FUTURE ISSUES
#
# The program would break if Unicode were to change its names so that
# interior white space, underscores, or dashes differences were significant
# within property and property value names.
#
# It might be easier to use the xml versions of the UCD if this program ever
# would need heavy revision, and the ability to handle old versions was not
# required.
#
# There is the potential for name collisions, in that Perl has chosen names
# that Unicode could decide it also likes.  There have been such collisions in
# the past, with mostly Perl deciding to adopt the Unicode definition of the
# name.  However in the 5.2 Unicode beta testing, there were a number of such
# collisions, which were withdrawn before the final release, because of Perl's
# and other's protests.  These all involved new properties which began with
# 'Is'.  Based on the protests, Unicode is unlikely to try that again.  Also,
# many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
# Unicode document, so they are unlikely to be used by Unicode for another
# purpose.  However, they might try something beginning with 'In', or use any
# of the other Perl-defined properties.  This program will warn you of name
# collisions, and refuse to generate tables with them, but manual intervention
# will be required in this event.  One scheme that could be implemented, if
# necessary, would be to have this program generate another file, or add a
# field to mktables.lst that gives the date of first definition of a property.
# Each new release of Unicode would use that file as a basis for the next
# iteration.  And the Perl synonym addition code could sort based on the age
# of the property, so older properties get priority, and newer ones that clash
# would be refused; hence existing code would not be impacted, and some other
# synonym would have to be used for the new property.  This is ugly, and
# manual intervention would certainly be easier to do in the short run; lets
# hope it never comes to this.
#
# A NOTE ON UNIHAN
#
# This program can generate tables from the Unihan database.  But it doesn't
# by default, letting the CPAN module Unicode::Unihan handle them.  Prior to
# version 5.2, this database was in a single file, Unihan.txt.  In 5.2 the
# database was split into 8 different files, all beginning with the letters
# 'Unihan'.  This program will read those file(s) if present, but it needs to
# know which of the many properties in the file(s) should have tables created
# for them.  It will create tables for any properties listed in
# PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
# @cjk_properties array and the @cjk_property_values array.  Thus, if a
# property you want is not in those files of the release you are building
# against, you must add it to those two arrays.  Starting in 4.0, the
# Unicode_Radical_Stroke was listed in those files, so if the Unihan database
# is present in the directory, a table will be generated for that property.
# In 5.2, several more properties were added.  For your convenience, the two
# arrays are initialized with all the 6.0 listed properties that are also in
# earlier releases.  But these are commented out.  You can just uncomment the
# ones you want, or use them as a template for adding entries for other
# properties.
#
# You may need to adjust the entries to suit your purposes.  setup_unihan(),
# and filter_unihan_line() are the functions where this is done.  This program
# already does some adjusting to make the lines look more like the rest of the
# Unicode DB;  You can see what that is in filter_unihan_line()
#
# There is a bug in the 3.2 data file in which some values for the
# kPrimaryNumeric property have commas and an unexpected comment.  A filter
# could be added for these; or for a particular installation, the Unihan.txt
# file could be edited to fix them.
#
# HOW TO ADD A FILE TO BE PROCESSED
#
# A new file from Unicode needs to have an object constructed for it in
# @input_file_objects, probably at the end or at the end of the extracted
# ones.  The program should warn you if its name will clash with others on
# restrictive file systems, like DOS.  If so, figure out a better name, and
# add lines to the README.perl file giving that.  If the file is a character
# property, it should be in the format that Unicode has by default
# standardized for such files for the more recently introduced ones.
# If so, the Input_file constructor for @input_file_objects can just be the
# file name and release it first appeared in.  If not, then it should be
# possible to construct an each_line_handler() to massage the line into the
# standardized form.
#
# For non-character properties, more code will be needed.  You can look at
# the existing entries for clues.
#
# UNICODE VERSIONS NOTES
#
# The Unicode UCD has had a number of errors in it over the versions.  And
# these remain, by policy, in the standard for that version.  Therefore it is
# risky to correct them, because code may be expecting the error.  So this
# program doesn't generally make changes, unless the error breaks the Perl
# core.  As an example, some versions of 2.1.x Jamo.txt have the wrong value
# for U+1105, which causes real problems for the algorithms for Jamo
# calculations, so it is changed here.
#
# But it isn't so clear cut as to what to do about concepts that are
# introduced in a later release; should they extend back to earlier releases
# where the concept just didn't exist?  It was easier to do this than to not,
# so that's what was done.  For example, the default value for code points not
# in the files for various properties was probably undefined until changed by
# some version.  No_Block for blocks is such an example.  This program will
# assign No_Block even in Unicode versions that didn't have it.  This has the
# benefit that code being written doesn't have to special case earlier
# versions; and the detriment that it doesn't match the Standard precisely for
# the affected versions.
#
# Here are some observations about some of the issues in early versions:
#
# The number of code points in \p{alpha} halved in 2.1.9.  It turns out that
# the reason is that the CJK block starting at 4E00 was removed from PropList,
# and was not put back in until 3.1.0
#
# Unicode introduced the synonym Space for White_Space in 4.1.  Perl has
# always had a \p{Space}.  In release 3.2 only, they are not synonymous.  The
# reason is that 3.2 introduced U+205F=medium math space, which was not
# classed as white space, but Perl figured out that it should have been. 4.0
# reclassified it correctly.
#
# Another change between 3.2 and 4.0 is the CCC property value ATBL.  In 3.2
# this was erroneously a synonym for 202.  In 4.0, ATB became 202, and ATBL
# was left with no code points, as all the ones that mapped to 202 stayed
# mapped to 202.  Thus if your program used the numeric name for the class,
# it would not have been affected, but if it used the mnemonic, it would have
# been.
#
# \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1.  Before that code
# points which eventually came to have this script property value, instead
# mapped to "Unknown".  But in the next release all these code points were
# moved to \p{sc=common} instead.
#
# The default for missing code points for BidiClass is complicated.  Starting
# in 3.1.1, the derived file DBidiClass.txt handles this, but this program
# tries to do the best it can for earlier releases.  It is done in
# process_PropertyAliases()
#
##############################################################################

my $UNDEF = ':UNDEF:';  # String to print out for undefined values in tracing
                        # and errors
my $MAX_LINE_WIDTH = 78;

# Debugging aid to skip most files so as to not be distracted by them when
# concentrating on the ones being debugged.  Add
# non_skip => 1,
# to the constructor for those files you want processed when you set this.
# Files with a first version number of 0 are special: they are always
# processed regardless of the state of this flag.
my $debug_skip = 0;

# Set to 1 to enable tracing.
our $to_trace = 0;

{ # Closure for trace: debugging aid
    my $print_caller = 1;        # ? Include calling subroutine name
    my $main_with_colon = 'main::';
    my $main_colon_length = length($main_with_colon);

    sub trace {
        return unless $to_trace;        # Do nothing if global flag not set

        my @input = @_;

        local $DB::trace = 0;
        $DB::trace = 0;          # Quiet 'used only once' message

        my $line_number;

        # Loop looking up the stack to get the first non-trace caller
        my $caller_line;
        my $caller_name;
        my $i = 0;
        do {
            $line_number = $caller_line;
            (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
            $caller = $main_with_colon unless defined $caller;

            $caller_name = $caller;

            # get rid of pkg
            $caller_name =~ s/.*:://;
            if (substr($caller_name, 0, $main_colon_length)
                eq $main_with_colon)
            {
                $caller_name = substr($caller_name, $main_colon_length);
            }

        } until ($caller_name ne 'trace');

        # If the stack was empty, we were called from the top level
        $caller_name = 'main' if ($caller_name eq ""
                                    || $caller_name eq 'trace');

        my $output = "";
        foreach my $string (@input) {
            #print STDERR __LINE__, ": ", join ", ", @input, "\n";
            if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
                $output .= simple_dumper($string);
            }
            else {
                $string = "$string" if ref $string;
                $string = $UNDEF unless defined $string;
                chomp $string;
                $string = '""' if $string eq "";
                $output .= " " if $output ne ""
                                && $string ne ""
                                && substr($output, -1, 1) ne " "
                                && substr($string, 0, 1) ne " ";
                $output .= $string;
            }
        }

        print STDERR sprintf "%4d: ", $line_number if defined $line_number;
        print STDERR "$caller_name: " if $print_caller;
        print STDERR $output, "\n";
        return;
    }
}

# This is for a rarely used development feature that allows you to compare two
# versions of the Unicode standard without having to deal with changes caused
# by the code points introduced in the later verson.  Change the 0 to a SINGLE
# dotted Unicode release number (e.g. 2.1).  Only code points introduced in
# that release and earlier will be used; later ones are thrown away.  You use
# the version number of the earliest one you want to compare; then run this
# program on directory structures containing each release, and compare the
# outputs.  These outputs will therefore include only the code points common
# to both releases, and you can see the changes caused just by the underlying
# release semantic changes.  For versions earlier than 3.2, you must copy a
# version of DAge.txt into the directory.
my $string_compare_versions = DEBUG && 0; #  e.g., v2.1;
my $compare_versions = DEBUG
                       && $string_compare_versions
                       && pack "C*", split /\./, $string_compare_versions;

sub uniques {
    # Returns non-duplicated input values.  From "Perl Best Practices:
    # Encapsulated Cleverness".  p. 455 in first edition.

    my %seen;
    # Arguably this breaks encapsulation, if the goal is to permit multiple
    # distinct objects to stringify to the same value, and be interchangeable.
    # However, for this program, no two objects stringify identically, and all
    # lists passed to this function are either objects or strings. So this
    # doesn't affect correctness, but it does give a couple of percent speedup.
    no overloading;
    return grep { ! $seen{$_}++ } @_;
}

$0 = File::Spec->canonpath($0);

my $make_test_script = 0;      # ? Should we output a test script
my $write_unchanged_files = 0; # ? Should we update the output files even if
                               #    we don't think they have changed
my $use_directory = "";        # ? Should we chdir somewhere.
my $pod_directory;             # input directory to store the pod file.
my $pod_file = 'perluniprops';
my $t_path;                     # Path to the .t test file
my $file_list = 'mktables.lst'; # File to store input and output file names.
                               # This is used to speed up the build, by not
                               # executing the main body of the program if
                               # nothing on the list has changed since the
                               # previous build
my $make_list = 1;             # ? Should we write $file_list.  Set to always
                               # make a list so that when the pumpking is
                               # preparing a release, s/he won't have to do
                               # special things
my $glob_list = 0;             # ? Should we try to include unknown .txt files
                               # in the input.
my $output_range_counts = $debugging_build;   # ? Should we include the number
                                              # of code points in ranges in
                                              # the output
my $annotate = 0;              # ? Should character names be in the output

# Verbosity levels; 0 is quiet
my $NORMAL_VERBOSITY = 1;
my $PROGRESS = 2;
my $VERBOSE = 3;

my $verbosity = $NORMAL_VERBOSITY;

# Process arguments
while (@ARGV) {
    my $arg = shift @ARGV;
    if ($arg eq '-v') {
        $verbosity = $VERBOSE;
    }
    elsif ($arg eq '-p') {
        $verbosity = $PROGRESS;
        $| = 1;     # Flush buffers as we go.
    }
    elsif ($arg eq '-q') {
        $verbosity = 0;
    }
    elsif ($arg eq '-w') {
        $write_unchanged_files = 1; # update the files even if havent changed
    }
    elsif ($arg eq '-check') {
        my $this = shift @ARGV;
        my $ok = shift @ARGV;
        if ($this ne $ok) {
            print "Skipping as check params are not the same.\n";
            exit(0);
        }
    }
    elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
        -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
    }
    elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
    {
        $make_test_script = 1;
    }
    elsif ($arg eq '-makelist') {
        $make_list = 1;
    }
    elsif ($arg eq '-C' && defined ($use_directory = shift)) {
        -d $use_directory or croak "Unknown directory '$use_directory'";
    }
    elsif ($arg eq '-L') {

        # Existence not tested until have chdir'd
        $file_list = shift;
    }
    elsif ($arg eq '-globlist') {
        $glob_list = 1;
    }
    elsif ($arg eq '-c') {
        $output_range_counts = ! $output_range_counts
    }
    elsif ($arg eq '-annotate') {
        $annotate = 1;
        $debugging_build = 1;
        $output_range_counts = 1;
    }
    else {
        my $with_c = 'with';
        $with_c .= 'out' if $output_range_counts;   # Complements the state
        croak <<END;
usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
          [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
          [-check A B ]
  -c          : Output comments $with_c number of code points in ranges
  -q          : Quiet Mode: Only output serious warnings.
  -p          : Set verbosity level to normal plus show progress.
  -v          : Set Verbosity level high:  Show progress and non-serious
                warnings
  -w          : Write files regardless
  -C dir      : Change to this directory before proceeding. All relative paths
                except those specified by the -P and -T options will be done
                with respect to this directory.
  -P dir      : Output $pod_file file to directory 'dir'.
  -T path     : Create a test script as 'path'; overrides -maketest
  -L filelist : Use alternate 'filelist' instead of standard one
  -globlist   : Take as input all non-Test *.txt files in current and sub
                directories
  -maketest   : Make test script 'TestProp.pl' in current (or -C directory),
                overrides -T
  -makelist   : Rewrite the file list $file_list based on current setup
  -annotate   : Output an annotation for each character in the table files;
                useful for debugging mktables, looking at diffs; but is slow,
                memory intensive; resulting tables are usable but slow and
                very large.
  -check A B  : Executes $0 only if A and B are the same
END
    }
}

# Stores the most-recently changed file.  If none have changed, can skip the
# build
my $most_recent = (stat $0)[9];   # Do this before the chdir!

# Change directories now, because need to read 'version' early.
if ($use_directory) {
    if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
        $pod_directory = File::Spec->rel2abs($pod_directory);
    }
    if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
        $t_path = File::Spec->rel2abs($t_path);
    }
    chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
    if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
        $pod_directory = File::Spec->abs2rel($pod_directory);
    }
    if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
        $t_path = File::Spec->abs2rel($t_path);
    }
}

# Get Unicode version into regular and v-string.  This is done now because
# various tables below get populated based on it.  These tables are populated
# here to be near the top of the file, and so easily seeable by those needing
# to modify things.
open my $VERSION, "<", "version"
                    or croak "$0: can't open required file 'version': $!\n";
my $string_version = <$VERSION>;
close $VERSION;
chomp $string_version;
my $v_version = pack "C*", split /\./, $string_version;        # v string

# The following are the complete names of properties with property values that
# are known to not match any code points in some versions of Unicode, but that
# may change in the future so they should be matchable, hence an empty file is
# generated for them.
my @tables_that_may_be_empty = (
                                'Joining_Type=Left_Joining',
                                );
push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
                                                    if $v_version ge v4.1.0;

# The lists below are hashes, so the key is the item in the list, and the
# value is the reason why it is in the list.  This makes generation of
# documentation easier.

my %why_suppressed;  # No file generated for these.

# Files aren't generated for empty extraneous properties.  This is arguable.
# Extraneous properties generally come about because a property is no longer
# used in a newer version of Unicode.  If we generated a file without code
# points, programs that used to work on that property will still execute
# without errors.  It just won't ever match (or will always match, with \P{}).
# This means that the logic is now likely wrong.  I (khw) think its better to
# find this out by getting an error message.  Just move them to the table
# above to change this behavior
my %why_suppress_if_empty_warn_if_not = (

   # It is the only property that has ever officially been removed from the
   # Standard.  The database never contained any code points for it.
   'Special_Case_Condition' => 'Obsolete',

   # Apparently never official, but there were code points in some versions of
   # old-style PropList.txt
   'Non_Break' => 'Obsolete',
);

# These would normally go in the warn table just above, but they were changed
# a long time before this program was written, so warnings about them are
# moot.
if ($v_version gt v3.2.0) {
    push @tables_that_may_be_empty,
                                'Canonical_Combining_Class=Attached_Below_Left'
}

# These are listed in the Property aliases file in 6.0, but Unihan is ignored
# unless explicitly added.
if ($v_version ge v5.2.0) {
    my $unihan = 'Unihan; remove from list if using Unihan';
    foreach my $table (qw (
                           kAccountingNumeric
                           kOtherNumeric
                           kPrimaryNumeric
                           kCompatibilityVariant
                           kIICore
                           kIRG_GSource
                           kIRG_HSource
                           kIRG_JSource
                           kIRG_KPSource
                           kIRG_MSource
                           kIRG_KSource
                           kIRG_TSource
                           kIRG_USource
                           kIRG_VSource
                           kRSUnicode
                        ))
    {
        $why_suppress_if_empty_warn_if_not{$table} = $unihan;
    }
}

# Properties that this program ignores.
my @unimplemented_properties = (
'Unicode_Radical_Stroke'    # Remove if changing to handle this one.
);

# There are several types of obsolete properties defined by Unicode.  These
# must be hand-edited for every new Unicode release.
my %why_deprecated;  # Generates a deprecated warning message if used.
my %why_stabilized;  # Documentation only
my %why_obsolete;    # Documentation only

{   # Closure
    my $simple = 'Perl uses the more complete version of this property';
    my $unihan = 'Unihan properties are by default not enabled in the Perl core.  Instead use CPAN: Unicode::Unihan';

    my $other_properties = 'other properties';
    my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
    my $why_no_expand  = "Deprecated by Unicode: less useful than UTF-specific calculations",

    %why_deprecated = (
        'Grapheme_Link' => 'Deprecated by Unicode:  Duplicates ccc=vr (Canonical_Combining_Class=Virama)',
        'Jamo_Short_Name' => $contributory,
        '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',
        'Other_Alphabetic' => $contributory,
        'Other_Default_Ignorable_Code_Point' => $contributory,
        'Other_Grapheme_Extend' => $contributory,
        'Other_ID_Continue' => $contributory,
        'Other_ID_Start' => $contributory,
        'Other_Lowercase' => $contributory,
        'Other_Math' => $contributory,
        'Other_Uppercase' => $contributory,
    );

    %why_suppressed = (
        # There is a lib/unicore/Decomposition.pl (used by Normalize.pm) which
        # contains the same information, but without the algorithmically
        # determinable Hangul syllables'.  This file is not published, so it's
        # existence is not noted in the comment.
        'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',

        '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',
        '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",

        'Simple_Case_Folding' => "$simple.  Can access this through Unicode::UCD::casefold",
        'Simple_Lowercase_Mapping' => "$simple.  Can access this through Unicode::UCD::charinfo",
        'Simple_Titlecase_Mapping' => "$simple.  Can access this through Unicode::UCD::charinfo",
        'Simple_Uppercase_Mapping' => "$simple.  Can access this through Unicode::UCD::charinfo",

        'Name' => "Accessible via 'use charnames;'",
        'Name_Alias' => "Accessible via 'use charnames;'",

        FC_NFKC_Closure => 'Supplanted in usage by NFKC_Casefold; otherwise not useful',
        Expands_On_NFC => $why_no_expand,
        Expands_On_NFD => $why_no_expand,
        Expands_On_NFKC => $why_no_expand,
        Expands_On_NFKD => $why_no_expand,
    );

    # The following are suppressed because they were made contributory or
    # deprecated by Unicode before Perl ever thought about supporting them.
    foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
        $why_suppressed{$property} = $why_deprecated{$property};
    }

    # Customize the message for all the 'Other_' properties
    foreach my $property (keys %why_deprecated) {
        next if (my $main_property = $property) !~ s/^Other_//;
        $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
    }
}

if ($v_version ge 4.0.0) {
    $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
    if ($v_version ge 6.0.0) {
        $why_deprecated{'Hyphen'} = 'Supplanted by Line_Break property values; see www.unicode.org/reports/tr14';
    }
}
if ($v_version ge 5.2.0 && $v_version lt 6.0.0) {
    $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
    if ($v_version ge 6.0.0) {
        $why_deprecated{'ISO_Comment'} = 'No longer needed for chart generation; otherwise not useful, and code points for it have been removed';
    }
}

# Probably obsolete forever
if ($v_version ge v4.1.0) {
    $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete.  All code points previously matched by this have been moved to "Script=Common"';
}

# This program can create files for enumerated-like properties, such as
# 'Numeric_Type'.  This file would be the same format as for a string
# property, with a mapping from code point to its value, so you could look up,
# for example, the script a code point is in.  But no one so far wants this
# mapping, or they have found another way to get it since this is a new
# feature.  So no file is generated except if it is in this list.
my @output_mapped_properties = split "\n", <<END;
END

# If you are using the Unihan database, you need to add the properties that
# you want to extract from it to this table.  For your convenience, the
# properties in the 6.0 PropertyAliases.txt file are listed, commented out
my @cjk_properties = split "\n", <<'END';
#cjkAccountingNumeric; kAccountingNumeric
#cjkOtherNumeric; kOtherNumeric
#cjkPrimaryNumeric; kPrimaryNumeric
#cjkCompatibilityVariant; kCompatibilityVariant
#cjkIICore ; kIICore
#cjkIRG_GSource; kIRG_GSource
#cjkIRG_HSource; kIRG_HSource
#cjkIRG_JSource; kIRG_JSource
#cjkIRG_KPSource; kIRG_KPSource
#cjkIRG_KSource; kIRG_KSource
#cjkIRG_TSource; kIRG_TSource
#cjkIRG_USource; kIRG_USource
#cjkIRG_VSource; kIRG_VSource
#cjkRSUnicode; kRSUnicode                ; Unicode_Radical_Stroke; URS
END

# Similarly for the property values.  For your convenience, the lines in the
# 6.0 PropertyAliases.txt file are listed.  Just remove the first BUT NOT both
# '#' marks
my @cjk_property_values = split "\n", <<'END';
## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
## @missing: 0000..10FFFF; cjkIICore; <none>
## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
## @missing: 0000..10FFFF; cjkIRG_USource; <none>
## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
## @missing: 0000..10FFFF; cjkRSUnicode; <none>
END

# The input files don't list every code point.  Those not listed are to be
# defaulted to some value.  Below are hard-coded what those values are for
# non-binary properties as of 5.1.  Starting in 5.0, there are
# machine-parsable comment lines in the files the give the defaults; so this
# list shouldn't have to be extended.  The claim is that all missing entries
# for binary properties will default to 'N'.  Unicode tried to change that in
# 5.2, but the beta period produced enough protest that they backed off.
#
# The defaults for the fields that appear in UnicodeData.txt in this hash must
# be in the form that it expects.  The others may be synonyms.
my $CODE_POINT = '<code point>';
my %default_mapping = (
    Age => "Unassigned",
    # Bidi_Class => Complicated; set in code
    Bidi_Mirroring_Glyph => "",
    Block => 'No_Block',
    Canonical_Combining_Class => 0,
    Case_Folding => $CODE_POINT,
    Decomposition_Mapping => $CODE_POINT,
    Decomposition_Type => 'None',
    East_Asian_Width => "Neutral",
    FC_NFKC_Closure => $CODE_POINT,
    General_Category => 'Cn',
    Grapheme_Cluster_Break => 'Other',
    Hangul_Syllable_Type => 'NA',
    ISO_Comment => "",
    Jamo_Short_Name => "",
    Joining_Group => "No_Joining_Group",
    # Joining_Type => Complicated; set in code
    kIICore => 'N',   #                       Is converted to binary
    #Line_Break => Complicated; set in code
    Lowercase_Mapping => $CODE_POINT,
    Name => "",
    Name_Alias => "",
    NFC_QC => 'Yes',
    NFD_QC => 'Yes',
    NFKC_QC => 'Yes',
    NFKD_QC => 'Yes',
    Numeric_Type => 'None',
    Numeric_Value => 'NaN',
    Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
    Sentence_Break => 'Other',
    Simple_Case_Folding => $CODE_POINT,
    Simple_Lowercase_Mapping => $CODE_POINT,
    Simple_Titlecase_Mapping => $CODE_POINT,
    Simple_Uppercase_Mapping => $CODE_POINT,
    Titlecase_Mapping => $CODE_POINT,
    Unicode_1_Name => "",
    Unicode_Radical_Stroke => "",
    Uppercase_Mapping => $CODE_POINT,
    Word_Break => 'Other',
);

# Below are files that Unicode furnishes, but this program ignores, and why
my %ignored_files = (
    'CJKRadicals.txt' => 'Unihan data',
    'Index.txt' => 'An index, not actual data',
    'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
    'NamesList.txt' => 'Just adds commentary',
    'NormalizationCorrections.txt' => 'Data is already in other files.',
    'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
    'ReadMe.txt' => 'Just comments',
    'README.TXT' => 'Just comments',
    'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property.  Does not fit into current scheme where one code point is mapped',
    'EmojiSources.txt' => 'Not of general utility: for Japanese legacy cell-phone applications',
    'IndicMatraCategory.txt' => 'Provisional',
    'IndicSyllabicCategory.txt' => 'Provisional',
    'ScriptExtensions.txt' => 'Provisional',
);

### End of externally interesting definitions, except for @input_file_objects

my $HEADER=<<"EOF";
# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
# This file is machine-generated by $0 from the Unicode
# database, Version $string_version.  Any changes made here will be lost!
EOF

my $INTERNAL_ONLY=<<"EOF";

# !!!!!!!   INTERNAL PERL USE ONLY   !!!!!!!
# This file is for internal use by the Perl program only.  The format and even
# the name or existence of this file are subject to change without notice.
# Don't use it directly.
EOF

my $DEVELOPMENT_ONLY=<<"EOF";
# !!!!!!!   DEVELOPMENT USE ONLY   !!!!!!!
# This file contains information artificially constrained to code points
# present in Unicode release $string_compare_versions.
# IT CANNOT BE RELIED ON.  It is for use during development only and should
# not be used for production.

EOF

my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;

# Matches legal code point.  4-6 hex numbers, If there are 6, the first
# two must be 10; if there are 5, the first must not be a 0.  Written this way
# to decrease backtracking
my $code_point_re =
        qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;

# This matches the beginning of the line in the Unicode db files that give the
# defaults for code points not listed (i.e., missing) in the file.  The code
# depends on this ending with a semi-colon, so it can assume it is a valid
# field when the line is split() by semi-colons
my $missing_defaults_prefix =
            qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;

# Property types.  Unicode has more types, but these are sufficient for our
# purposes.
my $UNKNOWN = -1;   # initialized to illegal value
my $NON_STRING = 1; # Either binary or enum
my $BINARY = 2;
my $ENUM = 3;       # Include catalog
my $STRING = 4;     # Anything else: string or misc

# Some input files have lines that give default values for code points not
# contained in the file.  Sometimes these should be ignored.
my $NO_DEFAULTS = 0;        # Must evaluate to false
my $NOT_IGNORED = 1;
my $IGNORED = 2;

# Range types.  Each range has a type.  Most ranges are type 0, for normal,
# and will appear in the main body of the tables in the output files, but
# there are other types of ranges as well, listed below, that are specially
# handled.   There are pseudo-types as well that will never be stored as a
# type, but will affect the calculation of the type.

# 0 is for normal, non-specials
my $MULTI_CP = 1;           # Sequence of more than code point
my $HANGUL_SYLLABLE = 2;
my $CP_IN_NAME = 3;         # The NAME contains the code point appended to it.
my $NULL = 4;               # The map is to the null string; utf8.c can't
                            # handle these, nor is there an accepted syntax
                            # for them in \p{} constructs
my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
                             # otherwise be $MULTI_CP type are instead type 0

# process_generic_property_file() can accept certain overrides in its input.
# Each of these must begin AND end with $CMD_DELIM.
my $CMD_DELIM = "\a";
my $REPLACE_CMD = 'replace';    # Override the Replace
my $MAP_TYPE_CMD = 'map_type';  # Override the Type

my $NO = 0;
my $YES = 1;

# Values for the Replace argument to add_range.
# $NO                      # Don't replace; add only the code points not
                           # already present.
my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
                           # the comments at the subroutine definition.
my $UNCONDITIONALLY = 2;   # Replace without conditions.
my $MULTIPLE = 4;          # Don't replace, but add a duplicate record if
                           # already there
my $CROAK = 5;             # Die with an error if is already there

# Flags to give property statuses.  The phrases are to remind maintainers that
# if the flag is changed, the indefinite article referring to it in the
# documentation may need to be as well.
my $NORMAL = "";
my $SUPPRESSED = 'z';   # The character should never actually be seen, since
                        # it is suppressed
my $PLACEHOLDER = 'P';  # Implies no pod entry generated
my $DEPRECATED = 'D';
my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
my $DISCOURAGED = 'X';
my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
my $STRICTER = 'T';
my $a_bold_stricter = "a 'B<$STRICTER>'";
my $A_bold_stricter = "A 'B<$STRICTER>'";
my $STABILIZED = 'S';
my $a_bold_stabilized = "an 'B<$STABILIZED>'";
my $A_bold_stabilized = "An 'B<$STABILIZED>'";
my $OBSOLETE = 'O';
my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
my $A_bold_obsolete = "An 'B<$OBSOLETE>'";

my %status_past_participles = (
    $DISCOURAGED => 'discouraged',
    $SUPPRESSED => 'should never be generated',
    $STABILIZED => 'stabilized',
    $OBSOLETE => 'obsolete',
    $DEPRECATED => 'deprecated',
);

# The format of the values of the tables:
my $EMPTY_FORMAT = "";
my $BINARY_FORMAT = 'b';
my $DECIMAL_FORMAT = 'd';
my $FLOAT_FORMAT = 'f';
my $INTEGER_FORMAT = 'i';
my $HEX_FORMAT = 'x';
my $RATIONAL_FORMAT = 'r';
my $STRING_FORMAT = 's';
my $DECOMP_STRING_FORMAT = 'c';

my %map_table_formats = (
    $BINARY_FORMAT => 'binary',
    $DECIMAL_FORMAT => 'single decimal digit',
    $FLOAT_FORMAT => 'floating point number',
    $INTEGER_FORMAT => 'integer',
    $HEX_FORMAT => 'positive hex whole number; a code point',
    $RATIONAL_FORMAT => 'rational: an integer or a fraction',
    $STRING_FORMAT => 'string',
    $DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
);

# Unicode didn't put such derived files in a separate directory at first.
my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
my $AUXILIARY = 'auxiliary';

# Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
my %loose_to_file_of;       # loosely maps table names to their respective
                            # files
my %stricter_to_file_of;    # same; but for stricter mapping.
my %nv_floating_to_rational; # maps numeric values floating point numbers to
                             # their rational equivalent
my %loose_property_name_of; # Loosely maps property names to standard form

# Most properties are immune to caseless matching, otherwise you would get
# nonsensical results, as properties are a function of a code point, not
# everything that is caselessly equivalent to that code point.  For example,
# Changes_When_Case_Folded('s') should be false, whereas caselessly it would
# be true because 's' and 'S' are equivalent caselessly.  However,
# traditionally, [:upper:] and [:lower:] are equivalent caselessly, so we
# extend that concept to those very few properties that are like this.  Each
# such property will match the full range caselessly.  They are hard-coded in
# the program; it's not worth trying to make it general as it's extremely
# unlikely that they will ever change.
my %caseless_equivalent_to;

# These constants names and values were taken from the Unicode standard,
# version 5.1, section 3.12.  They are used in conjunction with Hangul
# syllables.  The '_string' versions are so generated tables can retain the
# hex format, which is the more familiar value
my $SBase_string = "0xAC00";
my $SBase = CORE::hex $SBase_string;
my $LBase_string = "0x1100";
my $LBase = CORE::hex $LBase_string;
my $VBase_string = "0x1161";
my $VBase = CORE::hex $VBase_string;
my $TBase_string = "0x11A7";
my $TBase = CORE::hex $TBase_string;
my $SCount = 11172;
my $LCount = 19;
my $VCount = 21;
my $TCount = 28;
my $NCount = $VCount * $TCount;

# For Hangul syllables;  These store the numbers from Jamo.txt in conjunction
# with the above published constants.
my %Jamo;
my %Jamo_L;     # Leading consonants
my %Jamo_V;     # Vowels
my %Jamo_T;     # Trailing consonants

my @backslash_X_tests;     # List of tests read in for testing \X
my @unhandled_properties;  # Will contain a list of properties found in
                           # the input that we didn't process.
my @match_properties;      # Properties that have match tables, to be
                           # listed in the pod
my @map_properties;        # Properties that get map files written
my @named_sequences;       # NamedSequences.txt contents.
my %potential_files;       # Generated list of all .txt files in the directory
                           # structure so we can warn if something is being
                           # ignored.
my @files_actually_output; # List of files we generated.
my @more_Names;            # Some code point names are compound; this is used
                           # to store the extra components of them.
my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
                           # the minimum before we consider it equivalent to a
                           # candidate rational
my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms

# These store references to certain commonly used property objects
my $gc;
my $perl;
my $block;
my $perl_charname;
my $print;

# Are there conflicting names because of beginning with 'In_', or 'Is_'
my $has_In_conflicts = 0;
my $has_Is_conflicts = 0;

sub internal_file_to_platform ($) {
    # Convert our file paths which have '/' separators to those of the
    # platform.

    my $file = shift;
    return undef unless defined $file;

    return File::Spec->join(split '/', $file);
}

sub file_exists ($) {   # platform independent '-e'.  This program internally
                        # uses slash as a path separator.
    my $file = shift;
    return 0 if ! defined $file;
    return -e internal_file_to_platform($file);
}

sub objaddr($) {
    # Returns the address of the blessed input object.
    # It doesn't check for blessedness because that would do a string eval
    # every call, and the program is structured so that this is never called
    # for a non-blessed object.

    no overloading; # If overloaded, numifying below won't work.

    # Numifying a ref gives its address.
    return pack 'J', $_[0];
}

# These are used only if $annotate is true.
# The entire range of Unicode characters is examined to populate these
# after all the input has been processed.  But most can be skipped, as they
# have the same descriptive phrases, such as being unassigned
my @viacode;            # Contains the 1 million character names
my @printable;          # boolean: And are those characters printable?
my @annotate_char_type; # Contains a type of those characters, specifically
                        # for the purposes of annotation.
my $annotate_ranges;    # A map of ranges of code points that have the same
                        # name for the purposes of annotation.  They map to the
                        # upper edge of the range, so that the end point can
                        # be immediately found.  This is used to skip ahead to
                        # the end of a range, and avoid processing each
                        # individual code point in it.
my $unassigned_sans_noncharacters; # A Range_List of the unassigned
                                   # characters, but excluding those which are
                                   # also noncharacter code points

# The annotation types are an extension of the regular range types, though
# some of the latter are folded into one.  Make the new types negative to
# avoid conflicting with the regular types
my $SURROGATE_TYPE = -1;
my $UNASSIGNED_TYPE = -2;
my $PRIVATE_USE_TYPE = -3;
my $NONCHARACTER_TYPE = -4;
my $CONTROL_TYPE = -5;
my $UNKNOWN_TYPE = -6;  # Used only if there is a bug in this program

sub populate_char_info ($) {
    # Used only with the $annotate option.  Populates the arrays with the
    # input code point's info that are needed for outputting more detailed
    # comments.  If calling context wants a return, it is the end point of
    # any contiguous range of characters that share essentially the same info

    my $i = shift;
    Carp::carp_extra_args(\@_) if main::DEBUG && @_;

    $viacode[$i] = $perl_charname->value_of($i) || "";

    # A character is generally printable if Unicode says it is,
    # but below we make sure that most Unicode general category 'C' types
    # aren't.
    $printable[$i] = $print->contains($i);

    $annotate_char_type[$i] = $perl_charname->type_of($i) || 0;

    # Only these two regular types are treated specially for annotations
    # purposes
    $annotate_char_type[$i] = 0 if $annotate_char_type[$i] != $CP_IN_NAME
                                && $annotate_char_type[$i] != $HANGUL_SYLLABLE;

    # Give a generic name to all code points that don't have a real name.
    # We output ranges, if applicable, for these.  Also calculate the end
    # point of the range.
    my $end;
    if (! $viacode[$i]) {
        if ($gc-> table('Surrogate')->contains($i)) {
            $viacode[$i] = 'Surrogate';
            $annotate_char_type[$i] = $SURROGATE_TYPE;
            $printable[$i] = 0;
            $end = $gc->table('Surrogate')->containing_range($i)->end;
        }
        elsif ($gc-> table('Private_use')->contains($i)) {
            $viacode[$i] = 'Private Use';
            $annotate_char_type[$i] = $PRIVATE_USE_TYPE;
            $printable[$i] = 0;
            $end = $gc->table('Private_Use')->containing_range($i)->end;
        }
        elsif (Property::property_ref('Noncharacter_Code_Point')-> table('Y')->
                                                                contains($i))
        {
            $viacode[$i] = 'Noncharacter';
            $annotate_char_type[$i] = $NONCHARACTER_TYPE;
            $printable[$i] = 0;
            $end = property_ref('Noncharacter_Code_Point')->table('Y')->
                                                    containing_range($i)->end;
        }
        elsif ($gc-> table('Control')->contains($i)) {
            $viacode[$i] = 'Control';
            $annotate_char_type[$i] = $CONTROL_TYPE;
            $printable[$i] = 0;
            $end = 0x81 if $i == 0x80;  # Hard-code this one known case
        }
        elsif ($gc-> table('Unassigned')->contains($i)) {
            $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
            $annotate_char_type[$i] = $UNASSIGNED_TYPE;
            $printable[$i] = 0;

            # Because we name the unassigned by the blocks they are in, it
            # can't go past the end of that block, and it also can't go past
            # the unassigned range it is in.  The special table makes sure
            # that the non-characters, which are unassigned, are separated
            # out.
            $end = min($block->containing_range($i)->end,
                       $unassigned_sans_noncharacters-> containing_range($i)->
                                                                         end);
        }
        else {
            Carp::my_carp_bug("Can't figure out how to annotate "
                              . sprintf("U+%04X", $i)
                              . ".  Proceeding anyway.");
            $viacode[$i] = 'UNKNOWN';
            $annotate_char_type[$i] = $UNKNOWN_TYPE;
            $printable[$i] = 0;
        }
    }

    # Here, has a name, but if it's one in which the code point number is
    # appended to the name, do that.
    elsif ($annotate_char_type[$i] == $CP_IN_NAME) {
        $viacode[$i] .= sprintf("-%04X", $i);
        $end = $perl_charname->containing_range($i)->end;
    }

    # And here, has a name, but if it's a hangul syllable one, replace it with
    # the correct name from the Unicode algorithm
    elsif ($annotate_char_type[$i] == $HANGUL_SYLLABLE) {
        use integer;
        my $SIndex = $i - $SBase;
        my $L = $LBase + $SIndex / $NCount;
        my $V = $VBase + ($SIndex % $NCount) / $TCount;
        my $T = $TBase + $SIndex % $TCount;
        $viacode[$i] = "HANGUL SYLLABLE $Jamo{$L}$Jamo{$V}";
        $viacode[$i] .= $Jamo{$T} if $T != $TBase;
        $end = $perl_charname->containing_range($i)->end;
    }

    return if ! defined wantarray;
    return $i if ! defined $end;    # If not a range, return the input

    # Save this whole range so can find the end point quickly
    $annotate_ranges->add_map($i, $end, $end);

    return $end;
}

# Commented code below should work on Perl 5.8.
## This 'require' doesn't necessarily work in miniperl, and even if it does,
## the native perl version of it (which is what would operate under miniperl)
## is extremely slow, as it does a string eval every call.
#my $has_fast_scalar_util = $\18 !~ /miniperl/
#                            && defined eval "require Scalar::Util";
#
#sub objaddr($) {
#    # Returns the address of the blessed input object.  Uses the XS version if
#    # available.  It doesn't check for blessedness because that would do a
#    # string eval every call, and the program is structured so that this is
#    # never called for a non-blessed object.
#
#    return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
#
#    # Check at least that is a ref.
#    my $pkg = ref($_[0]) or return undef;
#
#    # Change to a fake package to defeat any overloaded stringify
#    bless $_[0], 'main::Fake';
#
#    # Numifying a ref gives its address.
#    my $addr = pack 'J', $_[0];
#
#    # Return to original class
#    bless $_[0], $pkg;
#    return $addr;
#}

sub max ($$) {
    my $a = shift;
    my $b = shift;
    return $a if $a >= $b;
    return $b;
}

sub min ($$) {
    my $a = shift;
    my $b = shift;
    return $a if $a <= $b;
    return $b;
}

sub clarify_number ($) {
    # This returns the input number with underscores inserted every 3 digits
    # in large (5 digits or more) numbers.  Input must be entirely digits, not
    # checked.

    my $number = shift;
    my $pos = length($number) - 3;
    return $number if $pos <= 1;
    while ($pos > 0) {
        substr($number, $pos, 0) = '_';
        $pos -= 3;
    }
    return $number;
}


package Carp;

# These routines give a uniform treatment of messages in this program.  They
# are placed in the Carp package to cause the stack trace to not include them,
# although an alternative would be to use another package and set @CARP_NOT
# for it.

our $Verbose = 1 if main::DEBUG;  # Useful info when debugging

# This is a work-around suggested by Nicholas Clark to fix a problem with Carp
# and overload trying to load Scalar:Util under miniperl.  See
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
undef $overload::VERSION;

sub my_carp {
    my $message = shift || "";
    my $nofold = shift || 0;

    if ($message) {
        $message = main::join_lines($message);
        $message =~ s/^$0: *//;     # Remove initial program name
        $message =~ s/[.;,]+$//;    # Remove certain ending punctuation
        $message = "\n$0: $message;";

        # Fold the message with program name, semi-colon end punctuation
        # (which looks good with the message that carp appends to it), and a
        # hanging indent for continuation lines.
        $message = main::simple_fold($message, "", 4) unless $nofold;
        $message =~ s/\n$//;        # Remove the trailing nl so what carp
                                    # appends is to the same line
    }

    return $message if defined wantarray;   # If a caller just wants the msg

    carp $message;
    return;
}

sub my_carp_bug {
    # This is called when it is clear that the problem is caused by a bug in
    # this program.

    my $message = shift;
    $message =~ s/^$0: *//;
    $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");
    carp $message;
    return;
}

sub carp_too_few_args {
    if (@_ != 2) {
        my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'.  No action taken.");
        return;
    }

    my $args_ref = shift;
    my $count = shift;

    my_carp_bug("Need at least $count arguments to "
        . (caller 1)[3]
        . ".  Instead got: '"
        . join ', ', @$args_ref
        . "'.  No action taken.");
    return;
}

sub carp_extra_args {
    my $args_ref = shift;
    my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . ");  Extras ignored.") if @_;

    unless (ref $args_ref) {
        my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref.  Not checking arguments.");
        return;
    }
    my ($package, $file, $line) = caller;
    my $subroutine = (caller 1)[3];

    my $list;
    if (ref $args_ref eq 'HASH') {
        foreach my $key (keys %$args_ref) {
            $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
        }
        $list = join ', ', each %{$args_ref};
    }
    elsif (ref $args_ref eq 'ARRAY') {
        foreach my $arg (@$args_ref) {
            $arg = $UNDEF unless defined $arg;
        }
        $list = join ', ', @$args_ref;
    }
    else {
        my_carp_bug("Can't cope with ref "
                . ref($args_ref)
                . " . argument to 'carp_extra_args'.  Not checking arguments.");
        return;
    }

    my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine.  Skipped.");
    return;
}

package main;

{ # Closure

    # This program uses the inside-out method for objects, as recommended in
    # "Perl Best Practices".  This closure aids in generating those.  There
    # are two routines.  setup_package() is called once per package to set
    # things up, and then set_access() is called for each hash representing a
    # field in the object.  These routines arrange for the object to be
    # properly destroyed when no longer used, and for standard accessor
    # functions to be generated.  If you need more complex accessors, just
    # write your own and leave those accesses out of the call to set_access().
    # More details below.

    my %constructor_fields; # fields that are to be used in constructors; see
                            # below

    # The values of this hash will be the package names as keys to other
    # hashes containing the name of each field in the package as keys, and
    # references to their respective hashes as values.
    my %package_fields;

    sub setup_package {
        # Sets up the package, creating standard DESTROY and dump methods
        # (unless already defined).  The dump method is used in debugging by
        # simple_dumper().
        # The optional parameters are:
        #   a)  a reference to a hash, that gets populated by later
        #       set_access() calls with one of the accesses being
        #       'constructor'.  The caller can then refer to this, but it is
        #       not otherwise used by these two routines.
        #   b)  a reference to a callback routine to call during destruction
        #       of the object, before any fields are actually destroyed

        my %args = @_;
        my $constructor_ref = delete $args{'Constructor_Fields'};
        my $destroy_callback = delete $args{'Destroy_Callback'};
        Carp::carp_extra_args(\@_) if main::DEBUG && %args;

        my %fields;
        my $package = (caller)[0];

        $package_fields{$package} = \%fields;
        $constructor_fields{$package} = $constructor_ref;

        unless ($package->can('DESTROY')) {
            my $destroy_name = "${package}::DESTROY";
            no strict "refs";

            # Use typeglob to give the anonymous subroutine the name we want
            *$destroy_name = sub {
                my $self = shift;
                my $addr = do { no overloading; pack 'J', $self; };

                $self->$destroy_callback if $destroy_callback;
                foreach my $field (keys %{$package_fields{$package}}) {
                    #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
                    delete $package_fields{$package}{$field}{$addr};
                }
                return;
            }
        }

        unless ($package->can('dump')) {
            my $dump_name = "${package}::dump";
            no strict "refs";
            *$dump_name = sub {
                my $self = shift;
                return dump_inside_out($self, $package_fields{$package}, @_);
            }
        }
        return;
    }

    sub set_access {
        # Arrange for the input field to be garbage collected when no longer
        # needed.  Also, creates standard accessor functions for the field
        # based on the optional parameters-- none if none of these parameters:
        #   'addable'    creates an 'add_NAME()' accessor function.
        #   'readable' or 'readable_array'   creates a 'NAME()' accessor
        #                function.
        #   'settable'   creates a 'set_NAME()' accessor function.
        #   'constructor' doesn't create an accessor function, but adds the
        #                field to the hash that was previously passed to
        #                setup_package();
        # Any of the accesses can be abbreviated down, so that 'a', 'ad',
        # 'add' etc. all mean 'addable'.
        # The read accessor function will work on both array and scalar
        # values.  If another accessor in the parameter list is 'a', the read
        # access assumes an array.  You can also force it to be array access
        # by specifying 'readable_array' instead of 'readable'
        #
        # A sort-of 'protected' access can be set-up by preceding the addable,
        # readable or settable with some initial portion of 'protected_' (but,
        # the underscore is required), like 'p_a', 'pro_set', etc.  The
        # "protection" is only by convention.  All that happens is that the
        # accessor functions' names begin with an underscore.  So instead of
        # calling set_foo, the call is _set_foo.  (Real protection could be
        # accomplished by having a new subroutine, end_package, called at the
        # end of each package, and then storing the __LINE__ ranges and
        # checking them on every accessor.  But that is way overkill.)

        # We create anonymous subroutines as the accessors and then use
        # typeglobs to assign them to the proper package and name

        my $name = shift;   # Name of the field
        my $field = shift;  # Reference to the inside-out hash containing the
                            # field

        my $package = (caller)[0];

        if (! exists $package_fields{$package}) {
            croak "$0: Must call 'setup_package' before 'set_access'";
        }

        # Stash the field so DESTROY can get it.
        $package_fields{$package}{$name} = $field;

        # Remaining arguments are the accessors.  For each...
        foreach my $access (@_) {
            my $access = lc $access;

            my $protected = "";

            # Match the input as far as it goes.
            if ($access =~ /^(p[^_]*)_/) {
                $protected = $1;
                if (substr('protected_', 0, length $protected)
                    eq $protected)
                {

                    # Add 1 for the underscore not included in $protected
                    $access = substr($access, length($protected) + 1);
                    $protected = '_';
                }
                else {
                    $protected = "";
                }
            }

            if (substr('addable', 0, length $access) eq $access) {
                my $subname = "${package}::${protected}add_$name";
                no strict "refs";

                # add_ accessor.  Don't add if already there, which we
                # determine using 'eq' for scalars and '==' otherwise.
                *$subname = sub {
                    use strict "refs";
                    return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
                    my $self = shift;
                    my $value = shift;
                    my $addr = do { no overloading; pack 'J', $self; };
                    Carp::carp_extra_args(\@_) if main::DEBUG && @_;
                    if (ref $value) {
                        return if grep { $value == $_ } @{$field->{$addr}};
                    }
                    else {
                        return if grep { $value eq $_ } @{$field->{$addr}};
                    }
                    push @{$field->{$addr}}, $value;
                    return;
                }
            }
            elsif (substr('constructor', 0, length $access) eq $access) {
                if ($protected) {
                    Carp::my_carp_bug("Can't set-up 'protected' constructors")
                }
                else {
                    $constructor_fields{$package}{$name} = $field;
                }
            }
            elsif (substr('readable_array', 0, length $access) eq $access) {

                # Here has read access.  If one of the other parameters for
                # access is array, or this one specifies array (by being more
                # than just 'readable_'), then create a subroutine that
                # assumes the data is an array.  Otherwise just a scalar
                my $subname = "${package}::${protected}$name";
                if (grep { /^a/i } @_
                    or length($access) > length('readable_'))
                {
                    no strict "refs";
                    *$subname = sub {
                        use strict "refs";
                        Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
                        my $addr = do { no overloading; pack 'J', $_[0]; };
                        if (ref $field->{$addr} ne 'ARRAY') {
                            my $type = ref $field->{$addr};
                            $type = 'scalar' unless $type;
                            Carp::my_carp_bug("Trying to read $name as an array when it is a $type.  Big problems.");
                            return;
                        }
                        return scalar @{$field->{$addr}} unless wantarray;

                        # Make a copy; had problems with caller modifying the
                        # original otherwise
                        my @return = @{$field->{$addr}};
                        return @return;
                    }
                }
                else {

                    # Here not an array value, a simpler function.
                    no strict "refs";
                    *$subname = sub {
                        use strict "refs";
                        Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
                        no overloading;
                        return $field->{pack 'J', $_[0]};
                    }
                }
            }
            elsif (substr('settable', 0, length $access) eq $access) {
                my $subname = "${package}::${protected}set_$name";
                no strict "refs";
                *$subname = sub {
                    use strict "refs";
                    if (main::DEBUG) {
                        return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
                        Carp::carp_extra_args(\@_) if @_ > 2;
                    }
                    # $self is $_[0]; $value is $_[1]
                    no overloading;
                    $field->{pack 'J', $_[0]} = $_[1];
                    return;
                }
            }
            else {
                Carp::my_carp_bug("Unknown accessor type $access.  No accessor set.");
            }
        }
        return;
    }
}

package Input_file;

# All input files use this object, which stores various attributes about them,
# and provides for convenient, uniform handling.  The run method wraps the
# processing.  It handles all the bookkeeping of opening, reading, and closing
# the file, returning only significant input lines.
#
# Each object gets a handler which processes the body of the file, and is
# called by run().  Most should use the generic, default handler, which has
# code scrubbed to handle things you might not expect.  A handler should
# basically be a while(next_line()) {...} loop.
#
# You can also set up handlers to
#   1) call before the first line is read for pre processing
#   2) call to adjust each line of the input before the main handler gets them
#   3) call upon EOF before the main handler exits its loop
#   4) call at the end for post processing
#
# $_ is used to store the input line, and is to be filtered by the
# each_line_handler()s.  So, if the format of the line is not in the desired
# format for the main handler, these are used to do that adjusting.  They can
# be stacked (by enclosing them in an [ anonymous array ] in the constructor,
# so the $_ output of one is used as the input to the next.  None of the other
# handlers are stackable, but could easily be changed to be so.
#
# Most of the handlers can call insert_lines() or insert_adjusted_lines()
# which insert the parameters as lines to be processed before the next input
# file line is read.  This allows the EOF handler to flush buffers, for
# example.  The difference between the two routines is that the lines inserted
# by insert_lines() are subjected to the each_line_handler()s.  (So if you
# called it from such a handler, you would get infinite recursion.)  Lines
# inserted by insert_adjusted_lines() go directly to the main handler without
# any adjustments.  If the  post-processing handler calls any of these, there
# will be no effect.  Some error checking for these conditions could be added,
# but it hasn't been done.
#
# carp_bad_line() should be called to warn of bad input lines, which clears $_
# to prevent further processing of the line.  This routine will output the
# message as a warning once, and then keep a count of the lines that have the
# same message, and output that count at the end of the file's processing.
# This keeps the number of messages down to a manageable amount.
#
# get_missings() should be called to retrieve any @missing input lines.
# Messages will be raised if this isn't done if the options aren't to ignore
# missings.

sub trace { return main::trace(@_); }

{ # Closure
    # Keep track of fields that are to be put into the constructor.
    my %constructor_fields;

    main::setup_package(Constructor_Fields => \%constructor_fields);

    my %file; # Input file name, required
    main::set_access('file', \%file, qw{ c r });

    my %first_released; # Unicode version file was first released in, required
    main::set_access('first_released', \%first_released, qw{ c r });

    my %handler;    # Subroutine to process the input file, defaults to
                    # 'process_generic_property_file'
    main::set_access('handler', \%handler, qw{ c });

    my %property;
    # name of property this file is for.  defaults to none, meaning not
    # applicable, or is otherwise determinable, for example, from each line.
    main::set_access('property', \%property, qw{ c });

    my %optional;
    # If this is true, the file is optional.  If not present, no warning is
    # output.  If it is present, the string given by this parameter is
    # evaluated, and if false the file is not processed.
    main::set_access('optional', \%optional, 'c', 'r');

    my %non_skip;
    # This is used for debugging, to skip processing of all but a few input
    # files.  Add 'non_skip => 1' to the constructor for those files you want
    # processed when you set the $debug_skip global.
    main::set_access('non_skip', \%non_skip, 'c');

    my %skip;
    # This is used to skip processing of this input file semi-permanently.
    # It is used for files that we aren't planning to process anytime soon,
    # but want to allow to be in the directory and not raise a message that we
    # are not handling.  Mostly for test files.  This is in contrast to the
    # non_skip element, which is supposed to be used very temporarily for
    # debugging.  Sets 'optional' to 1
    main::set_access('skip', \%skip, 'c');

    my %each_line_handler;
    # list of subroutines to look at and filter each non-comment line in the
    # file.  defaults to none.  The subroutines are called in order, each is
    # to adjust $_ for the next one, and the final one adjusts it for
    # 'handler'
    main::set_access('each_line_handler', \%each_line_handler, 'c');

    my %has_missings_defaults;
    # ? Are there lines in the file giving default values for code points
    # missing from it?.  Defaults to NO_DEFAULTS.  Otherwise NOT_IGNORED is
    # the norm, but IGNORED means it has such lines, but the handler doesn't
    # use them.  Having these three states allows us to catch changes to the
    # UCD that this program should track
    main::set_access('has_missings_defaults',
                                        \%has_missings_defaults, qw{ c r });

    my %pre_handler;
    # Subroutine to call before doing anything else in the file.  If undef, no
    # such handler is called.
    main::set_access('pre_handler', \%pre_handler, qw{ c });

    my %eof_handler;
    # Subroutine to call upon getting an EOF on the input file, but before
    # that is returned to the main handler.  This is to allow buffers to be
    # flushed.  The handler is expected to call insert_lines() or
    # insert_adjusted() with the buffered material
    main::set_access('eof_handler', \%eof_handler, qw{ c r });

    my %post_handler;
    # Subroutine to call after all the lines of the file are read in and
    # processed.  If undef, no such handler is called.
    main::set_access('post_handler', \%post_handler, qw{ c });

    my %progress_message;
    # Message to print to display progress in lieu of the standard one
    main::set_access('progress_message', \%progress_message, qw{ c });

    my %handle;
    # cache open file handle, internal.  Is undef if file hasn't been
    # processed at all, empty if has;
    main::set_access('handle', \%handle);

    my %added_lines;
    # cache of lines added virtually to the file, internal
    main::set_access('added_lines', \%added_lines);

    my %errors;
    # cache of errors found, internal
    main::set_access('errors', \%errors);

    my %missings;
    # storage of '@missing' defaults lines
    main::set_access('missings', \%missings);

    sub new {
        my $class = shift;

        my $self = bless \do{ my $anonymous_scalar }, $class;
        my $addr = do { no overloading; pack 'J', $self; };

        # Set defaults
        $handler{$addr} = \&main::process_generic_property_file;
        $non_skip{$addr} = 0;
        $skip{$addr} = 0;
        $has_missings_defaults{$addr} = $NO_DEFAULTS;
        $handle{$addr} = undef;
        $added_lines{$addr} = [ ];
        $each_line_handler{$addr} = [ ];
        $errors{$addr} = { };
        $missings{$addr} = [ ];

        # Two positional parameters.
        return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
        $file{$addr} = main::internal_file_to_platform(shift);
        $first_released{$addr} = shift;

        # The rest of the arguments are key => value pairs
        # %constructor_fields has been set up earlier to list all possible
        # ones.  Either set or push, depending on how the default has been set
        # up just above.
        my %args = @_;
        foreach my $key (keys %args) {
            my $argument = $args{$key};

            # Note that the fields are the lower case of the constructor keys
            my $hash = $constructor_fields{lc $key};
            if (! defined $hash) {
                Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self.  Skipped");
                next;
            }
            if (ref $hash->{$addr} eq 'ARRAY') {
                if (ref $argument eq 'ARRAY') {
                    foreach my $argument (@{$argument}) {
                        next if ! defined $argument;
                        push @{$hash->{$addr}}, $argument;
                    }
                }
                else {
                    push @{$hash->{$addr}}, $argument if defined $argument;
                }
            }
            else {
                $hash->{$addr} = $argument;
            }
            delete $args{$key};
        };

        # If the file has a property for it, it means that the property is not
        # listed in the file's entries.  So add a handler to the list of line
        # handlers to insert the property name into the lines, to provide a
        # uniform interface to the final processing subroutine.
        # the final code doesn't have to worry about that.
        if ($property{$addr}) {
            push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
        }

        if ($non_skip{$addr} && ! $debug_skip && $verbosity) {
            print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
        }

        $optional{$addr} = 1 if $skip{$addr};

        return $self;
    }


    use overload
        fallback => 0,
        qw("") => "_operator_stringify",
        "." => \&main::_operator_dot,
    ;

    sub _operator_stringify {
        my $self = shift;

        return __PACKAGE__ . " object for " . $self->file;
    }

    # flag to make sure extracted files are processed early
    my $seen_non_extracted_non_age = 0;

    sub run {
        # Process the input object $self.  This opens and closes the file and
        # calls all the handlers for it.  Currently,  this can only be called
        # once per file, as it destroy's the EOF handler

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        my $file = $file{$addr};

        # Don't process if not expecting this file (because released later
        # than this Unicode version), and isn't there.  This means if someone
        # copies it into an earlier version's directory, we will go ahead and
        # process it.
        return if $first_released{$addr} gt $v_version && ! -e $file;

        # If in debugging mode and this file doesn't have the non-skip
        # flag set, and isn't one of the critical files, skip it.
        if ($debug_skip
            && $first_released{$addr} ne v0
            && ! $non_skip{$addr})
        {
            print "Skipping $file in debugging\n" if $verbosity;
            return;
        }

        # File could be optional
        if ($optional{$addr}) {
            return unless -e $file;
            my $result = eval $optional{$addr};
            if (! defined $result) {
                Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}.  $file Skipped.");
                return;
            }
            if (! $result) {
                if ($verbosity) {
                    print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n";
                }
                return;
            }
        }

        if (! defined $file || ! -e $file) {

            # If the file doesn't exist, see if have internal data for it
            # (based on first_released being 0).
            if ($first_released{$addr} eq v0) {
                $handle{$addr} = 'pretend_is_open';
            }
            else {
                if (! $optional{$addr}  # File could be optional
                    && $v_version ge $first_released{$addr})
                {
                    print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr};
                }
                return;
            }
        }
        else {

            # Here, the file exists.  Some platforms may change the case of
            # its name
            if ($seen_non_extracted_non_age) {
                if ($file =~ /$EXTRACTED/i) {
                    Carp::my_carp_bug(join_lines(<<END
$file should be processed just after the 'Prop...Alias' files, and before
anything not in the $EXTRACTED_DIR directory.  Proceeding, but the results may
have subtle problems
END
                    ));
                }
            }
            elsif ($EXTRACTED_DIR
                    && $first_released{$addr} ne v0
                    && $file !~ /$EXTRACTED/i
                    && lc($file) ne 'dage.txt')
            {
                # We don't set this (by the 'if' above) if we have no
                # extracted directory, so if running on an early version,
                # this test won't work.  Not worth worrying about.
                $seen_non_extracted_non_age = 1;
            }

            # And mark the file as having being processed, and warn if it
            # isn't a file we are expecting.  As we process the files,
            # they are deleted from the hash, so any that remain at the
            # end of the program are files that we didn't process.
            my $fkey = File::Spec->rel2abs($file);
            my $expecting = delete $potential_files{$fkey};
            $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
            Carp::my_carp("Was not expecting '$file'.") if
                    ! $expecting
                    && ! defined $handle{$addr};

            # Having deleted from expected files, we can quit if not to do
            # anything.  Don't print progress unless really want verbosity
            if ($skip{$addr}) {
                print "Skipping $file.\n" if $verbosity >= $VERBOSE;
                return;
            }

            # Open the file, converting the slashes used in this program
            # into the proper form for the OS
            my $file_handle;
            if (not open $file_handle, "<", $file) {
                Carp::my_carp("Can't open $file.  Skipping: $!");
                return 0;
            }
            $handle{$addr} = $file_handle; # Cache the open file handle
        }

        if ($verbosity >= $PROGRESS) {
            if ($progress_message{$addr}) {
                print "$progress_message{$addr}\n";
            }
            else {
                # If using a virtual file, say so.
                print "Processing ", (-e $file)
                                       ? $file
                                       : "substitute $file",
                                     "\n";
            }
        }


        # Call any special handler for before the file.
        &{$pre_handler{$addr}}($self) if $pre_handler{$addr};

        # Then the main handler
        &{$handler{$addr}}($self);

        # Then any special post-file handler.
        &{$post_handler{$addr}}($self) if $post_handler{$addr};

        # If any errors have been accumulated, output the counts (as the first
        # error message in each class was output when it was encountered).
        if ($errors{$addr}) {
            my $total = 0;
            my $types = 0;
            foreach my $error (keys %{$errors{$addr}}) {
                $total += $errors{$addr}->{$error};
                delete $errors{$addr}->{$error};
                $types++;
            }
            if ($total > 1) {
                my $message
                        = "A total of $total lines had errors in $file.  ";

                $message .= ($types == 1)
                            ? '(Only the first one was displayed.)'
                            : '(Only the first of each type was displayed.)';
                Carp::my_carp($message);
            }
        }

        if (@{$missings{$addr}}) {
            Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines.  Generated tables likely are wrong");
        }

        # If a real file handle, close it.
        close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
                                                        ref $handle{$addr};
        $handle{$addr} = "";   # Uses empty to indicate that has already seen
                               # the file, as opposed to undef
        return;
    }

    sub next_line {
        # Sets $_ to be the next logical input line, if any.  Returns non-zero
        # if such a line exists.  'logical' means that any lines that have
        # been added via insert_lines() will be returned in $_ before the file
        # is read again.

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        # Here the file is open (or if the handle is not a ref, is an open
        # 'virtual' file).  Get the next line; any inserted lines get priority
        # over the file itself.
        my $adjusted;

        LINE:
        while (1) { # Loop until find non-comment, non-empty line
            #local $to_trace = 1 if main::DEBUG;
            my $inserted_ref = shift @{$added_lines{$addr}};
            if (defined $inserted_ref) {
                ($adjusted, $_) = @{$inserted_ref};
                trace $adjusted, $_ if main::DEBUG && $to_trace;
                return 1 if $adjusted;
            }
            else {
                last if ! ref $handle{$addr}; # Don't read unless is real file
                last if ! defined ($_ = readline $handle{$addr});
            }
            chomp;
            trace $_ if main::DEBUG && $to_trace;

            # See if this line is the comment line that defines what property
            # value that code points that are not listed in the file should
            # have.  The format or existence of these lines is not guaranteed
            # by Unicode since they are comments, but the documentation says
            # that this was added for machine-readability, so probably won't
            # change.  This works starting in Unicode Version 5.0.  They look
            # like:
            #
            # @missing: 0000..10FFFF; Not_Reordered
            # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
            # @missing: 0000..10FFFF; ; NaN
            #
            # Save the line for a later get_missings() call.
            if (/$missing_defaults_prefix/) {
                if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
                    $self->carp_bad_line("Unexpected \@missing line.  Assuming no missing entries");
                }
                elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
                    my @defaults = split /\s* ; \s*/x, $_;

                    # The first field is the @missing, which ends in a
                    # semi-colon, so can safely shift.
                    shift @defaults;

                    # Some of these lines may have empty field placeholders
                    # which get in the way.  An example is:
                    # @missing: 0000..10FFFF; ; NaN
                    # Remove them.  Process starting from the top so the
                    # splice doesn't affect things still to be looked at.
                    for (my $i = @defaults - 1; $i >= 0; $i--) {
                        next if $defaults[$i] ne "";
                        splice @defaults, $i, 1;
                    }

                    # What's left should be just the property (maybe) and the
                    # default.  Having only one element means it doesn't have
                    # the property.
                    my $default;
                    my $property;
                    if (@defaults >= 1) {
                        if (@defaults == 1) {
                            $default = $defaults[0];
                        }
                        else {
                            $property = $defaults[0];
                            $default = $defaults[1];
                        }
                    }

                    if (@defaults < 1
                        || @defaults > 2
                        || ($default =~ /^</
                            && $default !~ /^<code *point>$/i
                            && $default !~ /^<none>$/i))
                    {
                        $self->carp_bad_line("Unrecognized \@missing line: $_.  Assuming no missing entries");
                    }
                    else {

                        # If the property is missing from the line, it should
                        # be the one for the whole file
                        $property = $property{$addr} if ! defined $property;

                        # Change <none> to the null string, which is what it
                        # really means.  If the default is the code point
                        # itself, set it to <code point>, which is what
                        # Unicode uses (but sometimes they've forgotten the
                        # space)
                        if ($default =~ /^<none>$/i) {
                            $default = "";
                        }
                        elsif ($default =~ /^<code *point>$/i) {
                            $default = $CODE_POINT;
                        }

                        # Store them as a sub-arrays with both components.
                        push @{$missings{$addr}}, [ $default, $property ];
                    }
                }

                # There is nothing for the caller to process on this comment
                # line.
                next;
            }

            # Remove comments and trailing space, and skip this line if the
            # result is empty
            s/#.*//;
            s/\s+$//;
            next if /^$/;

            # Call any handlers for this line, and skip further processing of
            # the line if the handler sets the line to null.
            foreach my $sub_ref (@{$each_line_handler{$addr}}) {
                &{$sub_ref}($self);
                next LINE if /^$/;
            }

            # Here the line is ok.  return success.
            return 1;
        } # End of looping through lines.

        # If there is an EOF handler, call it (only once) and if it generates
        # more lines to process go back in the loop to handle them.
        if ($eof_handler{$addr}) {
            &{$eof_handler{$addr}}($self);
            $eof_handler{$addr} = "";   # Currently only get one shot at it.
            goto LINE if $added_lines{$addr};
        }

        # Return failure -- no more lines.
        return 0;

    }

#   Not currently used, not fully tested.
#    sub peek {
#        # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
#        # record.  Not callable from an each_line_handler(), nor does it call
#        # an each_line_handler() on the line.
#
#        my $self = shift;
#        my $addr = do { no overloading; pack 'J', $self; };
#
#        foreach my $inserted_ref (@{$added_lines{$addr}}) {
#            my ($adjusted, $line) = @{$inserted_ref};
#            next if $adjusted;
#
#            # Remove comments and trailing space, and return a non-empty
#            # resulting line
#            $line =~ s/#.*//;
#            $line =~ s/\s+$//;
#            return $line if $line ne "";
#        }
#
#        return if ! ref $handle{$addr}; # Don't read unless is real file
#        while (1) { # Loop until find non-comment, non-empty line
#            local $to_trace = 1 if main::DEBUG;
#            trace $_ if main::DEBUG && $to_trace;
#            return if ! defined (my $line = readline $handle{$addr});
#            chomp $line;
#            push @{$added_lines{$addr}}, [ 0, $line ];
#
#            $line =~ s/#.*//;
#            $line =~ s/\s+$//;
#            return $line if $line ne "";
#        }
#
#        return;
#    }


    sub insert_lines {
        # Lines can be inserted so that it looks like they were in the input
        # file at the place it was when this routine is called.  See also
        # insert_adjusted_lines().  Lines inserted via this routine go through
        # any each_line_handler()

        my $self = shift;

        # Each inserted line is an array, with the first element being 0 to
        # indicate that this line hasn't been adjusted, and needs to be
        # processed.
        no overloading;
        push @{$added_lines{pack 'J', $self}}, map { [ 0, $_ ] } @_;
        return;
    }

    sub insert_adjusted_lines {
        # Lines can be inserted so that it looks like they were in the input
        # file at the place it was when this routine is called.  See also
        # insert_lines().  Lines inserted via this routine are already fully
        # adjusted, ready to be processed; each_line_handler()s handlers will
        # not be called.  This means this is not a completely general
        # facility, as only the last each_line_handler on the stack should
        # call this.  It could be made more general, by passing to each of the
        # line_handlers their position on the stack, which they would pass on
        # to this routine, and that would replace the boolean first element in
        # the anonymous array pushed here, so that the next_line routine could
        # use that to call only those handlers whose index is after it on the
        # stack.  But this is overkill for what is needed now.

        my $self = shift;
        trace $_[0] if main::DEBUG && $to_trace;

        # Each inserted line is an array, with the first element being 1 to
        # indicate that this line has been adjusted
        no overloading;
        push @{$added_lines{pack 'J', $self}}, map { [ 1, $_ ] } @_;
        return;
    }

    sub get_missings {
        # Returns the stored up @missings lines' values, and clears the list.
        # The values are in an array, consisting of the default in the first
        # element, and the property in the 2nd.  However, since these lines
        # can be stacked up, the return is an array of all these arrays.

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        # If not accepting a list return, just return the first one.
        return shift @{$missings{$addr}} unless wantarray;

        my @return = @{$missings{$addr}};
        undef @{$missings{$addr}};
        return @return;
    }

    sub _insert_property_into_line {
        # Add a property field to $_, if this file requires it.

        my $self = shift;
        my $addr = do { no overloading; pack 'J', $self; };
        my $property = $property{$addr};
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        $_ =~ s/(;|$)/; $property$1/;
        return;
    }

    sub carp_bad_line {
        # Output consistent error messages, using either a generic one, or the
        # one given by the optional parameter.  To avoid gazillions of the
        # same message in case the syntax of a  file is way off, this routine
        # only outputs the first instance of each message, incrementing a
        # count so the totals can be output at the end of the file.

        my $self = shift;
        my $message = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        $message = 'Unexpected line' unless $message;

        # No trailing punctuation so as to fit with our addenda.
        $message =~ s/[.:;,]$//;

        # If haven't seen this exact message before, output it now.  Otherwise
        # increment the count of how many times it has occurred
        unless ($errors{$addr}->{$message}) {
            Carp::my_carp("$message in '$_' in "
                            . $file{$addr}
                            . " at line $..  Skipping this line;");
            $errors{$addr}->{$message} = 1;
        }
        else {
            $errors{$addr}->{$message}++;
        }

        # Clear the line to prevent any further (meaningful) processing of it.
        $_ = "";

        return;
    }
} # End closure

package Multi_Default;

# Certain properties in early versions of Unicode had more than one possible
# default for code points missing from the files.  In these cases, one
# default applies to everything left over after all the others are applied,
# and for each of the others, there is a description of which class of code
# points applies to it.  This object helps implement this by storing the
# defaults, and for all but that final default, an eval string that generates
# the class that it applies to.


{   # Closure

    main::setup_package();

    my %class_defaults;
    # The defaults structure for the classes
    main::set_access('class_defaults', \%class_defaults);

    my %other_default;
    # The default that applies to everything left over.
    main::set_access('other_default', \%other_default, 'r');


    sub new {
        # The constructor is called with default => eval pairs, terminated by
        # the left-over default. e.g.
        # Multi_Default->new(
        #        'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
        #               -  0x200D',
        #        'R' => 'some other expression that evaluates to code points',
        #        .
        #        .
        #        .
        #        'U'));

        my $class = shift;

        my $self = bless \do{my $anonymous_scalar}, $class;
        my $addr = do { no overloading; pack 'J', $self; };

        while (@_ > 1) {
            my $default = shift;
            my $eval = shift;
            $class_defaults{$addr}->{$default} = $eval;
        }

        $other_default{$addr} = shift;

        return $self;
    }

    sub get_next_defaults {
        # Iterates and returns the next class of defaults.
        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        return each %{$class_defaults{$addr}};
    }
}

package Alias;

# An alias is one of the names that a table goes by.  This class defines them
# including some attributes.  Everything is currently setup in the
# constructor.


{   # Closure

    main::setup_package();

    my %name;
    main::set_access('name', \%name, 'r');

    my %loose_match;
    # Determined by the constructor code if this name should match loosely or
    # not.  The constructor parameters can override this, but it isn't fully
    # implemented, as should have ability to override Unicode one's via
    # something like a set_loose_match()
    main::set_access('loose_match', \%loose_match, 'r');

    my %make_pod_entry;
    # Some aliases should not get their own entries because they are covered
    # by a wild-card, and some we want to discourage use of.  Binary
    main::set_access('make_pod_entry', \%make_pod_entry, 'r');

    my %status;
    # Aliases have a status, like deprecated, or even suppressed (which means
    # they don't appear in documentation).  Enum
    main::set_access('status', \%status, 'r');

    my %externally_ok;
    # Similarly, some aliases should not be considered as usable ones for
    # external use, such as file names, or we don't want documentation to
    # recommend them.  Boolean
    main::set_access('externally_ok', \%externally_ok, 'r');

    sub new {
        my $class = shift;

        my $self = bless \do { my $anonymous_scalar }, $class;
        my $addr = do { no overloading; pack 'J', $self; };

        $name{$addr} = shift;
        $loose_match{$addr} = shift;
        $make_pod_entry{$addr} = shift;
        $externally_ok{$addr} = shift;
        $status{$addr} = shift;

        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        # Null names are never ok externally
        $externally_ok{$addr} = 0 if $name{$addr} eq "";

        return $self;
    }
}

package Range;

# A range is the basic unit for storing code points, and is described in the
# comments at the beginning of the program.  Each range has a starting code
# point; an ending code point (not less than the starting one); a value
# that applies to every code point in between the two end-points, inclusive;
# and an enum type that applies to the value.  The type is for the user's
# convenience, and has no meaning here, except that a non-zero type is
# considered to not obey the normal Unicode rules for having standard forms.
#
# The same structure is used for both map and match tables, even though in the
# latter, the value (and hence type) is irrelevant and could be used as a
# comment.  In map tables, the value is what all the code points in the range
# map to.  Type 0 values have the standardized version of the value stored as
# well, so as to not have to recalculate it a lot.

sub trace { return main::trace(@_); }

{   # Closure

    main::setup_package();

    my %start;
    main::set_access('start', \%start, 'r', 's');

    my %end;
    main::set_access('end', \%end, 'r', 's');

    my %value;
    main::set_access('value', \%value, 'r');

    my %type;
    main::set_access('type', \%type, 'r');

    my %standard_form;
    # The value in internal standard form.  Defined only if the type is 0.
    main::set_access('standard_form', \%standard_form);

    # Note that if these fields change, the dump() method should as well

    sub new {
        return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
        my $class = shift;

        my $self = bless \do { my $anonymous_scalar }, $class;
        my $addr = do { no overloading; pack 'J', $self; };

        $start{$addr} = shift;
        $end{$addr} = shift;

        my %args = @_;

        my $value = delete $args{'Value'};  # Can be 0
        $value = "" unless defined $value;
        $value{$addr} = $value;

        $type{$addr} = delete $args{'Type'} || 0;

        Carp::carp_extra_args(\%args) if main::DEBUG && %args;

        if (! $type{$addr}) {
            $standard_form{$addr} = main::standardize($value);
        }

        return $self;
    }

    use overload
        fallback => 0,
        qw("") => "_operator_stringify",
        "." => \&main::_operator_dot,
    ;

    sub _operator_stringify {
        my $self = shift;
        my $addr = do { no overloading; pack 'J', $self; };

        # Output it like '0041..0065 (value)'
        my $return = sprintf("%04X", $start{$addr})
                        .  '..'
                        . sprintf("%04X", $end{$addr});
        my $value = $value{$addr};
        my $type = $type{$addr};
        $return .= ' (';
        $return .= "$value";
        $return .= ", Type=$type" if $type != 0;
        $return .= ')';

        return $return;
    }

    sub standard_form {
        # The standard form is the value itself if the standard form is
        # undefined (that is if the value is special)

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        return $standard_form{$addr} if defined $standard_form{$addr};
        return $value{$addr};
    }

    sub dump {
        # Human, not machine readable.  For machine readable, comment out this
        # entire routine and let the standard one take effect.
        my $self = shift;
        my $indent = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        my $return = $indent
                    . sprintf("%04X", $start{$addr})
                    . '..'
                    . sprintf("%04X", $end{$addr})
                    . " '$value{$addr}';";
        if (! defined $standard_form{$addr}) {
            $return .= "(type=$type{$addr})";
        }
        elsif ($standard_form{$addr} ne $value{$addr}) {
            $return .= "(standard '$standard_form{$addr}')";
        }
        return $return;
    }
} # End closure

package _Range_List_Base;

# Base class for range lists.  A range list is simply an ordered list of
# ranges, so that the ranges with the lowest starting numbers are first in it.
#
# When a new range is added that is adjacent to an existing range that has the
# same value and type, it merges with it to form a larger range.
#
# Ranges generally do not overlap, except that there can be multiple entries
# of single code point ranges.  This is because of NameAliases.txt.
#
# In this program, there is a standard value such that if two different
# values, have the same standard value, they are considered equivalent.  This
# value was chosen so that it gives correct results on Unicode data

# There are a number of methods to manipulate range lists, and some operators
# are overloaded to handle them.

sub trace { return main::trace(@_); }

{ # Closure

    our $addr;

    main::setup_package();

    my %ranges;
    # The list of ranges
    main::set_access('ranges', \%ranges, 'readable_array');

    my %max;
    # The highest code point in the list.  This was originally a method, but
    # actual measurements said it was used a lot.
    main::set_access('max', \%max, 'r');

    my %each_range_iterator;
    # Iterator position for each_range()
    main::set_access('each_range_iterator', \%each_range_iterator);

    my %owner_name_of;
    # Name of parent this is attached to, if any.  Solely for better error
    # messages.
    main::set_access('owner_name_of', \%owner_name_of, 'p_r');

    my %_search_ranges_cache;
    # A cache of the previous result from _search_ranges(), for better
    # performance
    main::set_access('_search_ranges_cache', \%_search_ranges_cache);

    sub new {
        my $class = shift;
        my %args = @_;

        # Optional initialization data for the range list.
        my $initialize = delete $args{'Initialize'};

        my $self;

        # Use _union() to initialize.  _union() returns an object of this
        # class, which means that it will call this constructor recursively.
        # But it won't have this $initialize parameter so that it won't
        # infinitely loop on this.
        return _union($class, $initialize, %args) if defined $initialize;

        $self = bless \do { my $anonymous_scalar }, $class;
        my $addr = do { no overloading; pack 'J', $self; };

        # Optional parent object, only for debug info.
        $owner_name_of{$addr} = delete $args{'Owner'};
        $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};

        # Stringify, in case it is an object.
        $owner_name_of{$addr} = "$owner_name_of{$addr}";

        # This is used only for error messages, and so a colon is added
        $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";

        Carp::carp_extra_args(\%args) if main::DEBUG && %args;

        # Max is initialized to a negative value that isn't adjacent to 0,
        # for simpler tests
        $max{$addr} = -2;

        $_search_ranges_cache{$addr} = 0;
        $ranges{$addr} = [];

        return $self;
    }

    use overload
        fallback => 0,
        qw("") => "_operator_stringify",
        "." => \&main::_operator_dot,
    ;

    sub _operator_stringify {
        my $self = shift;
        my $addr = do { no overloading; pack 'J', $self; };

        return "Range_List attached to '$owner_name_of{$addr}'"
                                                if $owner_name_of{$addr};
        return "anonymous Range_List " . \$self;
    }

    sub _union {
        # Returns the union of the input code points.  It can be called as
        # either a constructor or a method.  If called as a method, the result
        # will be a new() instance of the calling object, containing the union
        # of that object with the other parameter's code points;  if called as
        # a constructor, the first parameter gives the class the new object
        # should be, and the second parameter gives the code points to go into
        # it.
        # In either case, there are two parameters looked at by this routine;
        # any additional parameters are passed to the new() constructor.
        #
        # The code points can come in the form of some object that contains
        # ranges, and has a conventionally named method to access them; or
        # they can be an array of individual code points (as integers); or
        # just a single code point.
        #
        # If they are ranges, this routine doesn't make any effort to preserve
        # the range values of one input over the other.  Therefore this base
        # class should not allow _union to be called from other than
        # initialization code, so as to prevent two tables from being added
        # together where the range values matter.  The general form of this
        # routine therefore belongs in a derived class, but it was moved here
        # to avoid duplication of code.  The failure to overload this in this
        # class keeps it safe.
        #

        my $self;
        my @args;   # Arguments to pass to the constructor

        my $class = shift;

        # If a method call, will start the union with the object itself, and
        # the class of the new object will be the same as self.
        if (ref $class) {
            $self = $class;
            $class = ref $self;
            push @args, $self;
        }

        # Add the other required parameter.
        push @args, shift;
        # Rest of parameters are passed on to the constructor

        # Accumulate all records from both lists.
        my @records;
        for my $arg (@args) {
            #local $to_trace = 0 if main::DEBUG;
            trace "argument = $arg" if main::DEBUG && $to_trace;
            if (! defined $arg) {
                my $message = "";
                if (defined $self) {
                    no overloading;
                    $message .= $owner_name_of{pack 'J', $self};
                }
                Carp::my_carp_bug($message .= "Undefined argument to _union.  No union done.");
                return;
            }
            $arg = [ $arg ] if ! ref $arg;
            my $type = ref $arg;
            if ($type eq 'ARRAY') {
                foreach my $element (@$arg) {
                    push @records, Range->new($element, $element);
                }
            }
            elsif ($arg->isa('Range')) {
                push @records, $arg;
            }
            elsif ($arg->can('ranges')) {
                push @records, $arg->ranges;
            }
            else {
                my $message = "";
                if (defined $self) {
                    no overloading;
                    $message .= $owner_name_of{pack 'J', $self};
                }
                Carp::my_carp_bug($message . "Cannot take the union of a $type.  No union done.");
                return;
            }
        }

        # Sort with the range containing the lowest ordinal first, but if
        # two ranges start at the same code point, sort with the bigger range
        # of the two first, because it takes fewer cycles.
        @records = sort { ($a->start <=> $b->start)
                                      or
                                    # if b is shorter than a, b->end will be
                                    # less than a->end, and we want to select
                                    # a, so want to return -1
                                    ($b->end <=> $a->end)
                                   } @records;

        my $new = $class->new(@_);

        # Fold in records so long as they add new information.
        for my $set (@records) {
            my $start = $set->start;
            my $end   = $set->end;
            my $value   = $set->value;
            if ($start > $new->max) {
                $new->_add_delete('+', $start, $end, $value);
            }
            elsif ($end > $new->max) {
                $new->_add_delete('+', $new->max +1, $end, $value);
            }
        }

        return $new;
    }

    sub range_count {        # Return the number of ranges in the range list
        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        no overloading;
        return scalar @{$ranges{pack 'J', $self}};
    }

    sub min {
        # Returns the minimum code point currently in the range list, or if
        # the range list is empty, 2 beyond the max possible.  This is a
        # method because used so rarely, that not worth saving between calls,
        # and having to worry about changing it as ranges are added and
        # deleted.

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        # If the range list is empty, return a large value that isn't adjacent
        # to any that could be in the range list, for simpler tests
        return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
        return $ranges{$addr}->[0]->start;
    }

    sub contains {
        # Boolean: Is argument in the range list?  If so returns $i such that:
        #   range[$i]->end < $codepoint <= range[$i+1]->end
        # which is one beyond what you want; this is so that the 0th range
        # doesn't return false
        my $self = shift;
        my $codepoint = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $i = $self->_search_ranges($codepoint);
        return 0 unless defined $i;

        # The search returns $i, such that
        #   range[$i-1]->end < $codepoint <= range[$i]->end
        # So is in the table if and only iff it is at least the start position
        # of range $i.
        no overloading;
        return 0 if $ranges{pack 'J', $self}->[$i]->start > $codepoint;
        return $i + 1;
    }

    sub containing_range {
        # Returns the range object that contains the code point, undef if none

        my $self = shift;
        my $codepoint = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $i = $self->contains($codepoint);
        return unless $i;

        # contains() returns 1 beyond where we should look
        no overloading;
        return $ranges{pack 'J', $self}->[$i-1];
    }

    sub value_of {
        # Returns the value associated with the code point, undef if none

        my $self = shift;
        my $codepoint = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $range = $self->containing_range($codepoint);
        return unless defined $range;

        return $range->value;
    }

    sub type_of {
        # Returns the type of the range containing the code point, undef if
        # the code point is not in the table

        my $self = shift;
        my $codepoint = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $range = $self->containing_range($codepoint);
        return unless defined $range;

        return $range->type;
    }

    sub _search_ranges {
        # Find the range in the list which contains a code point, or where it
        # should go if were to add it.  That is, it returns $i, such that:
        #   range[$i-1]->end < $codepoint <= range[$i]->end
        # Returns undef if no such $i is possible (e.g. at end of table), or
        # if there is an error.

        my $self = shift;
        my $code_point = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        return if $code_point > $max{$addr};
        my $r = $ranges{$addr};                # The current list of ranges
        my $range_list_size = scalar @$r;
        my $i;

        use integer;        # want integer division

        # Use the cached result as the starting guess for this one, because,
        # an experiment on 5.1 showed that 90% of the time the cache was the
        # same as the result on the next call (and 7% it was one less).
        $i = $_search_ranges_cache{$addr};
        $i = 0 if $i >= $range_list_size;   # Reset if no longer valid (prob.
                                            # from an intervening deletion
        #local $to_trace = 1 if main::DEBUG;
        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);
        return $i if $code_point <= $r->[$i]->end
                     && ($i == 0 || $r->[$i-1]->end < $code_point);

        # Here the cache doesn't yield the correct $i.  Try adding 1.
        if ($i < $range_list_size - 1
            && $r->[$i]->end < $code_point &&
            $code_point <= $r->[$i+1]->end)
        {
            $i++;
            trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
            $_search_ranges_cache{$addr} = $i;
            return $i;
        }

        # Here, adding 1 also didn't work.  We do a binary search to
        # find the correct position, starting with current $i
        my $lower = 0;
        my $upper = $range_list_size - 1;
        while (1) {
            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;

            if ($code_point <= $r->[$i]->end) {

                # Here we have met the upper constraint.  We can quit if we
                # also meet the lower one.
                last if $i == 0 || $r->[$i-1]->end < $code_point;

                $upper = $i;        # Still too high.

            }
            else {

                # Here, $r[$i]->end < $code_point, so look higher up.
                $lower = $i;
            }

            # Split search domain in half to try again.
            my $temp = ($upper + $lower) / 2;

            # No point in continuing unless $i changes for next time
            # in the loop.
            if ($temp == $i) {

                # We can't reach the highest element because of the averaging.
                # So if one below the upper edge, force it there and try one
                # more time.
                if ($i == $range_list_size - 2) {

                    trace "Forcing to upper edge" if main::DEBUG && $to_trace;
                    $i = $range_list_size - 1;

                    # Change $lower as well so if fails next time through,
                    # taking the average will yield the same $i, and we will
                    # quit with the error message just below.
                    $lower = $i;
                    next;
                }
                Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go.  No action taken.");
                return;
            }
            $i = $temp;
        } # End of while loop

        if (main::DEBUG && $to_trace) {
            trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i;
            trace "i=  [ $i ]", $r->[$i];
            trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1;
        }

        # Here we have found the offset.  Cache it as a starting point for the
        # next call.
        $_search_ranges_cache{$addr} = $i;
        return $i;
    }

    sub _add_delete {
        # Add, replace or delete ranges to or from a list.  The $type
        # parameter gives which:
        #   '+' => insert or replace a range, returning a list of any changed
        #          ranges.
        #   '-' => delete a range, returning a list of any deleted ranges.
        #
        # The next three parameters give respectively the start, end, and
        # value associated with the range.  'value' should be null unless the
        # operation is '+';
        #
        # The range list is kept sorted so that the range with the lowest
        # starting position is first in the list, and generally, adjacent
        # ranges with the same values are merged into a single larger one (see
        # exceptions below).
        #
        # There are more parameters; all are key => value pairs:
        #   Type    gives the type of the value.  It is only valid for '+'.
        #           All ranges have types; if this parameter is omitted, 0 is
        #           assumed.  Ranges with type 0 are assumed to obey the
        #           Unicode rules for casing, etc; ranges with other types are
        #           not.  Otherwise, the type is arbitrary, for the caller's
        #           convenience, and looked at only by this routine to keep
        #           adjacent ranges of different types from being merged into
        #           a single larger range, and when Replace =>
        #           $IF_NOT_EQUIVALENT is specified (see just below).
        #   Replace  determines what to do if the range list already contains
        #            ranges which coincide with all or portions of the input
        #            range.  It is only valid for '+':
        #       => $NO            means that the new value is not to replace
        #                         any existing ones, but any empty gaps of the
        #                         range list coinciding with the input range
        #                         will be filled in with the new value.
        #       => $UNCONDITIONALLY  means to replace the existing values with
        #                         this one unconditionally.  However, if the
        #                         new and old values are identical, the
        #                         replacement is skipped to save cycles
        #       => $IF_NOT_EQUIVALENT means to replace the existing values
        #                         with this one if they are not equivalent.
        #                         Ranges are equivalent if their types are the
        #                         same, and they are the same string; or if
        #                         both are type 0 ranges, if their Unicode
        #                         standard forms are identical.  In this last
        #                         case, the routine chooses the more "modern"
        #                         one to use.  This is because some of the
        #                         older files are formatted with values that
        #                         are, for example, ALL CAPs, whereas the
        #                         derived files have a more modern style,
        #                         which looks better.  By looking for this
        #                         style when the pre-existing and replacement
        #                         standard forms are the same, we can move to
        #                         the modern style
        #       => $MULTIPLE      means that if this range duplicates an
        #                         existing one, but has a different value,
        #                         don't replace the existing one, but insert
        #                         this, one so that the same range can occur
        #                         multiple times.  They are stored LIFO, so
        #                         that the final one inserted is the first one
        #                         returned in an ordered search of the table.
        #       => anything else  is the same as => $IF_NOT_EQUIVALENT
        #
        # "same value" means identical for non-type-0 ranges, and it means
        # having the same standard forms for type-0 ranges.

        return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;

        my $self = shift;
        my $operation = shift;   # '+' for add/replace; '-' for delete;
        my $start = shift;
        my $end   = shift;
        my $value = shift;

        my %args = @_;

        $value = "" if not defined $value;        # warning: $value can be "0"

        my $replace = delete $args{'Replace'};
        $replace = $IF_NOT_EQUIVALENT unless defined $replace;

        my $type = delete $args{'Type'};
        $type = 0 unless defined $type;

        Carp::carp_extra_args(\%args) if main::DEBUG && %args;

        my $addr = do { no overloading; pack 'J', $self; };

        if ($operation ne '+' && $operation ne '-') {
            Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'.  No action taken.");
            return;
        }
        unless (defined $start && defined $end) {
            Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete.  No action taken.");
            return;
        }
        unless ($end >= $start) {
            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.");
            return;
        }
        #local $to_trace = 1 if main::DEBUG;

        if ($operation eq '-') {
            if ($replace != $IF_NOT_EQUIVALENT) {
                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.");
                $replace = $IF_NOT_EQUIVALENT;
            }
            if ($type) {
                Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list.  Assuming Type => 0.");
                $type = 0;
            }
            if ($value ne "") {
                Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list.  Assuming Value => \"\".");
                $value = "";
            }
        }

        my $r = $ranges{$addr};               # The current list of ranges
        my $range_list_size = scalar @$r;     # And its size
        my $max = $max{$addr};                # The current high code point in
                                              # the list of ranges

        # Do a special case requiring fewer machine cycles when the new range
        # starts after the current highest point.  The Unicode input data is
        # structured so this is common.
        if ($start > $max) {

            trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
            return if $operation eq '-'; # Deleting a non-existing range is a
                                         # no-op

            # If the new range doesn't logically extend the current final one
            # in the range list, create a new range at the end of the range
            # list.  (max cleverly is initialized to a negative number not
            # adjacent to 0 if the range list is empty, so even adding a range
            # to an empty range list starting at 0 will have this 'if'
            # succeed.)
            if ($start > $max + 1        # non-adjacent means can't extend.
                || @{$r}[-1]->value ne $value # values differ, can't extend.
                || @{$r}[-1]->type != $type # types differ, can't extend.
            ) {
                push @$r, Range->new($start, $end,
                                     Value => $value,
                                     Type => $type);
            }
            else {

                # Here, the new range starts just after the current highest in
                # the range list, and they have the same type and value.
                # Extend the current range to incorporate the new one.
                @{$r}[-1]->set_end($end);
            }

            # This becomes the new maximum.
            $max{$addr} = $end;

            return;
        }
        #local $to_trace = 0 if main::DEBUG;

        trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace;

        # Here, the input range isn't after the whole rest of the range list.
        # Most likely 'splice' will be needed.  The rest of the routine finds
        # the needed splice parameters, and if necessary, does the splice.
        # First, find the offset parameter needed by the splice function for
        # the input range.  Note that the input range may span multiple
        # existing ones, but we'll worry about that later.  For now, just find
        # the beginning.  If the input range is to be inserted starting in a
        # position not currently in the range list, it must (obviously) come
        # just after the range below it, and just before the range above it.
        # Slightly less obviously, it will occupy the position currently
        # occupied by the range that is to come after it.  More formally, we
        # are looking for the position, $i, in the array of ranges, such that:
        #
        # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end
        #
        # (The ordered relationships within existing ranges are also shown in
        # the equation above).  However, if the start of the input range is
        # within an existing range, the splice offset should point to that
        # existing range's position in the list; that is $i satisfies a
        # somewhat different equation, namely:
        #
        #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end
        #
        # More briefly, $start can come before or after r[$i]->start, and at
        # this point, we don't know which it will be.  However, these
        # two equations share these constraints:
        #
        #   r[$i-1]->end < $start <= r[$i]->end
        #
        # And that is good enough to find $i.

        my $i = $self->_search_ranges($start);
        if (! defined $i) {
            Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined.  Operation '$operation' not performed");
            return;
        }

        # The search function returns $i such that:
        #
        # r[$i-1]->end < $start <= r[$i]->end
        #
        # That means that $i points to the first range in the range list
        # that could possibly be affected by this operation.  We still don't
        # know if the start of the input range is within r[$i], or if it
        # points to empty space between r[$i-1] and r[$i].
        trace "[$i] is the beginning splice point.  Existing range there is ", $r->[$i] if main::DEBUG && $to_trace;

        # Special case the insertion of data that is not to replace any
        # existing data.
        if ($replace == $NO) {  # If $NO, has to be operation '+'
            #local $to_trace = 1 if main::DEBUG;
            trace "Doesn't replace" if main::DEBUG && $to_trace;

            # Here, the new range is to take effect only on those code points
            # that aren't already in an existing range.  This can be done by
            # looking through the existing range list and finding the gaps in
            # the ranges that this new range affects, and then calling this
            # function recursively on each of those gaps, leaving untouched
            # anything already in the list.  Gather up a list of the changed
            # gaps first so that changes to the internal state as new ranges
            # are added won't be a problem.
            my @gap_list;

            # First, if the starting point of the input range is outside an
            # existing one, there is a gap from there to the beginning of the
            # existing range -- add a span to fill the part that this new
            # range occupies
            if ($start < $r->[$i]->start) {
                push @gap_list, Range->new($start,
                                           main::min($end,
                                                     $r->[$i]->start - 1),
                                           Type => $type);
                trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace;
            }

            # Then look through the range list for other gaps until we reach
            # the highest range affected by the input one.
            my $j;
            for ($j = $i+1; $j < $range_list_size; $j++) {
                trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace;
                last if $end < $r->[$j]->start;

                # If there is a gap between when this range starts and the
                # previous one ends, add a span to fill it.  Note that just
                # because there are two ranges doesn't mean there is a
                # non-zero gap between them.  It could be that they have
                # different values or types
                if ($r->[$j-1]->end + 1 != $r->[$j]->start) {
                    push @gap_list,
                        Range->new($r->[$j-1]->end + 1,
                                   $r->[$j]->start - 1,
                                   Type => $type);
                    trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace;
                }
            }

            # Here, we have either found an existing range in the range list,
            # beyond the area affected by the input one, or we fell off the
            # end of the loop because the input range affects the whole rest
            # of the range list.  In either case, $j is 1 higher than the
            # highest affected range.  If $j == $i, it means that there are no
            # affected ranges, that the entire insertion is in the gap between
            # r[$i-1], and r[$i], which we already have taken care of before
            # the loop.
            # On the other hand, if there are affected ranges, it might be
            # that there is a gap that needs filling after the final such
            # range to the end of the input range
            if ($r->[$j-1]->end < $end) {
                    push @gap_list, Range->new(main::max($start,
                                                         $r->[$j-1]->end + 1),
                                               $end,
                                               Type => $type);
                    trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace;
            }

            # Call recursively to fill in all the gaps.
            foreach my $gap (@gap_list) {
                $self->_add_delete($operation,
                                   $gap->start,
                                   $gap->end,
                                   $value,
                                   Type => $type);
            }

            return;
        }

        # Here, we have taken care of the case where $replace is $NO.
        # Remember that here, r[$i-1]->end < $start <= r[$i]->end
        # If inserting a multiple record, this is where it goes, before the
        # first (if any) existing one.  This implies an insertion, and no
        # change to any existing ranges.  Note that $i can be -1 if this new
        # range doesn't actually duplicate any existing, and comes at the
        # beginning of the list.
        if ($replace == $MULTIPLE) {

            if ($start != $end) {
                Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the range ($start..$end) contains more than one code point.  No action taken.");
                return;
            }

            # Don't add an exact duplicate, as it isn't really a multiple
            if ($end >= $r->[$i]->start) {
                if ($r->[$i]->start != $r->[$i]->end) {
                    Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the other range ($r->[$i]) contains more than one code point.  No action taken.");
                    return;
                }
                return if $value eq $r->[$i]->value && $type eq $r->[$i]->type;
            }

            trace "Adding multiple record at $i with $start..$end, $value" if main::DEBUG && $to_trace;
            my @return = splice @$r,
                                $i,
                                0,
                                Range->new($start,
                                           $end,
                                           Value => $value,
                                           Type => $type);
            if (main::DEBUG && $to_trace) {
                trace "After splice:";
                trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
                trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
                trace "i  =[", $i, "]", $r->[$i] if $i >= 0;
                trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
                trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
                trace 'i+3=[', $i+3, ']', $r->[$i+3] if $i < @$r - 3;
            }
            return @return;
        }

        # Here, we have taken care of $NO and $MULTIPLE replaces.  This leaves
        # delete, insert, and replace either unconditionally or if not
        # equivalent.  $i still points to the first potential affected range.
        # Now find the highest range affected, which will determine the length
        # parameter to splice.  (The input range can span multiple existing
        # ones.)  If this isn't a deletion, while we are looking through the
        # range list, see also if this is a replacement rather than a clean
        # insertion; that is if it will change the values of at least one
        # existing range.  Start off assuming it is an insert, until find it
        # isn't.
        my $clean_insert = $operation eq '+';
        my $j;        # This will point to the highest affected range

        # For non-zero types, the standard form is the value itself;
        my $standard_form = ($type) ? $value : main::standardize($value);

        for ($j = $i; $j < $range_list_size; $j++) {
            trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace;

            # If find a range that it doesn't overlap into, we can stop
            # searching
            last if $end < $r->[$j]->start;

            # Here, overlaps the range at $j.  If the values don't match,
            # and so far we think this is a clean insertion, it becomes a
            # non-clean insertion, i.e., a 'change' or 'replace' instead.
            if ($clean_insert) {
                if ($r->[$j]->standard_form ne $standard_form) {
                    $clean_insert = 0;
                    if ($replace == $CROAK) {
                        main::croak("The range to add "
                        . sprintf("%04X", $start)
                        . '-'
                        . sprintf("%04X", $end)
                        . " with value '$value' overlaps an existing range $r->[$j]");
                    }
                }
                else {

                    # Here, the two values are essentially the same.  If the
                    # two are actually identical, replacing wouldn't change
                    # anything so skip it.
                    my $pre_existing = $r->[$j]->value;
                    if ($pre_existing ne $value) {

                        # Here the new and old standardized values are the
                        # same, but the non-standardized values aren't.  If
                        # replacing unconditionally, then replace
                        if( $replace == $UNCONDITIONALLY) {
                            $clean_insert = 0;
                        }
                        else {

                            # Here, are replacing conditionally.  Decide to
                            # replace or not based on which appears to look
                            # the "nicest".  If one is mixed case and the
                            # other isn't, choose the mixed case one.
                            my $new_mixed = $value =~ /[A-Z]/
                                            && $value =~ /[a-z]/;
                            my $old_mixed = $pre_existing =~ /[A-Z]/
                                            && $pre_existing =~ /[a-z]/;

                            if ($old_mixed != $new_mixed) {
                                $clean_insert = 0 if $new_mixed;
                                if (main::DEBUG && $to_trace) {
                                    if ($clean_insert) {
                                        trace "Retaining $pre_existing over $value";
                                    }
                                    else {
                                        trace "Replacing $pre_existing with $value";
                                    }
                                }
                            }
                            else {

                                # Here casing wasn't different between the two.
                                # If one has hyphens or underscores and the
                                # other doesn't, choose the one with the
                                # punctuation.
                                my $new_punct = $value =~ /[-_]/;
                                my $old_punct = $pre_existing =~ /[-_]/;

                                if ($old_punct != $new_punct) {
                                    $clean_insert = 0 if $new_punct;
                                    if (main::DEBUG && $to_trace) {
                                        if ($clean_insert) {
                                            trace "Retaining $pre_existing over $value";
                                        }
                                        else {
                                            trace "Replacing $pre_existing with $value";
                                        }
                                    }
                                }   # else existing one is just as "good";
                                    # retain it to save cycles.
                            }
                        }
                    }
                }
            }
        } # End of loop looking for highest affected range.

        # Here, $j points to one beyond the highest range that this insertion
        # affects (hence to beyond the range list if that range is the final
        # one in the range list).

        # The splice length is all the affected ranges.  Get it before
        # subtracting, for efficiency, so we don't have to later add 1.
        my $length = $j - $i;

        $j--;        # $j now points to the highest affected range.
        trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;

        # Here, have taken care of $NO and $MULTIPLE replaces.
        # $j points to the highest affected range.  But it can be < $i or even
        # -1.  These happen only if the insertion is entirely in the gap
        # between r[$i-1] and r[$i].  Here's why: j < i means that the j loop
        # above exited first time through with $end < $r->[$i]->start.  (And
        # then we subtracted one from j)  This implies also that $start <
        # $r->[$i]->start, but we know from above that $r->[$i-1]->end <
        # $start, so the entire input range is in the gap.
        if ($j < $i) {

            # Here the entire input range is in the gap before $i.

            if (main::DEBUG && $to_trace) {
                if ($i) {
                    trace "Entire range is between $r->[$i-1] and $r->[$i]";
                }
                else {
                    trace "Entire range is before $r->[$i]";
                }
            }
            return if $operation ne '+'; # Deletion of a non-existent range is
                                         # a no-op
        }
        else {

            # Here part of the input range is not in the gap before $i.  Thus,
            # there is at least one affected one, and $j points to the highest
            # such one.

            # At this point, here is the situation:
            # This is not an insertion of a multiple, nor of tentative ($NO)
            # data.
            #   $i  points to the first element in the current range list that
            #            may be affected by this operation.  In fact, we know
            #            that the range at $i is affected because we are in
            #            the else branch of this 'if'
            #   $j  points to the highest affected range.
            # In other words,
            #   r[$i-1]->end < $start <= r[$i]->end
            # And:
            #   r[$i-1]->end < $start <= $end <= r[$j]->end
            #
            # Also:
            #   $clean_insert is a boolean which is set true if and only if
            #        this is a "clean insertion", i.e., not a change nor a
            #        deletion (multiple was handled above).

            # We now have enough information to decide if this call is a no-op
            # or not.  It is a no-op if this is an insertion of already
            # existing data.

            if (main::DEBUG && $to_trace && $clean_insert
                                         && $i == $j
                                         && $start >= $r->[$i]->start)
            {
                    trace "no-op";
            }
            return if $clean_insert
                      && $i == $j # more than one affected range => not no-op

                      # Here, r[$i-1]->end < $start <= $end <= r[$i]->end
                      # Further, $start and/or $end is >= r[$i]->start
                      # The test below hence guarantees that
                      #     r[$i]->start < $start <= $end <= r[$i]->end
                      # This means the input range is contained entirely in
                      # the one at $i, so is a no-op
                      && $start >= $r->[$i]->start;
        }

        # Here, we know that some action will have to be taken.  We have
        # calculated the offset and length (though adjustments may be needed)
        # for the splice.  Now start constructing the replacement list.
        my @replacement;
        my $splice_start = $i;

        my $extends_below;
        my $extends_above;

        # See if should extend any adjacent ranges.
        if ($operation eq '-') { # Don't extend deletions
            $extends_below = $extends_above = 0;
        }
        else {  # Here, should extend any adjacent ranges.  See if there are
                # any.
            $extends_below = ($i > 0
                            # can't extend unless adjacent
                            && $r->[$i-1]->end == $start -1
                            # can't extend unless are same standard value
                            && $r->[$i-1]->standard_form eq $standard_form
                            # can't extend unless share type
                            && $r->[$i-1]->type == $type);
            $extends_above = ($j+1 < $range_list_size
                            && $r->[$j+1]->start == $end +1
                            && $r->[$j+1]->standard_form eq $standard_form
                            && $r->[$j+1]->type == $type);
        }
        if ($extends_below && $extends_above) { # Adds to both
            $splice_start--;     # start replace at element below
            $length += 2;        # will replace on both sides
            trace "Extends both below and above ranges" if main::DEBUG && $to_trace;

            # The result will fill in any gap, replacing both sides, and
            # create one large range.
            @replacement = Range->new($r->[$i-1]->start,
                                      $r->[$j+1]->end,
                                      Value => $value,
                                      Type => $type);
        }
        else {

            # Here we know that the result won't just be the conglomeration of
            # a new range with both its adjacent neighbors.  But it could
            # extend one of them.

            if ($extends_below) {

                # Here the new element adds to the one below, but not to the
                # one above.  If inserting, and only to that one range,  can
                # just change its ending to include the new one.
                if ($length == 0 && $clean_insert) {
                    $r->[$i-1]->set_end($end);
                    trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace;
                    return;
                }
                else {
                    trace "Changing inserted range to start at ", sprintf("%04X",  $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace;
                    $splice_start--;        # start replace at element below
                    $length++;              # will replace the element below
                    $start = $r->[$i-1]->start;
                }
            }
            elsif ($extends_above) {

                # Here the new element adds to the one above, but not below.
                # Mirror the code above
                if ($length == 0 && $clean_insert) {
                    $r->[$j+1]->set_start($start);
                    trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace;
                    return;
                }
                else {
                    trace "Changing inserted range to end at ", sprintf("%04X",  $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace;
                    $length++;        # will replace the element above
                    $end = $r->[$j+1]->end;
                }
            }

            trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace;

            # Finally, here we know there will have to be a splice.
            # If the change or delete affects only the highest portion of the
            # first affected range, the range will have to be split.  The
            # splice will remove the whole range, but will replace it by a new
            # range containing just the unaffected part.  So, in this case,
            # add to the replacement list just this unaffected portion.
            if (! $extends_below
                && $start > $r->[$i]->start && $start <= $r->[$i]->end)
            {
                push @replacement,
                    Range->new($r->[$i]->start,
                               $start - 1,
                               Value => $r->[$i]->value,
                               Type => $r->[$i]->type);
            }

            # In the case of an insert or change, but not a delete, we have to
            # put in the new stuff;  this comes next.
            if ($operation eq '+') {
                push @replacement, Range->new($start,
                                              $end,
                                              Value => $value,
                                              Type => $type);
            }

            trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i;
            #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace;

            # And finally, if we're changing or deleting only a portion of the
            # highest affected range, it must be split, as the lowest one was.
            if (! $extends_above
                && $j >= 0  # Remember that j can be -1 if before first
                            # current element
                && $end >= $r->[$j]->start
                && $end < $r->[$j]->end)
            {
                push @replacement,
                    Range->new($end + 1,
                               $r->[$j]->end,
                               Value => $r->[$j]->value,
                               Type => $r->[$j]->type);
            }
        }

        # And do the splice, as calculated above
        if (main::DEBUG && $to_trace) {
            trace "replacing $length element(s) at $i with ";
            foreach my $replacement (@replacement) {
                trace "    $replacement";
            }
            trace "Before splice:";
            trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
            trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
            trace "i  =[", $i, "]", $r->[$i];
            trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
            trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
        }

        my @return = splice @$r, $splice_start, $length, @replacement;

        if (main::DEBUG && $to_trace) {
            trace "After splice:";
            trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
            trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
            trace "i  =[", $i, "]", $r->[$i];
            trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
            trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
            trace "removed ", @return if @return;
        }

        # An actual deletion could have changed the maximum in the list.
        # There was no deletion if the splice didn't return something, but
        # otherwise recalculate it.  This is done too rarely to worry about
        # performance.
        if ($operation eq '-' && @return) {
            $max{$addr} = $r->[-1]->end;
        }
        return @return;
    }

    sub reset_each_range {  # reset the iterator for each_range();
        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        no overloading;
        undef $each_range_iterator{pack 'J', $self};
        return;
    }

    sub each_range {
        # Iterate over each range in a range list.  Results are undefined if
        # the range list is changed during the iteration.

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        return if $self->is_empty;

        $each_range_iterator{$addr} = -1
                                if ! defined $each_range_iterator{$addr};
        $each_range_iterator{$addr}++;
        return $ranges{$addr}->[$each_range_iterator{$addr}]
                        if $each_range_iterator{$addr} < @{$ranges{$addr}};
        undef $each_range_iterator{$addr};
        return;
    }

    sub count {        # Returns count of code points in range list
        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        my $count = 0;
        foreach my $range (@{$ranges{$addr}}) {
            $count += $range->end - $range->start + 1;
        }
        return $count;
    }

    sub delete_range {    # Delete a range
        my $self = shift;
        my $start = shift;
        my $end = shift;

        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        return $self->_add_delete('-', $start, $end, "");
    }

    sub is_empty { # Returns boolean as to if a range list is empty
        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        no overloading;
        return scalar @{$ranges{pack 'J', $self}} == 0;
    }

    sub hash {
        # Quickly returns a scalar suitable for separating tables into
        # buckets, i.e. it is a hash function of the contents of a table, so
        # there are relatively few conflicts.

        my $self = shift;
        Carp::carp_extra_args(\@_) if main::DEBUG && @_;

        my $addr = do { no overloading; pack 'J', $self; };

        # These are quickly computable.  Return looks like 'min..max;count'
        return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
    }
} # End closure for _Range_List_Base

package Range_List;
use base '_Range_List_Base';

# A Range_List is a range list for match tables; i.e. the range values are
# not significant.  Thus a number of operations can be safely added to it,
# such as inversion, intersection.  Note that union is also an unsafe
# operation when range values are cared about, and that method is in the base
# class, not here.  But things are set up so that that method is callable only
# during initialization.  Only in this derived class, is there an operation
# that combines two tables.  A Range_Map can thus be used to initialize a
# Range_List, and its mappings will be in the list, but are not significant to
# this class.

sub trace { return main::trace(@_); }

{ # Closure

    use overload
        fallback => 0,
        '+' => sub { my $self = shift;
                    my $other = shift;

                    return $self->_union($other)
                },
        '&' => sub { my $self = shift;
                    my $other = shift;

                    return $self->_intersect($other, 0);
                },
        '~' => "_invert",
        '-' => "_subtract",
    ;

    sub _invert {
        # Returns a new Range_List that gives all code points not in $self.

        my $self = shift;

        my $new = Range_List->new;

        # Go through each range in the table, finding the gaps between them
        my $max = -1;   # Set so no gap before range beginning at 0
        for my $range ($self->ranges) {
            my $start = $range->start;
            my $end   = $range->end;

            # If there is a gap before this range, the inverse will contain
            # that gap.
            if ($start > $max + 1) {
                $new->add_range($max + 1, $start - 1);
            }
            $max = $end;
        }

        # And finally, add the gap from the end of the table to the max
        # possible code point
        if ($max < $LAST_UNICODE_CODEPOINT) {
            $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
        }
        return $new;