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