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