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.
7 # Needs 'no overloading' to run faster on miniperl. Code commented out at the
8 # subroutine objaddr can be used instead to work as far back (untested) as
9 # 5.8: needs pack "U". But almost all occurrences of objaddr have been
10 # removed in favor of using 'no overloading'. You also would have to go
11 # through and replace occurrences like:
12 # my $addr = do { no overloading; pack 'J', $self; }
14 # my $addr = main::objaddr $self;
15 # (or reverse commit 9b01bafde4b022706c3d6f947a0963f821b2e50b
16 # that instituted the change to main::objaddr, and subsequent commits that
17 # changed 0+$self to pack 'J', $self.)
20 BEGIN { # Get the time the script started running; do it at compilation to
21 # get it as close as possible
36 sub DEBUG () { 0 } # Set to 0 for production; 1 for development
37 my $debugging_build = $Config{"ccflags"} =~ /-DDEBUGGING/;
39 ##########################################################################
41 # mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
42 # from the Unicode database files (lib/unicore/.../*.txt), It also generates
43 # a pod file and a .t file
45 # The structure of this file is:
46 # First these introductory comments; then
47 # code needed for everywhere, such as debugging stuff; then
48 # code to handle input parameters; then
49 # data structures likely to be of external interest (some of which depend on
50 # the input parameters, so follows them; then
51 # more data structures and subroutine and package (class) definitions; then
52 # the small actual loop to process the input files and finish up; then
53 # a __DATA__ section, for the .t tests
55 # This program works on all releases of Unicode through at least 6.0. The
56 # outputs have been scrutinized most intently for release 5.1. The others
57 # have been checked for somewhat more than just sanity. It can handle all
58 # existing Unicode character properties in those releases.
60 # This program is mostly about Unicode character (or code point) properties.
61 # A property describes some attribute or quality of a code point, like if it
62 # is lowercase or not, its name, what version of Unicode it was first defined
63 # in, or what its uppercase equivalent is. Unicode deals with these disparate
64 # possibilities by making all properties into mappings from each code point
65 # into some corresponding value. In the case of it being lowercase or not,
66 # the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each
67 # property maps each Unicode code point to a single value, called a "property
68 # value". (Hence each Unicode property is a true mathematical function with
69 # exactly one value per code point.)
71 # When using a property in a regular expression, what is desired isn't the
72 # mapping of the code point to its property's value, but the reverse (or the
73 # mathematical "inverse relation"): starting with the property value, "Does a
74 # code point map to it?" These are written in a "compound" form:
75 # \p{property=value}, e.g., \p{category=punctuation}. This program generates
76 # files containing the lists of code points that map to each such regular
77 # expression property value, one file per list
79 # There is also a single form shortcut that Perl adds for many of the commonly
80 # used properties. This happens for all binary properties, plus script,
81 # general_category, and block properties.
83 # Thus the outputs of this program are files. There are map files, mostly in
84 # the 'To' directory; and there are list files for use in regular expression
85 # matching, all in subdirectories of the 'lib' directory, with each
86 # subdirectory being named for the property that the lists in it are for.
87 # Bookkeeping, test, and documentation files are also generated.
89 my $matches_directory = 'lib'; # Where match (\p{}) files go.
90 my $map_directory = 'To'; # Where map files go.
94 # The major data structures of this program are Property, of course, but also
95 # Table. There are two kinds of tables, very similar to each other.
96 # "Match_Table" is the data structure giving the list of code points that have
97 # a particular property value, mentioned above. There is also a "Map_Table"
98 # data structure which gives the property's mapping from code point to value.
99 # There are two structures because the match tables need to be combined in
100 # various ways, such as constructing unions, intersections, complements, etc.,
101 # and the map ones don't. And there would be problems, perhaps subtle, if
102 # a map table were inadvertently operated on in some of those ways.
103 # The use of separate classes with operations defined on one but not the other
104 # prevents accidentally confusing the two.
106 # At the heart of each table's data structure is a "Range_List", which is just
107 # an ordered list of "Ranges", plus ancillary information, and methods to
108 # operate on them. A Range is a compact way to store property information.
109 # Each range has a starting code point, an ending code point, and a value that
110 # is meant to apply to all the code points between the two end points,
111 # inclusive. For a map table, this value is the property value for those
112 # code points. Two such ranges could be written like this:
113 # 0x41 .. 0x5A, 'Upper',
114 # 0x61 .. 0x7A, 'Lower'
116 # Each range also has a type used as a convenience to classify the values.
117 # Most ranges in this program will be Type 0, or normal, but there are some
118 # ranges that have a non-zero type. These are used only in map tables, and
119 # are for mappings that don't fit into the normal scheme of things. Mappings
120 # that require a hash entry to communicate with utf8.c are one example;
121 # another example is mappings for charnames.pm to use which indicate a name
122 # that is algorithmically determinable from its code point (and vice-versa).
123 # These are used to significantly compact these tables, instead of listing
124 # each one of the tens of thousands individually.
126 # In a match table, the value of a range is irrelevant (and hence the type as
127 # well, which will always be 0), and arbitrarily set to the null string.
128 # Using the example above, there would be two match tables for those two
129 # entries, one named Upper would contain the 0x41..0x5A range, and the other
130 # named Lower would contain 0x61..0x7A.
132 # Actually, there are two types of range lists, "Range_Map" is the one
133 # associated with map tables, and "Range_List" with match tables.
134 # Again, this is so that methods can be defined on one and not the other so as
135 # to prevent operating on them in incorrect ways.
137 # Eventually, most tables are written out to files to be read by utf8_heavy.pl
138 # in the perl core. All tables could in theory be written, but some are
139 # suppressed because there is no current practical use for them. It is easy
140 # to change which get written by changing various lists that are near the top
141 # of the actual code in this file. The table data structures contain enough
142 # ancillary information to allow them to be treated as separate entities for
143 # writing, such as the path to each one's file. There is a heading in each
144 # map table that gives the format of its entries, and what the map is for all
145 # the code points missing from it. (This allows tables to be more compact.)
147 # The Property data structure contains one or more tables. All properties
148 # contain a map table (except the $perl property which is a
149 # pseudo-property containing only match tables), and any properties that
150 # are usable in regular expression matches also contain various matching
151 # tables, one for each value the property can have. A binary property can
152 # have two values, True and False (or Y and N, which are preferred by Unicode
153 # terminology). Thus each of these properties will have a map table that
154 # takes every code point and maps it to Y or N (but having ranges cuts the
155 # number of entries in that table way down), and two match tables, one
156 # which has a list of all the code points that map to Y, and one for all the
157 # code points that map to N. (For each of these, a third table is also
158 # generated for the pseudo Perl property. It contains the identical code
159 # points as the Y table, but can be written, not in the compound form, but in
160 # a "single" form like \p{IsUppercase}.) Many properties are binary, but some
161 # properties have several possible values, some have many, and properties like
162 # Name have a different value for every named code point. Those will not,
163 # unless the controlling lists are changed, have their match tables written
164 # out. But all the ones which can be used in regular expression \p{} and \P{}
165 # constructs will. Generally a property will have either its map table or its
166 # match tables written but not both. Again, what gets written is controlled
167 # by lists which can easily be changed. Properties have a 'Type', like
168 # binary, or string, or enum depending on how many match tables there are and
169 # the content of the maps. This 'Type' is different than a range 'Type', so
170 # don't get confused by the two concepts having the same name.
172 # For information about the Unicode properties, see Unicode's UAX44 document:
174 my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
176 # As stated earlier, this program will work on any release of Unicode so far.
177 # Most obvious problems in earlier data have NOT been corrected except when
178 # necessary to make Perl or this program work reasonably. For example, no
179 # folding information was given in early releases, so this program uses the
180 # substitute of lower case, just so that a regular expression with the /i
181 # option will do something that actually gives the right results in many
182 # cases. There are also a couple other corrections for version 1.1.5,
183 # commented at the point they are made. As an example of corrections that
184 # weren't made (but could be) is this statement from DerivedAge.txt: "The
185 # supplementary private use code points and the non-character code points were
186 # assigned in version 2.0, but not specifically listed in the UCD until
187 # versions 3.0 and 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0)
188 # More information on Unicode version glitches is further down in these
189 # introductory comments.
191 # This program works on all non-provisional properties as of 6.0, though the
192 # files for some are suppressed from apparent lack of demand for them. You
193 # can change which are output by changing lists in this program.
195 # The old version of mktables emphasized the term "Fuzzy" to mean Unicode's
196 # loose matchings rules (from Unicode TR18):
198 # The recommended names for UCD properties and property values are in
199 # PropertyAliases.txt [Prop] and PropertyValueAliases.txt
200 # [PropValue]. There are both abbreviated names and longer, more
201 # descriptive names. It is strongly recommended that both names be
202 # recognized, and that loose matching of property names be used,
203 # whereby the case distinctions, whitespace, hyphens, and underbar
205 # The program still allows Fuzzy to override its determination of if loose
206 # matching should be used, but it isn't currently used, as it is no longer
207 # needed; the calculations it makes are good enough.
209 # SUMMARY OF HOW IT WORKS:
213 # A list is constructed containing each input file that is to be processed
215 # Each file on the list is processed in a loop, using the associated handler
217 # The PropertyAliases.txt and PropValueAliases.txt files are processed
218 # first. These files name the properties and property values.
219 # Objects are created of all the property and property value names
220 # that the rest of the input should expect, including all synonyms.
221 # The other input files give mappings from properties to property
222 # values. That is, they list code points and say what the mapping
223 # is under the given property. Some files give the mappings for
224 # just one property; and some for many. This program goes through
225 # each file and populates the properties from them. Some properties
226 # are listed in more than one file, and Unicode has set up a
227 # precedence as to which has priority if there is a conflict. Thus
228 # the order of processing matters, and this program handles the
229 # conflict possibility by processing the overriding input files
230 # last, so that if necessary they replace earlier values.
231 # After this is all done, the program creates the property mappings not
232 # furnished by Unicode, but derivable from what it does give.
233 # The tables of code points that match each property value in each
234 # property that is accessible by regular expressions are created.
235 # The Perl-defined properties are created and populated. Many of these
236 # require data determined from the earlier steps
237 # Any Perl-defined synonyms are created, and name clashes between Perl
238 # and Unicode are reconciled and warned about.
239 # All the properties are written to files
240 # Any other files are written, and final warnings issued.
242 # For clarity, a number of operators have been overloaded to work on tables:
243 # ~ means invert (take all characters not in the set). The more
244 # conventional '!' is not used because of the possibility of confusing
245 # it with the actual boolean operation.
247 # - means subtraction
248 # & means intersection
249 # The precedence of these is the order listed. Parentheses should be
250 # copiously used. These are not a general scheme. The operations aren't
251 # defined for a number of things, deliberately, to avoid getting into trouble.
252 # Operations are done on references and affect the underlying structures, so
253 # that the copy constructors for them have been overloaded to not return a new
254 # clone, but the input object itself.
256 # The bool operator is deliberately not overloaded to avoid confusion with
257 # "should it mean if the object merely exists, or also is non-empty?".
259 # WHY CERTAIN DESIGN DECISIONS WERE MADE
261 # This program needs to be able to run under miniperl. Therefore, it uses a
262 # minimum of other modules, and hence implements some things itself that could
263 # be gotten from CPAN
265 # This program uses inputs published by the Unicode Consortium. These can
266 # change incompatibly between releases without the Perl maintainers realizing
267 # it. Therefore this program is now designed to try to flag these. It looks
268 # at the directories where the inputs are, and flags any unrecognized files.
269 # It keeps track of all the properties in the files it handles, and flags any
270 # that it doesn't know how to handle. It also flags any input lines that
271 # don't match the expected syntax, among other checks.
273 # It is also designed so if a new input file matches one of the known
274 # templates, one hopefully just needs to add it to a list to have it
277 # As mentioned earlier, some properties are given in more than one file. In
278 # particular, the files in the extracted directory are supposedly just
279 # reformattings of the others. But they contain information not easily
280 # derivable from the other files, including results for Unihan, which this
281 # program doesn't ordinarily look at, and for unassigned code points. They
282 # also have historically had errors or been incomplete. In an attempt to
283 # create the best possible data, this program thus processes them first to
284 # glean information missing from the other files; then processes those other
285 # files to override any errors in the extracted ones. Much of the design was
286 # driven by this need to store things and then possibly override them.
288 # It tries to keep fatal errors to a minimum, to generate something usable for
289 # testing purposes. It always looks for files that could be inputs, and will
290 # warn about any that it doesn't know how to handle (the -q option suppresses
293 # Why have files written out for binary 'N' matches?
294 # For binary properties, if you know the mapping for either Y or N; the
295 # other is trivial to construct, so could be done at Perl run-time by just
296 # complementing the result, instead of having a file for it. That is, if
297 # someone types in \p{foo: N}, Perl could translate that to \P{foo: Y} and
298 # not need a file. The problem is communicating to Perl that a given
299 # property is binary. Perl can't figure it out from looking at the N (or
300 # No), as some non-binary properties have these as property values. So
301 # rather than inventing a way to communicate this info back to the core,
302 # which would have required changes there as well, it was simpler just to
303 # add the extra tables.
305 # Why is there more than one type of range?
306 # This simplified things. There are some very specialized code points that
307 # have to be handled specially for output, such as Hangul syllable names.
308 # By creating a range type (done late in the development process), it
309 # allowed this to be stored with the range, and overridden by other input.
310 # Originally these were stored in another data structure, and it became a
311 # mess trying to decide if a second file that was for the same property was
312 # overriding the earlier one or not.
314 # Why are there two kinds of tables, match and map?
315 # (And there is a base class shared by the two as well.) As stated above,
316 # they actually are for different things. Development proceeded much more
317 # smoothly when I (khw) realized the distinction. Map tables are used to
318 # give the property value for every code point (actually every code point
319 # that doesn't map to a default value). Match tables are used for regular
320 # expression matches, and are essentially the inverse mapping. Separating
321 # the two allows more specialized methods, and error checks so that one
322 # can't just take the intersection of two map tables, for example, as that
325 # There are no match tables generated for matches of the null string. These
326 # would look like qr/\p{JSN=}/ currently without modifying the regex code.
327 # Perhaps something like them could be added if necessary. The JSN does have
328 # a real code point U+110B that maps to the null string, but it is a
329 # contributory property, and therefore not output by default. And it's easily
330 # handled so far by making the null string the default where it is a
335 # This program is written so it will run under miniperl. Occasionally changes
336 # will cause an error where the backtrace doesn't work well under miniperl.
337 # To diagnose the problem, you can instead run it under regular perl, if you
340 # There is a good trace facility. To enable it, first sub DEBUG must be set
341 # to return true. Then a line like
343 # local $to_trace = 1 if main::DEBUG;
345 # can be added to enable tracing in its lexical scope or until you insert
348 # local $to_trace = 0 if main::DEBUG;
350 # then use a line like "trace $a, @b, %c, ...;
352 # Some of the more complex subroutines already have trace statements in them.
353 # Permanent trace statements should be like:
355 # trace ... if main::DEBUG && $to_trace;
357 # If there is just one or a few files that you're debugging, you can easily
358 # cause most everything else to be skipped. Change the line
360 # my $debug_skip = 0;
362 # to 1, and every file whose object is in @input_file_objects and doesn't have
363 # a, 'non_skip => 1,' in its constructor will be skipped.
365 # To compare the output tables, it may be useful to specify the -annotate
366 # flag. This causes the tables to expand so there is one entry for each
367 # non-algorithmically named code point giving, currently its name, and its
368 # graphic representation if printable (and you have a font that knows about
369 # it). This makes it easier to see what the particular code points are in
370 # each output table. The tables are usable, but because they don't have
371 # ranges (for the most part), a Perl using them will run slower. Non-named
372 # code points are annotated with a description of their status, and contiguous
373 # ones with the same description will be output as a range rather than
374 # individually. Algorithmically named characters are also output as ranges,
375 # except when there are just a few contiguous ones.
379 # The program would break if Unicode were to change its names so that
380 # interior white space, underscores, or dashes differences were significant
381 # within property and property value names.
383 # It might be easier to use the xml versions of the UCD if this program ever
384 # would need heavy revision, and the ability to handle old versions was not
387 # There is the potential for name collisions, in that Perl has chosen names
388 # that Unicode could decide it also likes. There have been such collisions in
389 # the past, with mostly Perl deciding to adopt the Unicode definition of the
390 # name. However in the 5.2 Unicode beta testing, there were a number of such
391 # collisions, which were withdrawn before the final release, because of Perl's
392 # and other's protests. These all involved new properties which began with
393 # 'Is'. Based on the protests, Unicode is unlikely to try that again. Also,
394 # many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
395 # Unicode document, so they are unlikely to be used by Unicode for another
396 # purpose. However, they might try something beginning with 'In', or use any
397 # of the other Perl-defined properties. This program will warn you of name
398 # collisions, and refuse to generate tables with them, but manual intervention
399 # will be required in this event. One scheme that could be implemented, if
400 # necessary, would be to have this program generate another file, or add a
401 # field to mktables.lst that gives the date of first definition of a property.
402 # Each new release of Unicode would use that file as a basis for the next
403 # iteration. And the Perl synonym addition code could sort based on the age
404 # of the property, so older properties get priority, and newer ones that clash
405 # would be refused; hence existing code would not be impacted, and some other
406 # synonym would have to be used for the new property. This is ugly, and
407 # manual intervention would certainly be easier to do in the short run; lets
408 # hope it never comes to this.
412 # This program can generate tables from the Unihan database. But it doesn't
413 # by default, letting the CPAN module Unicode::Unihan handle them. Prior to
414 # version 5.2, this database was in a single file, Unihan.txt. In 5.2 the
415 # database was split into 8 different files, all beginning with the letters
416 # 'Unihan'. This program will read those file(s) if present, but it needs to
417 # know which of the many properties in the file(s) should have tables created
418 # for them. It will create tables for any properties listed in
419 # PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
420 # @cjk_properties array and the @cjk_property_values array. Thus, if a
421 # property you want is not in those files of the release you are building
422 # against, you must add it to those two arrays. Starting in 4.0, the
423 # Unicode_Radical_Stroke was listed in those files, so if the Unihan database
424 # is present in the directory, a table will be generated for that property.
425 # In 5.2, several more properties were added. For your convenience, the two
426 # arrays are initialized with all the 6.0 listed properties that are also in
427 # earlier releases. But these are commented out. You can just uncomment the
428 # ones you want, or use them as a template for adding entries for other
431 # You may need to adjust the entries to suit your purposes. setup_unihan(),
432 # and filter_unihan_line() are the functions where this is done. This program
433 # already does some adjusting to make the lines look more like the rest of the
434 # Unicode DB; You can see what that is in filter_unihan_line()
436 # There is a bug in the 3.2 data file in which some values for the
437 # kPrimaryNumeric property have commas and an unexpected comment. A filter
438 # could be added for these; or for a particular installation, the Unihan.txt
439 # file could be edited to fix them.
441 # HOW TO ADD A FILE TO BE PROCESSED
443 # A new file from Unicode needs to have an object constructed for it in
444 # @input_file_objects, probably at the end or at the end of the extracted
445 # ones. The program should warn you if its name will clash with others on
446 # restrictive file systems, like DOS. If so, figure out a better name, and
447 # add lines to the README.perl file giving that. If the file is a character
448 # property, it should be in the format that Unicode has by default
449 # standardized for such files for the more recently introduced ones.
450 # If so, the Input_file constructor for @input_file_objects can just be the
451 # file name and release it first appeared in. If not, then it should be
452 # possible to construct an each_line_handler() to massage the line into the
455 # For non-character properties, more code will be needed. You can look at
456 # the existing entries for clues.
458 # UNICODE VERSIONS NOTES
460 # The Unicode UCD has had a number of errors in it over the versions. And
461 # these remain, by policy, in the standard for that version. Therefore it is
462 # risky to correct them, because code may be expecting the error. So this
463 # program doesn't generally make changes, unless the error breaks the Perl
464 # core. As an example, some versions of 2.1.x Jamo.txt have the wrong value
465 # for U+1105, which causes real problems for the algorithms for Jamo
466 # calculations, so it is changed here.
468 # But it isn't so clear cut as to what to do about concepts that are
469 # introduced in a later release; should they extend back to earlier releases
470 # where the concept just didn't exist? It was easier to do this than to not,
471 # so that's what was done. For example, the default value for code points not
472 # in the files for various properties was probably undefined until changed by
473 # some version. No_Block for blocks is such an example. This program will
474 # assign No_Block even in Unicode versions that didn't have it. This has the
475 # benefit that code being written doesn't have to special case earlier
476 # versions; and the detriment that it doesn't match the Standard precisely for
477 # the affected versions.
479 # Here are some observations about some of the issues in early versions:
481 # The number of code points in \p{alpha} halved in 2.1.9. It turns out that
482 # the reason is that the CJK block starting at 4E00 was removed from PropList,
483 # and was not put back in until 3.1.0
485 # Unicode introduced the synonym Space for White_Space in 4.1. Perl has
486 # always had a \p{Space}. In release 3.2 only, they are not synonymous. The
487 # reason is that 3.2 introduced U+205F=medium math space, which was not
488 # classed as white space, but Perl figured out that it should have been. 4.0
489 # reclassified it correctly.
491 # Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
492 # this was erroneously a synonym for 202. In 4.0, ATB became 202, and ATBL
493 # was left with no code points, as all the ones that mapped to 202 stayed
494 # mapped to 202. Thus if your program used the numeric name for the class,
495 # it would not have been affected, but if it used the mnemonic, it would have
498 # \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that code
499 # points which eventually came to have this script property value, instead
500 # mapped to "Unknown". But in the next release all these code points were
501 # moved to \p{sc=common} instead.
503 # The default for missing code points for BidiClass is complicated. Starting
504 # in 3.1.1, the derived file DBidiClass.txt handles this, but this program
505 # tries to do the best it can for earlier releases. It is done in
506 # process_PropertyAliases()
508 ##############################################################################
510 my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing
512 my $MAX_LINE_WIDTH = 78;
514 # Debugging aid to skip most files so as to not be distracted by them when
515 # concentrating on the ones being debugged. Add
517 # to the constructor for those files you want processed when you set this.
518 # Files with a first version number of 0 are special: they are always
519 # processed regardless of the state of this flag.
522 # Set to 1 to enable tracing.
525 { # Closure for trace: debugging aid
526 my $print_caller = 1; # ? Include calling subroutine name
527 my $main_with_colon = 'main::';
528 my $main_colon_length = length($main_with_colon);
531 return unless $to_trace; # Do nothing if global flag not set
535 local $DB::trace = 0;
536 $DB::trace = 0; # Quiet 'used only once' message
540 # Loop looking up the stack to get the first non-trace caller
545 $line_number = $caller_line;
546 (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
547 $caller = $main_with_colon unless defined $caller;
549 $caller_name = $caller;
552 $caller_name =~ s/.*:://;
553 if (substr($caller_name, 0, $main_colon_length)
556 $caller_name = substr($caller_name, $main_colon_length);
559 } until ($caller_name ne 'trace');
561 # If the stack was empty, we were called from the top level
562 $caller_name = 'main' if ($caller_name eq ""
563 || $caller_name eq 'trace');
566 foreach my $string (@input) {
567 #print STDERR __LINE__, ": ", join ", ", @input, "\n";
568 if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
569 $output .= simple_dumper($string);
572 $string = "$string" if ref $string;
573 $string = $UNDEF unless defined $string;
575 $string = '""' if $string eq "";
576 $output .= " " if $output ne ""
578 && substr($output, -1, 1) ne " "
579 && substr($string, 0, 1) ne " ";
584 print STDERR sprintf "%4d: ", $line_number if defined $line_number;
585 print STDERR "$caller_name: " if $print_caller;
586 print STDERR $output, "\n";
591 # This is for a rarely used development feature that allows you to compare two
592 # versions of the Unicode standard without having to deal with changes caused
593 # by the code points introduced in the later verson. Change the 0 to a SINGLE
594 # dotted Unicode release number (e.g. 2.1). Only code points introduced in
595 # that release and earlier will be used; later ones are thrown away. You use
596 # the version number of the earliest one you want to compare; then run this
597 # program on directory structures containing each release, and compare the
598 # outputs. These outputs will therefore include only the code points common
599 # to both releases, and you can see the changes caused just by the underlying
600 # release semantic changes. For versions earlier than 3.2, you must copy a
601 # version of DAge.txt into the directory.
602 my $string_compare_versions = DEBUG && 0; # e.g., v2.1;
603 my $compare_versions = DEBUG
604 && $string_compare_versions
605 && pack "C*", split /\./, $string_compare_versions;
608 # Returns non-duplicated input values. From "Perl Best Practices:
609 # Encapsulated Cleverness". p. 455 in first edition.
612 # Arguably this breaks encapsulation, if the goal is to permit multiple
613 # distinct objects to stringify to the same value, and be interchangeable.
614 # However, for this program, no two objects stringify identically, and all
615 # lists passed to this function are either objects or strings. So this
616 # doesn't affect correctness, but it does give a couple of percent speedup.
618 return grep { ! $seen{$_}++ } @_;
621 $0 = File::Spec->canonpath($0);
623 my $make_test_script = 0; # ? Should we output a test script
624 my $write_unchanged_files = 0; # ? Should we update the output files even if
625 # we don't think they have changed
626 my $use_directory = ""; # ? Should we chdir somewhere.
627 my $pod_directory; # input directory to store the pod file.
628 my $pod_file = 'perluniprops';
629 my $t_path; # Path to the .t test file
630 my $file_list = 'mktables.lst'; # File to store input and output file names.
631 # This is used to speed up the build, by not
632 # executing the main body of the program if
633 # nothing on the list has changed since the
635 my $make_list = 1; # ? Should we write $file_list. Set to always
636 # make a list so that when the pumpking is
637 # preparing a release, s/he won't have to do
639 my $glob_list = 0; # ? Should we try to include unknown .txt files
641 my $output_range_counts = $debugging_build; # ? Should we include the number
642 # of code points in ranges in
644 my $annotate = 0; # ? Should character names be in the output
646 # Verbosity levels; 0 is quiet
647 my $NORMAL_VERBOSITY = 1;
651 my $verbosity = $NORMAL_VERBOSITY;
655 my $arg = shift @ARGV;
657 $verbosity = $VERBOSE;
659 elsif ($arg eq '-p') {
660 $verbosity = $PROGRESS;
661 $| = 1; # Flush buffers as we go.
663 elsif ($arg eq '-q') {
666 elsif ($arg eq '-w') {
667 $write_unchanged_files = 1; # update the files even if havent changed
669 elsif ($arg eq '-check') {
670 my $this = shift @ARGV;
671 my $ok = shift @ARGV;
673 print "Skipping as check params are not the same.\n";
677 elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
678 -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
680 elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
682 $make_test_script = 1;
684 elsif ($arg eq '-makelist') {
687 elsif ($arg eq '-C' && defined ($use_directory = shift)) {
688 -d $use_directory or croak "Unknown directory '$use_directory'";
690 elsif ($arg eq '-L') {
692 # Existence not tested until have chdir'd
695 elsif ($arg eq '-globlist') {
698 elsif ($arg eq '-c') {
699 $output_range_counts = ! $output_range_counts
701 elsif ($arg eq '-annotate') {
703 $debugging_build = 1;
704 $output_range_counts = 1;
708 $with_c .= 'out' if $output_range_counts; # Complements the state
710 usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
711 [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
713 -c : Output comments $with_c number of code points in ranges
714 -q : Quiet Mode: Only output serious warnings.
715 -p : Set verbosity level to normal plus show progress.
716 -v : Set Verbosity level high: Show progress and non-serious
718 -w : Write files regardless
719 -C dir : Change to this directory before proceeding. All relative paths
720 except those specified by the -P and -T options will be done
721 with respect to this directory.
722 -P dir : Output $pod_file file to directory 'dir'.
723 -T path : Create a test script as 'path'; overrides -maketest
724 -L filelist : Use alternate 'filelist' instead of standard one
725 -globlist : Take as input all non-Test *.txt files in current and sub
727 -maketest : Make test script 'TestProp.pl' in current (or -C directory),
729 -makelist : Rewrite the file list $file_list based on current setup
730 -annotate : Output an annotation for each character in the table files;
731 useful for debugging mktables, looking at diffs; but is slow,
732 memory intensive; resulting tables are usable but slow and
734 -check A B : Executes $0 only if A and B are the same
739 # Stores the most-recently changed file. If none have changed, can skip the
741 my $most_recent = (stat $0)[9]; # Do this before the chdir!
743 # Change directories now, because need to read 'version' early.
744 if ($use_directory) {
745 if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
746 $pod_directory = File::Spec->rel2abs($pod_directory);
748 if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
749 $t_path = File::Spec->rel2abs($t_path);
751 chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
752 if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
753 $pod_directory = File::Spec->abs2rel($pod_directory);
755 if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
756 $t_path = File::Spec->abs2rel($t_path);
760 # Get Unicode version into regular and v-string. This is done now because
761 # various tables below get populated based on it. These tables are populated
762 # here to be near the top of the file, and so easily seeable by those needing
764 open my $VERSION, "<", "version"
765 or croak "$0: can't open required file 'version': $!\n";
766 my $string_version = <$VERSION>;
768 chomp $string_version;
769 my $v_version = pack "C*", split /\./, $string_version; # v string
771 # The following are the complete names of properties with property values that
772 # are known to not match any code points in some versions of Unicode, but that
773 # may change in the future so they should be matchable, hence an empty file is
774 # generated for them.
775 my @tables_that_may_be_empty = (
776 'Joining_Type=Left_Joining',
778 push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
779 push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
780 push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
781 if $v_version ge v4.1.0;
783 # The lists below are hashes, so the key is the item in the list, and the
784 # value is the reason why it is in the list. This makes generation of
785 # documentation easier.
787 my %why_suppressed; # No file generated for these.
789 # Files aren't generated for empty extraneous properties. This is arguable.
790 # Extraneous properties generally come about because a property is no longer
791 # used in a newer version of Unicode. If we generated a file without code
792 # points, programs that used to work on that property will still execute
793 # without errors. It just won't ever match (or will always match, with \P{}).
794 # This means that the logic is now likely wrong. I (khw) think its better to
795 # find this out by getting an error message. Just move them to the table
796 # above to change this behavior
797 my %why_suppress_if_empty_warn_if_not = (
799 # It is the only property that has ever officially been removed from the
800 # Standard. The database never contained any code points for it.
801 'Special_Case_Condition' => 'Obsolete',
803 # Apparently never official, but there were code points in some versions of
804 # old-style PropList.txt
805 'Non_Break' => 'Obsolete',
808 # These would normally go in the warn table just above, but they were changed
809 # a long time before this program was written, so warnings about them are
811 if ($v_version gt v3.2.0) {
812 push @tables_that_may_be_empty,
813 'Canonical_Combining_Class=Attached_Below_Left'
816 # These are listed in the Property aliases file in 6.0, but Unihan is ignored
817 # unless explicitly added.
818 if ($v_version ge v5.2.0) {
819 my $unihan = 'Unihan; remove from list if using Unihan';
820 foreach my $table (qw (
824 kCompatibilityVariant
838 $why_suppress_if_empty_warn_if_not{$table} = $unihan;
842 # Properties that this program ignores.
843 my @unimplemented_properties = (
844 'Unicode_Radical_Stroke' # Remove if changing to handle this one.
847 # There are several types of obsolete properties defined by Unicode. These
848 # must be hand-edited for every new Unicode release.
849 my %why_deprecated; # Generates a deprecated warning message if used.
850 my %why_stabilized; # Documentation only
851 my %why_obsolete; # Documentation only
854 my $simple = 'Perl uses the more complete version of this property';
855 my $unihan = 'Unihan properties are by default not enabled in the Perl core. Instead use CPAN: Unicode::Unihan';
857 my $other_properties = 'other properties';
858 my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
859 my $why_no_expand = "Deprecated by Unicode: less useful than UTF-specific calculations",
862 'Grapheme_Link' => 'Deprecated by Unicode: Duplicates ccc=vr (Canonical_Combining_Class=Virama)',
863 'Jamo_Short_Name' => $contributory,
864 'Line_Break=Surrogate' => 'Deprecated by Unicode because surrogates should never appear in well-formed text, and therefore shouldn\'t be the basis for line breaking',
865 'Other_Alphabetic' => $contributory,
866 'Other_Default_Ignorable_Code_Point' => $contributory,
867 'Other_Grapheme_Extend' => $contributory,
868 'Other_ID_Continue' => $contributory,
869 'Other_ID_Start' => $contributory,
870 'Other_Lowercase' => $contributory,
871 'Other_Math' => $contributory,
872 'Other_Uppercase' => $contributory,
876 # There is a lib/unicore/Decomposition.pl (used by Normalize.pm) which
877 # contains the same information, but without the algorithmically
878 # determinable Hangul syllables'. This file is not published, so it's
879 # existence is not noted in the comment.
880 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',
882 'ISO_Comment' => 'Apparently no demand for it, but can access it through Unicode::UCD::charinfo. Obsoleted, and code points for it removed in Unicode 5.2',
883 'Unicode_1_Name' => "$simple, and no apparent demand for it, but can access it through Unicode::UCD::charinfo. If there is no later name for a code point, then this one is used instead in charnames",
885 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold",
886 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
887 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
888 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
890 'Name' => "Accessible via 'use charnames;'",
891 'Name_Alias' => "Accessible via 'use charnames;'",
893 FC_NFKC_Closure => 'Supplanted in usage by NFKC_Casefold; otherwise not useful',
894 Expands_On_NFC => $why_no_expand,
895 Expands_On_NFD => $why_no_expand,
896 Expands_On_NFKC => $why_no_expand,
897 Expands_On_NFKD => $why_no_expand,
900 # The following are suppressed because they were made contributory or
901 # deprecated by Unicode before Perl ever thought about supporting them.
902 foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') {
903 $why_suppressed{$property} = $why_deprecated{$property};
906 # Customize the message for all the 'Other_' properties
907 foreach my $property (keys %why_deprecated) {
908 next if (my $main_property = $property) !~ s/^Other_//;
909 $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
913 if ($v_version ge 4.0.0) {
914 $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
915 if ($v_version ge 6.0.0) {
916 $why_deprecated{'Hyphen'} = 'Supplanted by Line_Break property values; see www.unicode.org/reports/tr14';
919 if ($v_version ge 5.2.0 && $v_version lt 6.0.0) {
920 $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
921 if ($v_version ge 6.0.0) {
922 $why_deprecated{'ISO_Comment'} = 'No longer needed for chart generation; otherwise not useful, and code points for it have been removed';
926 # Probably obsolete forever
927 if ($v_version ge v4.1.0) {
928 $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common"';
931 # This program can create files for enumerated-like properties, such as
932 # 'Numeric_Type'. This file would be the same format as for a string
933 # property, with a mapping from code point to its value, so you could look up,
934 # for example, the script a code point is in. But no one so far wants this
935 # mapping, or they have found another way to get it since this is a new
936 # feature. So no file is generated except if it is in this list.
937 my @output_mapped_properties = split "\n", <<END;
940 # If you are using the Unihan database, you need to add the properties that
941 # you want to extract from it to this table. For your convenience, the
942 # properties in the 6.0 PropertyAliases.txt file are listed, commented out
943 my @cjk_properties = split "\n", <<'END';
944 #cjkAccountingNumeric; kAccountingNumeric
945 #cjkOtherNumeric; kOtherNumeric
946 #cjkPrimaryNumeric; kPrimaryNumeric
947 #cjkCompatibilityVariant; kCompatibilityVariant
949 #cjkIRG_GSource; kIRG_GSource
950 #cjkIRG_HSource; kIRG_HSource
951 #cjkIRG_JSource; kIRG_JSource
952 #cjkIRG_KPSource; kIRG_KPSource
953 #cjkIRG_KSource; kIRG_KSource
954 #cjkIRG_TSource; kIRG_TSource
955 #cjkIRG_USource; kIRG_USource
956 #cjkIRG_VSource; kIRG_VSource
957 #cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS
960 # Similarly for the property values. For your convenience, the lines in the
961 # 6.0 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
963 my @cjk_property_values = split "\n", <<'END';
964 ## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
965 ## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
966 ## @missing: 0000..10FFFF; cjkIICore; <none>
967 ## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
968 ## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
969 ## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
970 ## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
971 ## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
972 ## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
973 ## @missing: 0000..10FFFF; cjkIRG_USource; <none>
974 ## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
975 ## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
976 ## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
977 ## @missing: 0000..10FFFF; cjkRSUnicode; <none>
980 # The input files don't list every code point. Those not listed are to be
981 # defaulted to some value. Below are hard-coded what those values are for
982 # non-binary properties as of 5.1. Starting in 5.0, there are
983 # machine-parsable comment lines in the files the give the defaults; so this
984 # list shouldn't have to be extended. The claim is that all missing entries
985 # for binary properties will default to 'N'. Unicode tried to change that in
986 # 5.2, but the beta period produced enough protest that they backed off.
988 # The defaults for the fields that appear in UnicodeData.txt in this hash must
989 # be in the form that it expects. The others may be synonyms.
990 my $CODE_POINT = '<code point>';
991 my %default_mapping = (
993 # Bidi_Class => Complicated; set in code
994 Bidi_Mirroring_Glyph => "",
996 Canonical_Combining_Class => 0,
997 Case_Folding => $CODE_POINT,
998 Decomposition_Mapping => $CODE_POINT,
999 Decomposition_Type => 'None',
1000 East_Asian_Width => "Neutral",
1001 FC_NFKC_Closure => $CODE_POINT,
1002 General_Category => 'Cn',
1003 Grapheme_Cluster_Break => 'Other',
1004 Hangul_Syllable_Type => 'NA',
1006 Jamo_Short_Name => "",
1007 Joining_Group => "No_Joining_Group",
1008 # Joining_Type => Complicated; set in code
1009 kIICore => 'N', # Is converted to binary
1010 #Line_Break => Complicated; set in code
1011 Lowercase_Mapping => $CODE_POINT,
1018 Numeric_Type => 'None',
1019 Numeric_Value => 'NaN',
1020 Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
1021 Sentence_Break => 'Other',
1022 Simple_Case_Folding => $CODE_POINT,
1023 Simple_Lowercase_Mapping => $CODE_POINT,
1024 Simple_Titlecase_Mapping => $CODE_POINT,
1025 Simple_Uppercase_Mapping => $CODE_POINT,
1026 Titlecase_Mapping => $CODE_POINT,
1027 Unicode_1_Name => "",
1028 Unicode_Radical_Stroke => "",
1029 Uppercase_Mapping => $CODE_POINT,
1030 Word_Break => 'Other',
1033 # Below are files that Unicode furnishes, but this program ignores, and why
1034 my %ignored_files = (
1035 'CJKRadicals.txt' => 'Unihan data',
1036 'Index.txt' => 'An index, not actual data',
1037 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
1038 'NamesList.txt' => 'Just adds commentary',
1039 'NormalizationCorrections.txt' => 'Data is already in other files.',
1040 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
1041 'ReadMe.txt' => 'Just comments',
1042 'README.TXT' => 'Just comments',
1043 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
1044 'EmojiSources.txt' => 'Not of general utility: for Japanese legacy cell-phone applications',
1045 'IndicMatraCategory.txt' => 'Provisional',
1046 'IndicSyllabicCategory.txt' => 'Provisional',
1047 'ScriptExtensions.txt' => 'Provisional',
1050 ### End of externally interesting definitions, except for @input_file_objects
1053 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
1054 # This file is machine-generated by $0 from the Unicode
1055 # database, Version $string_version. Any changes made here will be lost!
1058 my $INTERNAL_ONLY=<<"EOF";
1060 # !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
1061 # This file is for internal use by the Perl program only. The format and even
1062 # the name or existence of this file are subject to change without notice.
1063 # Don't use it directly.
1066 my $DEVELOPMENT_ONLY=<<"EOF";
1067 # !!!!!!! DEVELOPMENT USE ONLY !!!!!!!
1068 # This file contains information artificially constrained to code points
1069 # present in Unicode release $string_compare_versions.
1070 # IT CANNOT BE RELIED ON. It is for use during development only and should
1071 # not be used for production.
1075 my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF";
1076 my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING;
1077 my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1;
1079 # Matches legal code point. 4-6 hex numbers, If there are 6, the first
1080 # two must be 10; if there are 5, the first must not be a 0. Written this way
1081 # to decrease backtracking
1083 qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
1085 # This matches the beginning of the line in the Unicode db files that give the
1086 # defaults for code points not listed (i.e., missing) in the file. The code
1087 # depends on this ending with a semi-colon, so it can assume it is a valid
1088 # field when the line is split() by semi-colons
1089 my $missing_defaults_prefix =
1090 qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/;
1092 # Property types. Unicode has more types, but these are sufficient for our
1094 my $UNKNOWN = -1; # initialized to illegal value
1095 my $NON_STRING = 1; # Either binary or enum
1097 my $ENUM = 3; # Include catalog
1098 my $STRING = 4; # Anything else: string or misc
1100 # Some input files have lines that give default values for code points not
1101 # contained in the file. Sometimes these should be ignored.
1102 my $NO_DEFAULTS = 0; # Must evaluate to false
1103 my $NOT_IGNORED = 1;
1106 # Range types. Each range has a type. Most ranges are type 0, for normal,
1107 # and will appear in the main body of the tables in the output files, but
1108 # there are other types of ranges as well, listed below, that are specially
1109 # handled. There are pseudo-types as well that will never be stored as a
1110 # type, but will affect the calculation of the type.
1112 # 0 is for normal, non-specials
1113 my $MULTI_CP = 1; # Sequence of more than code point
1114 my $HANGUL_SYLLABLE = 2;
1115 my $CP_IN_NAME = 3; # The NAME contains the code point appended to it.
1116 my $NULL = 4; # The map is to the null string; utf8.c can't
1117 # handle these, nor is there an accepted syntax
1118 # for them in \p{} constructs
1119 my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
1120 # otherwise be $MULTI_CP type are instead type 0
1122 # process_generic_property_file() can accept certain overrides in its input.
1123 # Each of these must begin AND end with $CMD_DELIM.
1124 my $CMD_DELIM = "\a";
1125 my $REPLACE_CMD = 'replace'; # Override the Replace
1126 my $MAP_TYPE_CMD = 'map_type'; # Override the Type
1131 # Values for the Replace argument to add_range.
1132 # $NO # Don't replace; add only the code points not
1134 my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
1135 # the comments at the subroutine definition.
1136 my $UNCONDITIONALLY = 2; # Replace without conditions.
1137 my $MULTIPLE = 4; # Don't replace, but add a duplicate record if
1139 my $CROAK = 5; # Die with an error if is already there
1141 # Flags to give property statuses. The phrases are to remind maintainers that
1142 # if the flag is changed, the indefinite article referring to it in the
1143 # documentation may need to be as well.
1145 my $SUPPRESSED = 'z'; # The character should never actually be seen, since
1147 my $PLACEHOLDER = 'P'; # Implies no pod entry generated
1148 my $DEPRECATED = 'D';
1149 my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
1150 my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
1151 my $DISCOURAGED = 'X';
1152 my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
1153 my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
1155 my $a_bold_stricter = "a 'B<$STRICTER>'";
1156 my $A_bold_stricter = "A 'B<$STRICTER>'";
1157 my $STABILIZED = 'S';
1158 my $a_bold_stabilized = "an 'B<$STABILIZED>'";
1159 my $A_bold_stabilized = "An 'B<$STABILIZED>'";
1161 my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
1162 my $A_bold_obsolete = "An 'B<$OBSOLETE>'";
1164 my %status_past_participles = (
1165 $DISCOURAGED => 'discouraged',
1166 $SUPPRESSED => 'should never be generated',
1167 $STABILIZED => 'stabilized',
1168 $OBSOLETE => 'obsolete',
1169 $DEPRECATED => 'deprecated',
1172 # The format of the values of the tables:
1173 my $EMPTY_FORMAT = "";
1174 my $BINARY_FORMAT = 'b';
1175 my $DECIMAL_FORMAT = 'd';
1176 my $FLOAT_FORMAT = 'f';
1177 my $INTEGER_FORMAT = 'i';
1178 my $HEX_FORMAT = 'x';
1179 my $RATIONAL_FORMAT = 'r';
1180 my $STRING_FORMAT = 's';
1181 my $DECOMP_STRING_FORMAT = 'c';
1183 my %map_table_formats = (
1184 $BINARY_FORMAT => 'binary',
1185 $DECIMAL_FORMAT => 'single decimal digit',
1186 $FLOAT_FORMAT => 'floating point number',
1187 $INTEGER_FORMAT => 'integer',
1188 $HEX_FORMAT => 'positive hex whole number; a code point',
1189 $RATIONAL_FORMAT => 'rational: an integer or a fraction',
1190 $STRING_FORMAT => 'string',
1191 $DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
1194 # Unicode didn't put such derived files in a separate directory at first.
1195 my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
1196 my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
1197 my $AUXILIARY = 'auxiliary';
1199 # Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
1200 my %loose_to_file_of; # loosely maps table names to their respective
1202 my %stricter_to_file_of; # same; but for stricter mapping.
1203 my %nv_floating_to_rational; # maps numeric values floating point numbers to
1204 # their rational equivalent
1205 my %loose_property_name_of; # Loosely maps property names to standard form
1207 # Most properties are immune to caseless matching, otherwise you would get
1208 # nonsensical results, as properties are a function of a code point, not
1209 # everything that is caselessly equivalent to that code point. For example,
1210 # Changes_When_Case_Folded('s') should be false, whereas caselessly it would
1211 # be true because 's' and 'S' are equivalent caselessly. However,
1212 # traditionally, [:upper:] and [:lower:] are equivalent caselessly, so we
1213 # extend that concept to those very few properties that are like this. Each
1214 # such property will match the full range caselessly. They are hard-coded in
1215 # the program; it's not worth trying to make it general as it's extremely
1216 # unlikely that they will ever change.
1217 my %caseless_equivalent_to;
1219 # These constants names and values were taken from the Unicode standard,
1220 # version 5.1, section 3.12. They are used in conjunction with Hangul
1221 # syllables. The '_string' versions are so generated tables can retain the
1222 # hex format, which is the more familiar value
1223 my $SBase_string = "0xAC00";
1224 my $SBase = CORE::hex $SBase_string;
1225 my $LBase_string = "0x1100";
1226 my $LBase = CORE::hex $LBase_string;
1227 my $VBase_string = "0x1161";
1228 my $VBase = CORE::hex $VBase_string;
1229 my $TBase_string = "0x11A7";
1230 my $TBase = CORE::hex $TBase_string;
1235 my $NCount = $VCount * $TCount;
1237 # For Hangul syllables; These store the numbers from Jamo.txt in conjunction
1238 # with the above published constants.
1240 my %Jamo_L; # Leading consonants
1241 my %Jamo_V; # Vowels
1242 my %Jamo_T; # Trailing consonants
1244 my @backslash_X_tests; # List of tests read in for testing \X
1245 my @unhandled_properties; # Will contain a list of properties found in
1246 # the input that we didn't process.
1247 my @match_properties; # Properties that have match tables, to be
1249 my @map_properties; # Properties that get map files written
1250 my @named_sequences; # NamedSequences.txt contents.
1251 my %potential_files; # Generated list of all .txt files in the directory
1252 # structure so we can warn if something is being
1254 my @files_actually_output; # List of files we generated.
1255 my @more_Names; # Some code point names are compound; this is used
1256 # to store the extra components of them.
1257 my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
1258 # the minimum before we consider it equivalent to a
1259 # candidate rational
1260 my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
1262 # These store references to certain commonly used property objects
1269 # Are there conflicting names because of beginning with 'In_', or 'Is_'
1270 my $has_In_conflicts = 0;
1271 my $has_Is_conflicts = 0;
1273 sub internal_file_to_platform ($) {
1274 # Convert our file paths which have '/' separators to those of the
1278 return undef unless defined $file;
1280 return File::Spec->join(split '/', $file);
1283 sub file_exists ($) { # platform independent '-e'. This program internally
1284 # uses slash as a path separator.
1286 return 0 if ! defined $file;
1287 return -e internal_file_to_platform($file);
1291 # Returns the address of the blessed input object.
1292 # It doesn't check for blessedness because that would do a string eval
1293 # every call, and the program is structured so that this is never called
1294 # for a non-blessed object.
1296 no overloading; # If overloaded, numifying below won't work.
1298 # Numifying a ref gives its address.
1299 return pack 'J', $_[0];
1302 # These are used only if $annotate is true.
1303 # The entire range of Unicode characters is examined to populate these
1304 # after all the input has been processed. But most can be skipped, as they
1305 # have the same descriptive phrases, such as being unassigned
1306 my @viacode; # Contains the 1 million character names
1307 my @printable; # boolean: And are those characters printable?
1308 my @annotate_char_type; # Contains a type of those characters, specifically
1309 # for the purposes of annotation.
1310 my $annotate_ranges; # A map of ranges of code points that have the same
1311 # name for the purposes of annotation. They map to the
1312 # upper edge of the range, so that the end point can
1313 # be immediately found. This is used to skip ahead to
1314 # the end of a range, and avoid processing each
1315 # individual code point in it.
1316 my $unassigned_sans_noncharacters; # A Range_List of the unassigned
1317 # characters, but excluding those which are
1318 # also noncharacter code points
1320 # The annotation types are an extension of the regular range types, though
1321 # some of the latter are folded into one. Make the new types negative to
1322 # avoid conflicting with the regular types
1323 my $SURROGATE_TYPE = -1;
1324 my $UNASSIGNED_TYPE = -2;
1325 my $PRIVATE_USE_TYPE = -3;
1326 my $NONCHARACTER_TYPE = -4;
1327 my $CONTROL_TYPE = -5;
1328 my $UNKNOWN_TYPE = -6; # Used only if there is a bug in this program
1330 sub populate_char_info ($) {
1331 # Used only with the $annotate option. Populates the arrays with the
1332 # input code point's info that are needed for outputting more detailed
1333 # comments. If calling context wants a return, it is the end point of
1334 # any contiguous range of characters that share essentially the same info
1337 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1339 $viacode[$i] = $perl_charname->value_of($i) || "";
1341 # A character is generally printable if Unicode says it is,
1342 # but below we make sure that most Unicode general category 'C' types
1344 $printable[$i] = $print->contains($i);
1346 $annotate_char_type[$i] = $perl_charname->type_of($i) || 0;
1348 # Only these two regular types are treated specially for annotations
1350 $annotate_char_type[$i] = 0 if $annotate_char_type[$i] != $CP_IN_NAME
1351 && $annotate_char_type[$i] != $HANGUL_SYLLABLE;
1353 # Give a generic name to all code points that don't have a real name.
1354 # We output ranges, if applicable, for these. Also calculate the end
1355 # point of the range.
1357 if (! $viacode[$i]) {
1358 if ($gc-> table('Surrogate')->contains($i)) {
1359 $viacode[$i] = 'Surrogate';
1360 $annotate_char_type[$i] = $SURROGATE_TYPE;
1362 $end = $gc->table('Surrogate')->containing_range($i)->end;
1364 elsif ($gc-> table('Private_use')->contains($i)) {
1365 $viacode[$i] = 'Private Use';
1366 $annotate_char_type[$i] = $PRIVATE_USE_TYPE;
1368 $end = $gc->table('Private_Use')->containing_range($i)->end;
1370 elsif (Property::property_ref('Noncharacter_Code_Point')-> table('Y')->
1373 $viacode[$i] = 'Noncharacter';
1374 $annotate_char_type[$i] = $NONCHARACTER_TYPE;
1376 $end = property_ref('Noncharacter_Code_Point')->table('Y')->
1377 containing_range($i)->end;
1379 elsif ($gc-> table('Control')->contains($i)) {
1380 $viacode[$i] = 'Control';
1381 $annotate_char_type[$i] = $CONTROL_TYPE;
1383 $end = 0x81 if $i == 0x80; # Hard-code this one known case
1385 elsif ($gc-> table('Unassigned')->contains($i)) {
1386 $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
1387 $annotate_char_type[$i] = $UNASSIGNED_TYPE;
1390 # Because we name the unassigned by the blocks they are in, it
1391 # can't go past the end of that block, and it also can't go past
1392 # the unassigned range it is in. The special table makes sure
1393 # that the non-characters, which are unassigned, are separated
1395 $end = min($block->containing_range($i)->end,
1396 $unassigned_sans_noncharacters-> containing_range($i)->
1400 Carp::my_carp_bug("Can't figure out how to annotate "
1401 . sprintf("U+%04X", $i)
1402 . ". Proceeding anyway.");
1403 $viacode[$i] = 'UNKNOWN';
1404 $annotate_char_type[$i] = $UNKNOWN_TYPE;
1409 # Here, has a name, but if it's one in which the code point number is
1410 # appended to the name, do that.
1411 elsif ($annotate_char_type[$i] == $CP_IN_NAME) {
1412 $viacode[$i] .= sprintf("-%04X", $i);
1413 $end = $perl_charname->containing_range($i)->end;
1416 # And here, has a name, but if it's a hangul syllable one, replace it with
1417 # the correct name from the Unicode algorithm
1418 elsif ($annotate_char_type[$i] == $HANGUL_SYLLABLE) {
1420 my $SIndex = $i - $SBase;
1421 my $L = $LBase + $SIndex / $NCount;
1422 my $V = $VBase + ($SIndex % $NCount) / $TCount;
1423 my $T = $TBase + $SIndex % $TCount;
1424 $viacode[$i] = "HANGUL SYLLABLE $Jamo{$L}$Jamo{$V}";
1425 $viacode[$i] .= $Jamo{$T} if $T != $TBase;
1426 $end = $perl_charname->containing_range($i)->end;
1429 return if ! defined wantarray;
1430 return $i if ! defined $end; # If not a range, return the input
1432 # Save this whole range so can find the end point quickly
1433 $annotate_ranges->add_map($i, $end, $end);
1438 # Commented code below should work on Perl 5.8.
1439 ## This 'require' doesn't necessarily work in miniperl, and even if it does,
1440 ## the native perl version of it (which is what would operate under miniperl)
1441 ## is extremely slow, as it does a string eval every call.
1442 #my $has_fast_scalar_util = $
\18 !~ /miniperl/
1443 # && defined eval "require Scalar::Util";
1446 # # Returns the address of the blessed input object. Uses the XS version if
1447 # # available. It doesn't check for blessedness because that would do a
1448 # # string eval every call, and the program is structured so that this is
1449 # # never called for a non-blessed object.
1451 # return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
1453 # # Check at least that is a ref.
1454 # my $pkg = ref($_[0]) or return undef;
1456 # # Change to a fake package to defeat any overloaded stringify
1457 # bless $_[0], 'main::Fake';
1459 # # Numifying a ref gives its address.
1460 # my $addr = pack 'J', $_[0];
1462 # # Return to original class
1463 # bless $_[0], $pkg;
1470 return $a if $a >= $b;
1477 return $a if $a <= $b;
1481 sub clarify_number ($) {
1482 # This returns the input number with underscores inserted every 3 digits
1483 # in large (5 digits or more) numbers. Input must be entirely digits, not
1487 my $pos = length($number) - 3;
1488 return $number if $pos <= 1;
1490 substr($number, $pos, 0) = '_';
1499 # These routines give a uniform treatment of messages in this program. They
1500 # are placed in the Carp package to cause the stack trace to not include them,
1501 # although an alternative would be to use another package and set @CARP_NOT
1504 our $Verbose = 1 if main::DEBUG; # Useful info when debugging
1506 # This is a work-around suggested by Nicholas Clark to fix a problem with Carp
1507 # and overload trying to load Scalar:Util under miniperl. See
1508 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
1509 undef $overload::VERSION;
1512 my $message = shift || "";
1513 my $nofold = shift || 0;
1516 $message = main::join_lines($message);
1517 $message =~ s/^$0: *//; # Remove initial program name
1518 $message =~ s/[.;,]+$//; # Remove certain ending punctuation
1519 $message = "\n$0: $message;";
1521 # Fold the message with program name, semi-colon end punctuation
1522 # (which looks good with the message that carp appends to it), and a
1523 # hanging indent for continuation lines.
1524 $message = main::simple_fold($message, "", 4) unless $nofold;
1525 $message =~ s/\n$//; # Remove the trailing nl so what carp
1526 # appends is to the same line
1529 return $message if defined wantarray; # If a caller just wants the msg
1536 # This is called when it is clear that the problem is caused by a bug in
1539 my $message = shift;
1540 $message =~ s/^$0: *//;
1541 $message = my_carp("Bug in $0. Please report it by running perlbug or if that is unavailable, by sending email to perbug\@perl.org:\n$message");
1546 sub carp_too_few_args {
1548 my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'. No action taken.");
1552 my $args_ref = shift;
1555 my_carp_bug("Need at least $count arguments to "
1557 . ". Instead got: '"
1558 . join ', ', @$args_ref
1559 . "'. No action taken.");
1563 sub carp_extra_args {
1564 my $args_ref = shift;
1565 my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . "); Extras ignored.") if @_;
1567 unless (ref $args_ref) {
1568 my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref. Not checking arguments.");
1571 my ($package, $file, $line) = caller;
1572 my $subroutine = (caller 1)[3];
1575 if (ref $args_ref eq 'HASH') {
1576 foreach my $key (keys %$args_ref) {
1577 $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
1579 $list = join ', ', each %{$args_ref};
1581 elsif (ref $args_ref eq 'ARRAY') {
1582 foreach my $arg (@$args_ref) {
1583 $arg = $UNDEF unless defined $arg;
1585 $list = join ', ', @$args_ref;
1588 my_carp_bug("Can't cope with ref "
1590 . " . argument to 'carp_extra_args'. Not checking arguments.");
1594 my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine. Skipped.");
1602 # This program uses the inside-out method for objects, as recommended in
1603 # "Perl Best Practices". This closure aids in generating those. There
1604 # are two routines. setup_package() is called once per package to set
1605 # things up, and then set_access() is called for each hash representing a
1606 # field in the object. These routines arrange for the object to be
1607 # properly destroyed when no longer used, and for standard accessor
1608 # functions to be generated. If you need more complex accessors, just
1609 # write your own and leave those accesses out of the call to set_access().
1610 # More details below.
1612 my %constructor_fields; # fields that are to be used in constructors; see
1615 # The values of this hash will be the package names as keys to other
1616 # hashes containing the name of each field in the package as keys, and
1617 # references to their respective hashes as values.
1621 # Sets up the package, creating standard DESTROY and dump methods
1622 # (unless already defined). The dump method is used in debugging by
1624 # The optional parameters are:
1625 # a) a reference to a hash, that gets populated by later
1626 # set_access() calls with one of the accesses being
1627 # 'constructor'. The caller can then refer to this, but it is
1628 # not otherwise used by these two routines.
1629 # b) a reference to a callback routine to call during destruction
1630 # of the object, before any fields are actually destroyed
1633 my $constructor_ref = delete $args{'Constructor_Fields'};
1634 my $destroy_callback = delete $args{'Destroy_Callback'};
1635 Carp::carp_extra_args(\@_) if main::DEBUG && %args;
1638 my $package = (caller)[0];
1640 $package_fields{$package} = \%fields;
1641 $constructor_fields{$package} = $constructor_ref;
1643 unless ($package->can('DESTROY')) {
1644 my $destroy_name = "${package}::DESTROY";
1647 # Use typeglob to give the anonymous subroutine the name we want
1648 *$destroy_name = sub {
1650 my $addr = do { no overloading; pack 'J', $self; };
1652 $self->$destroy_callback if $destroy_callback;
1653 foreach my $field (keys %{$package_fields{$package}}) {
1654 #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
1655 delete $package_fields{$package}{$field}{$addr};
1661 unless ($package->can('dump')) {
1662 my $dump_name = "${package}::dump";
1666 return dump_inside_out($self, $package_fields{$package}, @_);
1673 # Arrange for the input field to be garbage collected when no longer
1674 # needed. Also, creates standard accessor functions for the field
1675 # based on the optional parameters-- none if none of these parameters:
1676 # 'addable' creates an 'add_NAME()' accessor function.
1677 # 'readable' or 'readable_array' creates a 'NAME()' accessor
1679 # 'settable' creates a 'set_NAME()' accessor function.
1680 # 'constructor' doesn't create an accessor function, but adds the
1681 # field to the hash that was previously passed to
1683 # Any of the accesses can be abbreviated down, so that 'a', 'ad',
1684 # 'add' etc. all mean 'addable'.
1685 # The read accessor function will work on both array and scalar
1686 # values. If another accessor in the parameter list is 'a', the read
1687 # access assumes an array. You can also force it to be array access
1688 # by specifying 'readable_array' instead of 'readable'
1690 # A sort-of 'protected' access can be set-up by preceding the addable,
1691 # readable or settable with some initial portion of 'protected_' (but,
1692 # the underscore is required), like 'p_a', 'pro_set', etc. The
1693 # "protection" is only by convention. All that happens is that the
1694 # accessor functions' names begin with an underscore. So instead of
1695 # calling set_foo, the call is _set_foo. (Real protection could be
1696 # accomplished by having a new subroutine, end_package, called at the
1697 # end of each package, and then storing the __LINE__ ranges and
1698 # checking them on every accessor. But that is way overkill.)
1700 # We create anonymous subroutines as the accessors and then use
1701 # typeglobs to assign them to the proper package and name
1703 my $name = shift; # Name of the field
1704 my $field = shift; # Reference to the inside-out hash containing the
1707 my $package = (caller)[0];
1709 if (! exists $package_fields{$package}) {
1710 croak "$0: Must call 'setup_package' before 'set_access'";
1713 # Stash the field so DESTROY can get it.
1714 $package_fields{$package}{$name} = $field;
1716 # Remaining arguments are the accessors. For each...
1717 foreach my $access (@_) {
1718 my $access = lc $access;
1722 # Match the input as far as it goes.
1723 if ($access =~ /^(p[^_]*)_/) {
1725 if (substr('protected_', 0, length $protected)
1729 # Add 1 for the underscore not included in $protected
1730 $access = substr($access, length($protected) + 1);
1738 if (substr('addable', 0, length $access) eq $access) {
1739 my $subname = "${package}::${protected}add_$name";
1742 # add_ accessor. Don't add if already there, which we
1743 # determine using 'eq' for scalars and '==' otherwise.
1746 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1749 my $addr = do { no overloading; pack 'J', $self; };
1750 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1752 return if grep { $value == $_ } @{$field->{$addr}};
1755 return if grep { $value eq $_ } @{$field->{$addr}};
1757 push @{$field->{$addr}}, $value;
1761 elsif (substr('constructor', 0, length $access) eq $access) {
1763 Carp::my_carp_bug("Can't set-up 'protected' constructors")
1766 $constructor_fields{$package}{$name} = $field;
1769 elsif (substr('readable_array', 0, length $access) eq $access) {
1771 # Here has read access. If one of the other parameters for
1772 # access is array, or this one specifies array (by being more
1773 # than just 'readable_'), then create a subroutine that
1774 # assumes the data is an array. Otherwise just a scalar
1775 my $subname = "${package}::${protected}$name";
1776 if (grep { /^a/i } @_
1777 or length($access) > length('readable_'))
1782 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1783 my $addr = do { no overloading; pack 'J', $_[0]; };
1784 if (ref $field->{$addr} ne 'ARRAY') {
1785 my $type = ref $field->{$addr};
1786 $type = 'scalar' unless $type;
1787 Carp::my_carp_bug("Trying to read $name as an array when it is a $type. Big problems.");
1790 return scalar @{$field->{$addr}} unless wantarray;
1792 # Make a copy; had problems with caller modifying the
1793 # original otherwise
1794 my @return = @{$field->{$addr}};
1800 # Here not an array value, a simpler function.
1804 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1806 return $field->{pack 'J', $_[0]};
1810 elsif (substr('settable', 0, length $access) eq $access) {
1811 my $subname = "${package}::${protected}set_$name";
1816 return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
1817 Carp::carp_extra_args(\@_) if @_ > 2;
1819 # $self is $_[0]; $value is $_[1]
1821 $field->{pack 'J', $_[0]} = $_[1];
1826 Carp::my_carp_bug("Unknown accessor type $access. No accessor set.");
1835 # All input files use this object, which stores various attributes about them,
1836 # and provides for convenient, uniform handling. The run method wraps the
1837 # processing. It handles all the bookkeeping of opening, reading, and closing
1838 # the file, returning only significant input lines.
1840 # Each object gets a handler which processes the body of the file, and is
1841 # called by run(). Most should use the generic, default handler, which has
1842 # code scrubbed to handle things you might not expect. A handler should
1843 # basically be a while(next_line()) {...} loop.
1845 # You can also set up handlers to
1846 # 1) call before the first line is read for pre processing
1847 # 2) call to adjust each line of the input before the main handler gets them
1848 # 3) call upon EOF before the main handler exits its loop
1849 # 4) call at the end for post processing
1851 # $_ is used to store the input line, and is to be filtered by the
1852 # each_line_handler()s. So, if the format of the line is not in the desired
1853 # format for the main handler, these are used to do that adjusting. They can
1854 # be stacked (by enclosing them in an [ anonymous array ] in the constructor,
1855 # so the $_ output of one is used as the input to the next. None of the other
1856 # handlers are stackable, but could easily be changed to be so.
1858 # Most of the handlers can call insert_lines() or insert_adjusted_lines()
1859 # which insert the parameters as lines to be processed before the next input
1860 # file line is read. This allows the EOF handler to flush buffers, for
1861 # example. The difference between the two routines is that the lines inserted
1862 # by insert_lines() are subjected to the each_line_handler()s. (So if you
1863 # called it from such a handler, you would get infinite recursion.) Lines
1864 # inserted by insert_adjusted_lines() go directly to the main handler without
1865 # any adjustments. If the post-processing handler calls any of these, there
1866 # will be no effect. Some error checking for these conditions could be added,
1867 # but it hasn't been done.
1869 # carp_bad_line() should be called to warn of bad input lines, which clears $_
1870 # to prevent further processing of the line. This routine will output the
1871 # message as a warning once, and then keep a count of the lines that have the
1872 # same message, and output that count at the end of the file's processing.
1873 # This keeps the number of messages down to a manageable amount.
1875 # get_missings() should be called to retrieve any @missing input lines.
1876 # Messages will be raised if this isn't done if the options aren't to ignore
1879 sub trace { return main::trace(@_); }
1882 # Keep track of fields that are to be put into the constructor.
1883 my %constructor_fields;
1885 main::setup_package(Constructor_Fields => \%constructor_fields);
1887 my %file; # Input file name, required
1888 main::set_access('file', \%file, qw{ c r });
1890 my %first_released; # Unicode version file was first released in, required
1891 main::set_access('first_released', \%first_released, qw{ c r });
1893 my %handler; # Subroutine to process the input file, defaults to
1894 # 'process_generic_property_file'
1895 main::set_access('handler', \%handler, qw{ c });
1898 # name of property this file is for. defaults to none, meaning not
1899 # applicable, or is otherwise determinable, for example, from each line.
1900 main::set_access('property', \%property, qw{ c });
1903 # If this is true, the file is optional. If not present, no warning is
1904 # output. If it is present, the string given by this parameter is
1905 # evaluated, and if false the file is not processed.
1906 main::set_access('optional', \%optional, 'c', 'r');
1909 # This is used for debugging, to skip processing of all but a few input
1910 # files. Add 'non_skip => 1' to the constructor for those files you want
1911 # processed when you set the $debug_skip global.
1912 main::set_access('non_skip', \%non_skip, 'c');
1915 # This is used to skip processing of this input file semi-permanently.
1916 # It is used for files that we aren't planning to process anytime soon,
1917 # but want to allow to be in the directory and not raise a message that we
1918 # are not handling. Mostly for test files. This is in contrast to the
1919 # non_skip element, which is supposed to be used very temporarily for
1920 # debugging. Sets 'optional' to 1
1921 main::set_access('skip', \%skip, 'c');
1923 my %each_line_handler;
1924 # list of subroutines to look at and filter each non-comment line in the
1925 # file. defaults to none. The subroutines are called in order, each is
1926 # to adjust $_ for the next one, and the final one adjusts it for
1928 main::set_access('each_line_handler', \%each_line_handler, 'c');
1930 my %has_missings_defaults;
1931 # ? Are there lines in the file giving default values for code points
1932 # missing from it?. Defaults to NO_DEFAULTS. Otherwise NOT_IGNORED is
1933 # the norm, but IGNORED means it has such lines, but the handler doesn't
1934 # use them. Having these three states allows us to catch changes to the
1935 # UCD that this program should track
1936 main::set_access('has_missings_defaults',
1937 \%has_missings_defaults, qw{ c r });
1940 # Subroutine to call before doing anything else in the file. If undef, no
1941 # such handler is called.
1942 main::set_access('pre_handler', \%pre_handler, qw{ c });
1945 # Subroutine to call upon getting an EOF on the input file, but before
1946 # that is returned to the main handler. This is to allow buffers to be
1947 # flushed. The handler is expected to call insert_lines() or
1948 # insert_adjusted() with the buffered material
1949 main::set_access('eof_handler', \%eof_handler, qw{ c r });
1952 # Subroutine to call after all the lines of the file are read in and
1953 # processed. If undef, no such handler is called.
1954 main::set_access('post_handler', \%post_handler, qw{ c });
1956 my %progress_message;
1957 # Message to print to display progress in lieu of the standard one
1958 main::set_access('progress_message', \%progress_message, qw{ c });
1961 # cache open file handle, internal. Is undef if file hasn't been
1962 # processed at all, empty if has;
1963 main::set_access('handle', \%handle);
1966 # cache of lines added virtually to the file, internal
1967 main::set_access('added_lines', \%added_lines);
1970 # cache of errors found, internal
1971 main::set_access('errors', \%errors);
1974 # storage of '@missing' defaults lines
1975 main::set_access('missings', \%missings);
1980 my $self = bless \do{ my $anonymous_scalar }, $class;
1981 my $addr = do { no overloading; pack 'J', $self; };
1984 $handler{$addr} = \&main::process_generic_property_file;
1985 $non_skip{$addr} = 0;
1987 $has_missings_defaults{$addr} = $NO_DEFAULTS;
1988 $handle{$addr} = undef;
1989 $added_lines{$addr} = [ ];
1990 $each_line_handler{$addr} = [ ];
1991 $errors{$addr} = { };
1992 $missings{$addr} = [ ];
1994 # Two positional parameters.
1995 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1996 $file{$addr} = main::internal_file_to_platform(shift);
1997 $first_released{$addr} = shift;
1999 # The rest of the arguments are key => value pairs
2000 # %constructor_fields has been set up earlier to list all possible
2001 # ones. Either set or push, depending on how the default has been set
2004 foreach my $key (keys %args) {
2005 my $argument = $args{$key};
2007 # Note that the fields are the lower case of the constructor keys
2008 my $hash = $constructor_fields{lc $key};
2009 if (! defined $hash) {
2010 Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self. Skipped");
2013 if (ref $hash->{$addr} eq 'ARRAY') {
2014 if (ref $argument eq 'ARRAY') {
2015 foreach my $argument (@{$argument}) {
2016 next if ! defined $argument;
2017 push @{$hash->{$addr}}, $argument;
2021 push @{$hash->{$addr}}, $argument if defined $argument;
2025 $hash->{$addr} = $argument;
2030 # If the file has a property for it, it means that the property is not
2031 # listed in the file's entries. So add a handler to the list of line
2032 # handlers to insert the property name into the lines, to provide a
2033 # uniform interface to the final processing subroutine.
2034 # the final code doesn't have to worry about that.
2035 if ($property{$addr}) {
2036 push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
2039 if ($non_skip{$addr} && ! $debug_skip && $verbosity) {
2040 print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
2043 $optional{$addr} = 1 if $skip{$addr};
2051 qw("") => "_operator_stringify",
2052 "." => \&main::_operator_dot,
2055 sub _operator_stringify {
2058 return __PACKAGE__ . " object for " . $self->file;
2061 # flag to make sure extracted files are processed early
2062 my $seen_non_extracted_non_age = 0;
2065 # Process the input object $self. This opens and closes the file and
2066 # calls all the handlers for it. Currently, this can only be called
2067 # once per file, as it destroy's the EOF handler
2070 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2072 my $addr = do { no overloading; pack 'J', $self; };
2074 my $file = $file{$addr};
2076 # Don't process if not expecting this file (because released later
2077 # than this Unicode version), and isn't there. This means if someone
2078 # copies it into an earlier version's directory, we will go ahead and
2080 return if $first_released{$addr} gt $v_version && ! -e $file;
2082 # If in debugging mode and this file doesn't have the non-skip
2083 # flag set, and isn't one of the critical files, skip it.
2085 && $first_released{$addr} ne v0
2086 && ! $non_skip{$addr})
2088 print "Skipping $file in debugging\n" if $verbosity;
2092 # File could be optional
2093 if ($optional{$addr}) {
2094 return unless -e $file;
2095 my $result = eval $optional{$addr};
2096 if (! defined $result) {
2097 Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}. $file Skipped.");
2102 print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n";
2108 if (! defined $file || ! -e $file) {
2110 # If the file doesn't exist, see if have internal data for it
2111 # (based on first_released being 0).
2112 if ($first_released{$addr} eq v0) {
2113 $handle{$addr} = 'pretend_is_open';
2116 if (! $optional{$addr} # File could be optional
2117 && $v_version ge $first_released{$addr})
2119 print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr};
2126 # Here, the file exists. Some platforms may change the case of
2128 if ($seen_non_extracted_non_age) {
2129 if ($file =~ /$EXTRACTED/i) {
2130 Carp::my_carp_bug(join_lines(<<END
2131 $file should be processed just after the 'Prop...Alias' files, and before
2132 anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may
2133 have subtle problems
2138 elsif ($EXTRACTED_DIR
2139 && $first_released{$addr} ne v0
2140 && $file !~ /$EXTRACTED/i
2141 && lc($file) ne 'dage.txt')
2143 # We don't set this (by the 'if' above) if we have no
2144 # extracted directory, so if running on an early version,
2145 # this test won't work. Not worth worrying about.
2146 $seen_non_extracted_non_age = 1;
2149 # And mark the file as having being processed, and warn if it
2150 # isn't a file we are expecting. As we process the files,
2151 # they are deleted from the hash, so any that remain at the
2152 # end of the program are files that we didn't process.
2153 my $fkey = File::Spec->rel2abs($file);
2154 my $expecting = delete $potential_files{$fkey};
2155 $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
2156 Carp::my_carp("Was not expecting '$file'.") if
2158 && ! defined $handle{$addr};
2160 # Having deleted from expected files, we can quit if not to do
2161 # anything. Don't print progress unless really want verbosity
2163 print "Skipping $file.\n" if $verbosity >= $VERBOSE;
2167 # Open the file, converting the slashes used in this program
2168 # into the proper form for the OS
2170 if (not open $file_handle, "<", $file) {
2171 Carp::my_carp("Can't open $file. Skipping: $!");
2174 $handle{$addr} = $file_handle; # Cache the open file handle
2177 if ($verbosity >= $PROGRESS) {
2178 if ($progress_message{$addr}) {
2179 print "$progress_message{$addr}\n";
2182 # If using a virtual file, say so.
2183 print "Processing ", (-e $file)
2185 : "substitute $file",
2191 # Call any special handler for before the file.
2192 &{$pre_handler{$addr}}($self) if $pre_handler{$addr};
2194 # Then the main handler
2195 &{$handler{$addr}}($self);
2197 # Then any special post-file handler.
2198 &{$post_handler{$addr}}($self) if $post_handler{$addr};
2200 # If any errors have been accumulated, output the counts (as the first
2201 # error message in each class was output when it was encountered).
2202 if ($errors{$addr}) {
2205 foreach my $error (keys %{$errors{$addr}}) {
2206 $total += $errors{$addr}->{$error};
2207 delete $errors{$addr}->{$error};
2212 = "A total of $total lines had errors in $file. ";
2214 $message .= ($types == 1)
2215 ? '(Only the first one was displayed.)'
2216 : '(Only the first of each type was displayed.)';
2217 Carp::my_carp($message);
2221 if (@{$missings{$addr}}) {
2222 Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines. Generated tables likely are wrong");
2225 # If a real file handle, close it.
2226 close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
2228 $handle{$addr} = ""; # Uses empty to indicate that has already seen
2229 # the file, as opposed to undef
2234 # Sets $_ to be the next logical input line, if any. Returns non-zero
2235 # if such a line exists. 'logical' means that any lines that have
2236 # been added via insert_lines() will be returned in $_ before the file
2240 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2242 my $addr = do { no overloading; pack 'J', $self; };
2244 # Here the file is open (or if the handle is not a ref, is an open
2245 # 'virtual' file). Get the next line; any inserted lines get priority
2246 # over the file itself.
2250 while (1) { # Loop until find non-comment, non-empty line
2251 #local $to_trace = 1 if main::DEBUG;
2252 my $inserted_ref = shift @{$added_lines{$addr}};
2253 if (defined $inserted_ref) {
2254 ($adjusted, $_) = @{$inserted_ref};
2255 trace $adjusted, $_ if main::DEBUG && $to_trace;
2256 return 1 if $adjusted;
2259 last if ! ref $handle{$addr}; # Don't read unless is real file
2260 last if ! defined ($_ = readline $handle{$addr});
2263 trace $_ if main::DEBUG && $to_trace;
2265 # See if this line is the comment line that defines what property
2266 # value that code points that are not listed in the file should
2267 # have. The format or existence of these lines is not guaranteed
2268 # by Unicode since they are comments, but the documentation says
2269 # that this was added for machine-readability, so probably won't
2270 # change. This works starting in Unicode Version 5.0. They look
2273 # @missing: 0000..10FFFF; Not_Reordered
2274 # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
2275 # @missing: 0000..10FFFF; ; NaN
2277 # Save the line for a later get_missings() call.
2278 if (/$missing_defaults_prefix/) {
2279 if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
2280 $self->carp_bad_line("Unexpected \@missing line. Assuming no missing entries");
2282 elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
2283 my @defaults = split /\s* ; \s*/x, $_;
2285 # The first field is the @missing, which ends in a
2286 # semi-colon, so can safely shift.
2289 # Some of these lines may have empty field placeholders
2290 # which get in the way. An example is:
2291 # @missing: 0000..10FFFF; ; NaN
2292 # Remove them. Process starting from the top so the
2293 # splice doesn't affect things still to be looked at.
2294 for (my $i = @defaults - 1; $i >= 0; $i--) {
2295 next if $defaults[$i] ne "";
2296 splice @defaults, $i, 1;
2299 # What's left should be just the property (maybe) and the
2300 # default. Having only one element means it doesn't have
2304 if (@defaults >= 1) {
2305 if (@defaults == 1) {
2306 $default = $defaults[0];
2309 $property = $defaults[0];
2310 $default = $defaults[1];
2316 || ($default =~ /^</
2317 && $default !~ /^<code *point>$/i
2318 && $default !~ /^<none>$/i))
2320 $self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries");
2324 # If the property is missing from the line, it should
2325 # be the one for the whole file
2326 $property = $property{$addr} if ! defined $property;
2328 # Change <none> to the null string, which is what it
2329 # really means. If the default is the code point
2330 # itself, set it to <code point>, which is what
2331 # Unicode uses (but sometimes they've forgotten the
2333 if ($default =~ /^<none>$/i) {
2336 elsif ($default =~ /^<code *point>$/i) {
2337 $default = $CODE_POINT;
2340 # Store them as a sub-arrays with both components.
2341 push @{$missings{$addr}}, [ $default, $property ];
2345 # There is nothing for the caller to process on this comment
2350 # Remove comments and trailing space, and skip this line if the
2356 # Call any handlers for this line, and skip further processing of
2357 # the line if the handler sets the line to null.
2358 foreach my $sub_ref (@{$each_line_handler{$addr}}) {
2363 # Here the line is ok. return success.
2365 } # End of looping through lines.
2367 # If there is an EOF handler, call it (only once) and if it generates
2368 # more lines to process go back in the loop to handle them.
2369 if ($eof_handler{$addr}) {
2370 &{$eof_handler{$addr}}($self);
2371 $eof_handler{$addr} = ""; # Currently only get one shot at it.
2372 goto LINE if $added_lines{$addr};
2375 # Return failure -- no more lines.
2380 # Not currently used, not fully tested.
2382 # # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
2383 # # record. Not callable from an each_line_handler(), nor does it call
2384 # # an each_line_handler() on the line.
2387 # my $addr = do { no overloading; pack 'J', $self; };
2389 # foreach my $inserted_ref (@{$added_lines{$addr}}) {
2390 # my ($adjusted, $line) = @{$inserted_ref};
2391 # next if $adjusted;
2393 # # Remove comments and trailing space, and return a non-empty
2396 # $line =~ s/\s+$//;
2397 # return $line if $line ne "";
2400 # return if ! ref $handle{$addr}; # Don't read unless is real file
2401 # while (1) { # Loop until find non-comment, non-empty line
2402 # local $to_trace = 1 if main::DEBUG;
2403 # trace $_ if main::DEBUG && $to_trace;
2404 # return if ! defined (my $line = readline $handle{$addr});
2406 # push @{$added_lines{$addr}}, [ 0, $line ];
2409 # $line =~ s/\s+$//;
2410 # return $line if $line ne "";
2418 # Lines can be inserted so that it looks like they were in the input
2419 # file at the place it was when this routine is called. See also
2420 # insert_adjusted_lines(). Lines inserted via this routine go through
2421 # any each_line_handler()
2425 # Each inserted line is an array, with the first element being 0 to
2426 # indicate that this line hasn't been adjusted, and needs to be
2429 push @{$added_lines{pack 'J', $self}}, map { [ 0, $_ ] } @_;
2433 sub insert_adjusted_lines {
2434 # Lines can be inserted so that it looks like they were in the input
2435 # file at the place it was when this routine is called. See also
2436 # insert_lines(). Lines inserted via this routine are already fully
2437 # adjusted, ready to be processed; each_line_handler()s handlers will
2438 # not be called. This means this is not a completely general
2439 # facility, as only the last each_line_handler on the stack should
2440 # call this. It could be made more general, by passing to each of the
2441 # line_handlers their position on the stack, which they would pass on
2442 # to this routine, and that would replace the boolean first element in
2443 # the anonymous array pushed here, so that the next_line routine could
2444 # use that to call only those handlers whose index is after it on the
2445 # stack. But this is overkill for what is needed now.
2448 trace $_[0] if main::DEBUG && $to_trace;
2450 # Each inserted line is an array, with the first element being 1 to
2451 # indicate that this line has been adjusted
2453 push @{$added_lines{pack 'J', $self}}, map { [ 1, $_ ] } @_;
2458 # Returns the stored up @missings lines' values, and clears the list.
2459 # The values are in an array, consisting of the default in the first
2460 # element, and the property in the 2nd. However, since these lines
2461 # can be stacked up, the return is an array of all these arrays.
2464 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2466 my $addr = do { no overloading; pack 'J', $self; };
2468 # If not accepting a list return, just return the first one.
2469 return shift @{$missings{$addr}} unless wantarray;
2471 my @return = @{$missings{$addr}};
2472 undef @{$missings{$addr}};
2476 sub _insert_property_into_line {
2477 # Add a property field to $_, if this file requires it.
2480 my $addr = do { no overloading; pack 'J', $self; };
2481 my $property = $property{$addr};
2482 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2484 $_ =~ s/(;|$)/; $property$1/;
2489 # Output consistent error messages, using either a generic one, or the
2490 # one given by the optional parameter. To avoid gazillions of the
2491 # same message in case the syntax of a file is way off, this routine
2492 # only outputs the first instance of each message, incrementing a
2493 # count so the totals can be output at the end of the file.
2496 my $message = shift;
2497 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2499 my $addr = do { no overloading; pack 'J', $self; };
2501 $message = 'Unexpected line' unless $message;
2503 # No trailing punctuation so as to fit with our addenda.
2504 $message =~ s/[.:;,]$//;
2506 # If haven't seen this exact message before, output it now. Otherwise
2507 # increment the count of how many times it has occurred
2508 unless ($errors{$addr}->{$message}) {
2509 Carp::my_carp("$message in '$_' in "
2511 . " at line $.. Skipping this line;");
2512 $errors{$addr}->{$message} = 1;
2515 $errors{$addr}->{$message}++;
2518 # Clear the line to prevent any further (meaningful) processing of it.
2525 package Multi_Default;
2527 # Certain properties in early versions of Unicode had more than one possible
2528 # default for code points missing from the files. In these cases, one
2529 # default applies to everything left over after all the others are applied,
2530 # and for each of the others, there is a description of which class of code
2531 # points applies to it. This object helps implement this by storing the
2532 # defaults, and for all but that final default, an eval string that generates
2533 # the class that it applies to.
2538 main::setup_package();
2541 # The defaults structure for the classes
2542 main::set_access('class_defaults', \%class_defaults);
2545 # The default that applies to everything left over.
2546 main::set_access('other_default', \%other_default, 'r');
2550 # The constructor is called with default => eval pairs, terminated by
2551 # the left-over default. e.g.
2552 # Multi_Default->new(
2553 # 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
2555 # 'R' => 'some other expression that evaluates to code points',
2563 my $self = bless \do{my $anonymous_scalar}, $class;
2564 my $addr = do { no overloading; pack 'J', $self; };
2567 my $default = shift;
2569 $class_defaults{$addr}->{$default} = $eval;
2572 $other_default{$addr} = shift;
2577 sub get_next_defaults {
2578 # Iterates and returns the next class of defaults.
2580 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2582 my $addr = do { no overloading; pack 'J', $self; };
2584 return each %{$class_defaults{$addr}};
2590 # An alias is one of the names that a table goes by. This class defines them
2591 # including some attributes. Everything is currently setup in the
2597 main::setup_package();
2600 main::set_access('name', \%name, 'r');
2603 # Determined by the constructor code if this name should match loosely or
2604 # not. The constructor parameters can override this, but it isn't fully
2605 # implemented, as should have ability to override Unicode one's via
2606 # something like a set_loose_match()
2607 main::set_access('loose_match', \%loose_match, 'r');
2610 # Some aliases should not get their own entries because they are covered
2611 # by a wild-card, and some we want to discourage use of. Binary
2612 main::set_access('make_pod_entry', \%make_pod_entry, 'r');
2615 # Aliases have a status, like deprecated, or even suppressed (which means
2616 # they don't appear in documentation). Enum
2617 main::set_access('status', \%status, 'r');
2620 # Similarly, some aliases should not be considered as usable ones for
2621 # external use, such as file names, or we don't want documentation to
2622 # recommend them. Boolean
2623 main::set_access('externally_ok', \%externally_ok, 'r');
2628 my $self = bless \do { my $anonymous_scalar }, $class;
2629 my $addr = do { no overloading; pack 'J', $self; };
2631 $name{$addr} = shift;
2632 $loose_match{$addr} = shift;
2633 $make_pod_entry{$addr} = shift;
2634 $externally_ok{$addr} = shift;
2635 $status{$addr} = shift;
2637 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2639 # Null names are never ok externally
2640 $externally_ok{$addr} = 0 if $name{$addr} eq "";
2648 # A range is the basic unit for storing code points, and is described in the
2649 # comments at the beginning of the program. Each range has a starting code
2650 # point; an ending code point (not less than the starting one); a value
2651 # that applies to every code point in between the two end-points, inclusive;
2652 # and an enum type that applies to the value. The type is for the user's
2653 # convenience, and has no meaning here, except that a non-zero type is
2654 # considered to not obey the normal Unicode rules for having standard forms.
2656 # The same structure is used for both map and match tables, even though in the
2657 # latter, the value (and hence type) is irrelevant and could be used as a
2658 # comment. In map tables, the value is what all the code points in the range
2659 # map to. Type 0 values have the standardized version of the value stored as
2660 # well, so as to not have to recalculate it a lot.
2662 sub trace { return main::trace(@_); }
2666 main::setup_package();
2669 main::set_access('start', \%start, 'r', 's');
2672 main::set_access('end', \%end, 'r', 's');
2675 main::set_access('value', \%value, 'r');
2678 main::set_access('type', \%type, 'r');
2681 # The value in internal standard form. Defined only if the type is 0.
2682 main::set_access('standard_form', \%standard_form);
2684 # Note that if these fields change, the dump() method should as well
2687 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
2690 my $self = bless \do { my $anonymous_scalar }, $class;
2691 my $addr = do { no overloading; pack 'J', $self; };
2693 $start{$addr} = shift;
2694 $end{$addr} = shift;
2698 my $value = delete $args{'Value'}; # Can be 0
2699 $value = "" unless defined $value;
2700 $value{$addr} = $value;
2702 $type{$addr} = delete $args{'Type'} || 0;
2704 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2706 if (! $type{$addr}) {
2707 $standard_form{$addr} = main::standardize($value);
2715 qw("") => "_operator_stringify",
2716 "." => \&main::_operator_dot,
2719 sub _operator_stringify {
2721 my $addr = do { no overloading; pack 'J', $self; };
2723 # Output it like '0041..0065 (value)'
2724 my $return = sprintf("%04X", $start{$addr})
2726 . sprintf("%04X", $end{$addr});
2727 my $value = $value{$addr};
2728 my $type = $type{$addr};
2730 $return .= "$value";
2731 $return .= ", Type=$type" if $type != 0;
2738 # The standard form is the value itself if the standard form is
2739 # undefined (that is if the value is special)
2742 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2744 my $addr = do { no overloading; pack 'J', $self; };
2746 return $standard_form{$addr} if defined $standard_form{$addr};
2747 return $value{$addr};
2751 # Human, not machine readable. For machine readable, comment out this
2752 # entire routine and let the standard one take effect.
2755 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2757 my $addr = do { no overloading; pack 'J', $self; };
2759 my $return = $indent
2760 . sprintf("%04X", $start{$addr})
2762 . sprintf("%04X", $end{$addr})
2763 . " '$value{$addr}';";
2764 if (! defined $standard_form{$addr}) {
2765 $return .= "(type=$type{$addr})";
2767 elsif ($standard_form{$addr} ne $value{$addr}) {
2768 $return .= "(standard '$standard_form{$addr}')";
2774 package _Range_List_Base;
2776 # Base class for range lists. A range list is simply an ordered list of
2777 # ranges, so that the ranges with the lowest starting numbers are first in it.
2779 # When a new range is added that is adjacent to an existing range that has the
2780 # same value and type, it merges with it to form a larger range.
2782 # Ranges generally do not overlap, except that there can be multiple entries
2783 # of single code point ranges. This is because of NameAliases.txt.
2785 # In this program, there is a standard value such that if two different
2786 # values, have the same standard value, they are considered equivalent. This
2787 # value was chosen so that it gives correct results on Unicode data
2789 # There are a number of methods to manipulate range lists, and some operators
2790 # are overloaded to handle them.
2792 sub trace { return main::trace(@_); }
2798 main::setup_package();
2801 # The list of ranges
2802 main::set_access('ranges', \%ranges, 'readable_array');
2805 # The highest code point in the list. This was originally a method, but
2806 # actual measurements said it was used a lot.
2807 main::set_access('max', \%max, 'r');
2809 my %each_range_iterator;
2810 # Iterator position for each_range()
2811 main::set_access('each_range_iterator', \%each_range_iterator);
2814 # Name of parent this is attached to, if any. Solely for better error
2816 main::set_access('owner_name_of', \%owner_name_of, 'p_r');
2818 my %_search_ranges_cache;
2819 # A cache of the previous result from _search_ranges(), for better
2821 main::set_access('_search_ranges_cache', \%_search_ranges_cache);
2827 # Optional initialization data for the range list.
2828 my $initialize = delete $args{'Initialize'};
2832 # Use _union() to initialize. _union() returns an object of this
2833 # class, which means that it will call this constructor recursively.
2834 # But it won't have this $initialize parameter so that it won't
2835 # infinitely loop on this.
2836 return _union($class, $initialize, %args) if defined $initialize;
2838 $self = bless \do { my $anonymous_scalar }, $class;
2839 my $addr = do { no overloading; pack 'J', $self; };
2841 # Optional parent object, only for debug info.
2842 $owner_name_of{$addr} = delete $args{'Owner'};
2843 $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};
2845 # Stringify, in case it is an object.
2846 $owner_name_of{$addr} = "$owner_name_of{$addr}";
2848 # This is used only for error messages, and so a colon is added
2849 $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";
2851 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2853 # Max is initialized to a negative value that isn't adjacent to 0,
2857 $_search_ranges_cache{$addr} = 0;
2858 $ranges{$addr} = [];
2865 qw("") => "_operator_stringify",
2866 "." => \&main::_operator_dot,
2869 sub _operator_stringify {
2871 my $addr = do { no overloading; pack 'J', $self; };
2873 return "Range_List attached to '$owner_name_of{$addr}'"
2874 if $owner_name_of{$addr};
2875 return "anonymous Range_List " . \$self;
2879 # Returns the union of the input code points. It can be called as
2880 # either a constructor or a method. If called as a method, the result
2881 # will be a new() instance of the calling object, containing the union
2882 # of that object with the other parameter's code points; if called as
2883 # a constructor, the first parameter gives the class the new object
2884 # should be, and the second parameter gives the code points to go into
2886 # In either case, there are two parameters looked at by this routine;
2887 # any additional parameters are passed to the new() constructor.
2889 # The code points can come in the form of some object that contains
2890 # ranges, and has a conventionally named method to access them; or
2891 # they can be an array of individual code points (as integers); or
2892 # just a single code point.
2894 # If they are ranges, this routine doesn't make any effort to preserve
2895 # the range values of one input over the other. Therefore this base
2896 # class should not allow _union to be called from other than
2897 # initialization code, so as to prevent two tables from being added
2898 # together where the range values matter. The general form of this
2899 # routine therefore belongs in a derived class, but it was moved here
2900 # to avoid duplication of code. The failure to overload this in this
2901 # class keeps it safe.
2905 my @args; # Arguments to pass to the constructor
2909 # If a method call, will start the union with the object itself, and
2910 # the class of the new object will be the same as self.
2917 # Add the other required parameter.
2919 # Rest of parameters are passed on to the constructor
2921 # Accumulate all records from both lists.
2923 for my $arg (@args) {
2924 #local $to_trace = 0 if main::DEBUG;
2925 trace "argument = $arg" if main::DEBUG && $to_trace;
2926 if (! defined $arg) {
2928 if (defined $self) {
2930 $message .= $owner_name_of{pack 'J', $self};
2932 Carp::my_carp_bug($message .= "Undefined argument to _union. No union done.");
2935 $arg = [ $arg ] if ! ref $arg;
2936 my $type = ref $arg;
2937 if ($type eq 'ARRAY') {
2938 foreach my $element (@$arg) {
2939 push @records, Range->new($element, $element);
2942 elsif ($arg->isa('Range')) {
2943 push @records, $arg;
2945 elsif ($arg->can('ranges')) {
2946 push @records, $arg->ranges;
2950 if (defined $self) {
2952 $message .= $owner_name_of{pack 'J', $self};
2954 Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done.");
2959 # Sort with the range containing the lowest ordinal first, but if
2960 # two ranges start at the same code point, sort with the bigger range
2961 # of the two first, because it takes fewer cycles.
2962 @records = sort { ($a->start <=> $b->start)
2964 # if b is shorter than a, b->end will be
2965 # less than a->end, and we want to select
2966 # a, so want to return -1
2967 ($b->end <=> $a->end)
2970 my $new = $class->new(@_);
2972 # Fold in records so long as they add new information.
2973 for my $set (@records) {
2974 my $start = $set->start;
2975 my $end = $set->end;
2976 my $value = $set->value;
2977 if ($start > $new->max) {
2978 $new->_add_delete('+', $start, $end, $value);
2980 elsif ($end > $new->max) {
2981 $new->_add_delete('+', $new->max +1, $end, $value);
2988 sub range_count { # Return the number of ranges in the range list
2990 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2993 return scalar @{$ranges{pack 'J', $self}};
2997 # Returns the minimum code point currently in the range list, or if
2998 # the range list is empty, 2 beyond the max possible. This is a
2999 # method because used so rarely, that not worth saving between calls,
3000 # and having to worry about changing it as ranges are added and
3004 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3006 my $addr = do { no overloading; pack 'J', $self; };
3008 # If the range list is empty, return a large value that isn't adjacent
3009 # to any that could be in the range list, for simpler tests
3010 return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
3011 return $ranges{$addr}->[0]->start;
3015 # Boolean: Is argument in the range list? If so returns $i such that:
3016 # range[$i]->end < $codepoint <= range[$i+1]->end
3017 # which is one beyond what you want; this is so that the 0th range
3018 # doesn't return false
3020 my $codepoint = shift;
3021 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3023 my $i = $self->_search_ranges($codepoint);
3024 return 0 unless defined $i;
3026 # The search returns $i, such that
3027 # range[$i-1]->end < $codepoint <= range[$i]->end
3028 # So is in the table if and only iff it is at least the start position
3031 return 0 if $ranges{pack 'J', $self}->[$i]->start > $codepoint;
3035 sub containing_range {
3036 # Returns the range object that contains the code point, undef if none
3039 my $codepoint = shift;
3040 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3042 my $i = $self->contains($codepoint);
3045 # contains() returns 1 beyond where we should look
3047 return $ranges{pack 'J', $self}->[$i-1];
3051 # Returns the value associated with the code point, undef if none
3054 my $codepoint = shift;
3055 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3057 my $range = $self->containing_range($codepoint);
3058 return unless defined $range;
3060 return $range->value;
3064 # Returns the type of the range containing the code point, undef if
3065 # the code point is not in the table
3068 my $codepoint = shift;
3069 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3071 my $range = $self->containing_range($codepoint);
3072 return unless defined $range;
3074 return $range->type;
3077 sub _search_ranges {
3078 # Find the range in the list which contains a code point, or where it
3079 # should go if were to add it. That is, it returns $i, such that:
3080 # range[$i-1]->end < $codepoint <= range[$i]->end
3081 # Returns undef if no such $i is possible (e.g. at end of table), or
3082 # if there is an error.
3085 my $code_point = shift;
3086 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3088 my $addr = do { no overloading; pack 'J', $self; };
3090 return if $code_point > $max{$addr};
3091 my $r = $ranges{$addr}; # The current list of ranges
3092 my $range_list_size = scalar @$r;
3095 use integer; # want integer division
3097 # Use the cached result as the starting guess for this one, because,
3098 # an experiment on 5.1 showed that 90% of the time the cache was the
3099 # same as the result on the next call (and 7% it was one less).
3100 $i = $_search_ranges_cache{$addr};
3101 $i = 0 if $i >= $range_list_size; # Reset if no longer valid (prob.
3102 # from an intervening deletion
3103 #local $to_trace = 1 if main::DEBUG;
3104 trace "previous \$i is still valid: $i" if main::DEBUG && $to_trace && $code_point <= $r->[$i]->end && ($i == 0 || $r->[$i-1]->end < $code_point);
3105 return $i if $code_point <= $r->[$i]->end
3106 && ($i == 0 || $r->[$i-1]->end < $code_point);
3108 # Here the cache doesn't yield the correct $i. Try adding 1.
3109 if ($i < $range_list_size - 1
3110 && $r->[$i]->end < $code_point &&
3111 $code_point <= $r->[$i+1]->end)
3114 trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
3115 $_search_ranges_cache{$addr} = $i;
3119 # Here, adding 1 also didn't work. We do a binary search to
3120 # find the correct position, starting with current $i
3122 my $upper = $range_list_size - 1;
3124 trace "top of loop i=$i:", sprintf("%04X", $r->[$lower]->start), "[$lower] .. ", sprintf("%04X", $r->[$i]->start), "[$i] .. ", sprintf("%04X", $r->[$upper]->start), "[$upper]" if main::DEBUG && $to_trace;
3126 if ($code_point <= $r->[$i]->end) {
3128 # Here we have met the upper constraint. We can quit if we
3129 # also meet the lower one.
3130 last if $i == 0 || $r->[$i-1]->end < $code_point;
3132 $upper = $i; # Still too high.
3137 # Here, $r[$i]->end < $code_point, so look higher up.
3141 # Split search domain in half to try again.
3142 my $temp = ($upper + $lower) / 2;
3144 # No point in continuing unless $i changes for next time
3148 # We can't reach the highest element because of the averaging.
3149 # So if one below the upper edge, force it there and try one
3151 if ($i == $range_list_size - 2) {
3153 trace "Forcing to upper edge" if main::DEBUG && $to_trace;
3154 $i = $range_list_size - 1;
3156 # Change $lower as well so if fails next time through,
3157 # taking the average will yield the same $i, and we will
3158 # quit with the error message just below.
3162 Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go. No action taken.");
3166 } # End of while loop
3168 if (main::DEBUG && $to_trace) {
3169 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i;
3170 trace "i= [ $i ]", $r->[$i];
3171 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1;
3174 # Here we have found the offset. Cache it as a starting point for the
3176 $_search_ranges_cache{$addr} = $i;
3181 # Add, replace or delete ranges to or from a list. The $type
3182 # parameter gives which:
3183 # '+' => insert or replace a range, returning a list of any changed
3185 # '-' => delete a range, returning a list of any deleted ranges.
3187 # The next three parameters give respectively the start, end, and
3188 # value associated with the range. 'value' should be null unless the
3191 # The range list is kept sorted so that the range with the lowest
3192 # starting position is first in the list, and generally, adjacent
3193 # ranges with the same values are merged into a single larger one (see
3194 # exceptions below).
3196 # There are more parameters; all are key => value pairs:
3197 # Type gives the type of the value. It is only valid for '+'.
3198 # All ranges have types; if this parameter is omitted, 0 is
3199 # assumed. Ranges with type 0 are assumed to obey the
3200 # Unicode rules for casing, etc; ranges with other types are
3201 # not. Otherwise, the type is arbitrary, for the caller's
3202 # convenience, and looked at only by this routine to keep
3203 # adjacent ranges of different types from being merged into
3204 # a single larger range, and when Replace =>
3205 # $IF_NOT_EQUIVALENT is specified (see just below).
3206 # Replace determines what to do if the range list already contains
3207 # ranges which coincide with all or portions of the input
3208 # range. It is only valid for '+':
3209 # => $NO means that the new value is not to replace
3210 # any existing ones, but any empty gaps of the
3211 # range list coinciding with the input range
3212 # will be filled in with the new value.
3213 # => $UNCONDITIONALLY means to replace the existing values with
3214 # this one unconditionally. However, if the
3215 # new and old values are identical, the
3216 # replacement is skipped to save cycles
3217 # => $IF_NOT_EQUIVALENT means to replace the existing values
3218 # with this one if they are not equivalent.
3219 # Ranges are equivalent if their types are the
3220 # same, and they are the same string; or if
3221 # both are type 0 ranges, if their Unicode
3222 # standard forms are identical. In this last
3223 # case, the routine chooses the more "modern"
3224 # one to use. This is because some of the
3225 # older files are formatted with values that
3226 # are, for example, ALL CAPs, whereas the
3227 # derived files have a more modern style,
3228 # which looks better. By looking for this
3229 # style when the pre-existing and replacement
3230 # standard forms are the same, we can move to
3232 # => $MULTIPLE means that if this range duplicates an
3233 # existing one, but has a different value,
3234 # don't replace the existing one, but insert
3235 # this, one so that the same range can occur
3236 # multiple times. They are stored LIFO, so
3237 # that the final one inserted is the first one
3238 # returned in an ordered search of the table.
3239 # => anything else is the same as => $IF_NOT_EQUIVALENT
3241 # "same value" means identical for non-type-0 ranges, and it means
3242 # having the same standard forms for type-0 ranges.
3244 return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;
3247 my $operation = shift; # '+' for add/replace; '-' for delete;
3254 $value = "" if not defined $value; # warning: $value can be "0"
3256 my $replace = delete $args{'Replace'};
3257 $replace = $IF_NOT_EQUIVALENT unless defined $replace;
3259 my $type = delete $args{'Type'};
3260 $type = 0 unless defined $type;
3262 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
3264 my $addr = do { no overloading; pack 'J', $self; };
3266 if ($operation ne '+' && $operation ne '-') {
3267 Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'. No action taken.");
3270 unless (defined $start && defined $end) {
3271 Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete. No action taken.");
3274 unless ($end >= $start) {
3275 Carp::my_carp_bug("$owner_name_of{$addr}End of range (" . sprintf("%04X", $end) . ") must not be before start (" . sprintf("%04X", $start) . "). No action taken.");
3278 #local $to_trace = 1 if main::DEBUG;
3280 if ($operation eq '-') {
3281 if ($replace != $IF_NOT_EQUIVALENT) {
3282 Carp::my_carp_bug("$owner_name_of{$addr}Replace => \$IF_NOT_EQUIVALENT is required when deleting a range from a range list. Assuming Replace => \$IF_NOT_EQUIVALENT.");
3283 $replace = $IF_NOT_EQUIVALENT;
3286 Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list. Assuming Type => 0.");
3290 Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list. Assuming Value => \"\".");
3295 my $r = $ranges{$addr}; # The current list of ranges
3296 my $range_list_size = scalar @$r; # And its size
3297 my $max = $max{$addr}; # The current high code point in
3298 # the list of ranges
3300 # Do a special case requiring fewer machine cycles when the new range
3301 # starts after the current highest point. The Unicode input data is
3302 # structured so this is common.
3303 if ($start > $max) {
3305 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
3306 return if $operation eq '-'; # Deleting a non-existing range is a
3309 # If the new range doesn't logically extend the current final one
3310 # in the range list, create a new range at the end of the range
3311 # list. (max cleverly is initialized to a negative number not
3312 # adjacent to 0 if the range list is empty, so even adding a range
3313 # to an empty range list starting at 0 will have this 'if'
3315 if ($start > $max + 1 # non-adjacent means can't extend.
3316 || @{$r}[-1]->value ne $value # values differ, can't extend.
3317 || @{$r}[-1]->type != $type # types differ, can't extend.
3319 push @$r, Range->new($start, $end,
3325 # Here, the new range starts just after the current highest in
3326 # the range list, and they have the same type and value.
3327 # Extend the current range to incorporate the new one.
3328 @{$r}[-1]->set_end($end);
3331 # This becomes the new maximum.
3336 #local $to_trace = 0 if main::DEBUG;
3338 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace;
3340 # Here, the input range isn't after the whole rest of the range list.
3341 # Most likely 'splice' will be needed. The rest of the routine finds
3342 # the needed splice parameters, and if necessary, does the splice.
3343 # First, find the offset parameter needed by the splice function for
3344 # the input range. Note that the input range may span multiple
3345 # existing ones, but we'll worry about that later. For now, just find
3346 # the beginning. If the input range is to be inserted starting in a
3347 # position not currently in the range list, it must (obviously) come
3348 # just after the range below it, and just before the range above it.
3349 # Slightly less obviously, it will occupy the position currently
3350 # occupied by the range that is to come after it. More formally, we
3351 # are looking for the position, $i, in the array of ranges, such that:
3353 # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end
3355 # (The ordered relationships within existing ranges are also shown in
3356 # the equation above). However, if the start of the input range is
3357 # within an existing range, the splice offset should point to that
3358 # existing range's position in the list; that is $i satisfies a
3359 # somewhat different equation, namely:
3361 #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end
3363 # More briefly, $start can come before or after r[$i]->start, and at
3364 # this point, we don't know which it will be. However, these
3365 # two equations share these constraints:
3367 # r[$i-1]->end < $start <= r[$i]->end
3369 # And that is good enough to find $i.
3371 my $i = $self->_search_ranges($start);
3373 Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined. Operation '$operation' not performed");
3377 # The search function returns $i such that:
3379 # r[$i-1]->end < $start <= r[$i]->end
3381 # That means that $i points to the first range in the range list
3382 # that could possibly be affected by this operation. We still don't
3383 # know if the start of the input range is within r[$i], or if it
3384 # points to empty space between r[$i-1] and r[$i].
3385 trace "[$i] is the beginning splice point. Existing range there is ", $r->[$i] if main::DEBUG && $to_trace;
3387 # Special case the insertion of data that is not to replace any
3389 if ($replace == $NO) { # If $NO, has to be operation '+'
3390 #local $to_trace = 1 if main::DEBUG;
3391 trace "Doesn't replace" if main::DEBUG && $to_trace;
3393 # Here, the new range is to take effect only on those code points
3394 # that aren't already in an existing range. This can be done by
3395 # looking through the existing range list and finding the gaps in
3396 # the ranges that this new range affects, and then calling this
3397 # function recursively on each of those gaps, leaving untouched
3398 # anything already in the list. Gather up a list of the changed
3399 # gaps first so that changes to the internal state as new ranges
3400 # are added won't be a problem.
3403 # First, if the starting point of the input range is outside an
3404 # existing one, there is a gap from there to the beginning of the
3405 # existing range -- add a span to fill the part that this new
3407 if ($start < $r->[$i]->start) {
3408 push @gap_list, Range->new($start,
3410 $r->[$i]->start - 1),
3412 trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace;
3415 # Then look through the range list for other gaps until we reach
3416 # the highest range affected by the input one.
3418 for ($j = $i+1; $j < $range_list_size; $j++) {
3419 trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace;
3420 last if $end < $r->[$j]->start;
3422 # If there is a gap between when this range starts and the
3423 # previous one ends, add a span to fill it. Note that just
3424 # because there are two ranges doesn't mean there is a
3425 # non-zero gap between them. It could be that they have
3426 # different values or types
3427 if ($r->[$j-1]->end + 1 != $r->[$j]->start) {
3429 Range->new($r->[$j-1]->end + 1,
3430 $r->[$j]->start - 1,
3432 trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace;
3436 # Here, we have either found an existing range in the range list,
3437 # beyond the area affected by the input one, or we fell off the
3438 # end of the loop because the input range affects the whole rest
3439 # of the range list. In either case, $j is 1 higher than the
3440 # highest affected range. If $j == $i, it means that there are no
3441 # affected ranges, that the entire insertion is in the gap between
3442 # r[$i-1], and r[$i], which we already have taken care of before
3444 # On the other hand, if there are affected ranges, it might be
3445 # that there is a gap that needs filling after the final such
3446 # range to the end of the input range
3447 if ($r->[$j-1]->end < $end) {
3448 push @gap_list, Range->new(main::max($start,
3449 $r->[$j-1]->end + 1),
3452 trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace;
3455 # Call recursively to fill in all the gaps.
3456 foreach my $gap (@gap_list) {
3457 $self->_add_delete($operation,
3467 # Here, we have taken care of the case where $replace is $NO.
3468 # Remember that here, r[$i-1]->end < $start <= r[$i]->end
3469 # If inserting a multiple record, this is where it goes, before the
3470 # first (if any) existing one. This implies an insertion, and no
3471 # change to any existing ranges. Note that $i can be -1 if this new
3472 # range doesn't actually duplicate any existing, and comes at the
3473 # beginning of the list.
3474 if ($replace == $MULTIPLE) {
3476 if ($start != $end) {
3477 Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the range ($start..$end) contains more than one code point. No action taken.");
3481 # Don't add an exact duplicate, as it isn't really a multiple
3482 if ($end >= $r->[$i]->start) {
3483 if ($r->[$i]->start != $r->[$i]->end) {
3484 Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple record when the other range ($r->[$i]) contains more than one code point. No action taken.");
3487 return if $value eq $r->[$i]->value && $type eq $r->[$i]->type;
3490 trace "Adding multiple record at $i with $start..$end, $value" if main::DEBUG && $to_trace;
3491 my @return = splice @$r,
3498 if (main::DEBUG && $to_trace) {
3499 trace "After splice:";
3500 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3501 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3502 trace "i =[", $i, "]", $r->[$i] if $i >= 0;
3503 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3504 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3505 trace 'i+3=[', $i+3, ']', $r->[$i+3] if $i < @$r - 3;
3510 # Here, we have taken care of $NO and $MULTIPLE replaces. This leaves
3511 # delete, insert, and replace either unconditionally or if not
3512 # equivalent. $i still points to the first potential affected range.
3513 # Now find the highest range affected, which will determine the length
3514 # parameter to splice. (The input range can span multiple existing
3515 # ones.) If this isn't a deletion, while we are looking through the
3516 # range list, see also if this is a replacement rather than a clean
3517 # insertion; that is if it will change the values of at least one
3518 # existing range. Start off assuming it is an insert, until find it
3520 my $clean_insert = $operation eq '+';
3521 my $j; # This will point to the highest affected range
3523 # For non-zero types, the standard form is the value itself;
3524 my $standard_form = ($type) ? $value : main::standardize($value);
3526 for ($j = $i; $j < $range_list_size; $j++) {
3527 trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace;
3529 # If find a range that it doesn't overlap into, we can stop
3531 last if $end < $r->[$j]->start;
3533 # Here, overlaps the range at $j. If the values don't match,
3534 # and so far we think this is a clean insertion, it becomes a
3535 # non-clean insertion, i.e., a 'change' or 'replace' instead.
3536 if ($clean_insert) {
3537 if ($r->[$j]->standard_form ne $standard_form) {
3539 if ($replace == $CROAK) {
3540 main::croak("The range to add "
3541 . sprintf("%04X", $start)
3543 . sprintf("%04X", $end)
3544 . " with value '$value' overlaps an existing range $r->[$j]");
3549 # Here, the two values are essentially the same. If the
3550 # two are actually identical, replacing wouldn't change
3551 # anything so skip it.
3552 my $pre_existing = $r->[$j]->value;
3553 if ($pre_existing ne $value) {
3555 # Here the new and old standardized values are the
3556 # same, but the non-standardized values aren't. If
3557 # replacing unconditionally, then replace
3558 if( $replace == $UNCONDITIONALLY) {
3563 # Here, are replacing conditionally. Decide to
3564 # replace or not based on which appears to look
3565 # the "nicest". If one is mixed case and the
3566 # other isn't, choose the mixed case one.
3567 my $new_mixed = $value =~ /[A-Z]/
3568 && $value =~ /[a-z]/;
3569 my $old_mixed = $pre_existing =~ /[A-Z]/
3570 && $pre_existing =~ /[a-z]/;
3572 if ($old_mixed != $new_mixed) {
3573 $clean_insert = 0 if $new_mixed;
3574 if (main::DEBUG && $to_trace) {
3575 if ($clean_insert) {
3576 trace "Retaining $pre_existing over $value";
3579 trace "Replacing $pre_existing with $value";
3585 # Here casing wasn't different between the two.
3586 # If one has hyphens or underscores and the
3587 # other doesn't, choose the one with the
3589 my $new_punct = $value =~ /[-_]/;
3590 my $old_punct = $pre_existing =~ /[-_]/;
3592 if ($old_punct != $new_punct) {
3593 $clean_insert = 0 if $new_punct;
3594 if (main::DEBUG && $to_trace) {
3595 if ($clean_insert) {
3596 trace "Retaining $pre_existing over $value";
3599 trace "Replacing $pre_existing with $value";
3602 } # else existing one is just as "good";
3603 # retain it to save cycles.
3609 } # End of loop looking for highest affected range.
3611 # Here, $j points to one beyond the highest range that this insertion
3612 # affects (hence to beyond the range list if that range is the final
3613 # one in the range list).
3615 # The splice length is all the affected ranges. Get it before
3616 # subtracting, for efficiency, so we don't have to later add 1.
3617 my $length = $j - $i;
3619 $j--; # $j now points to the highest affected range.
3620 trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;
3622 # Here, have taken care of $NO and $MULTIPLE replaces.
3623 # $j points to the highest affected range. But it can be < $i or even
3624 # -1. These happen only if the insertion is entirely in the gap
3625 # between r[$i-1] and r[$i]. Here's why: j < i means that the j loop
3626 # above exited first time through with $end < $r->[$i]->start. (And
3627 # then we subtracted one from j) This implies also that $start <
3628 # $r->[$i]->start, but we know from above that $r->[$i-1]->end <
3629 # $start, so the entire input range is in the gap.
3632 # Here the entire input range is in the gap before $i.
3634 if (main::DEBUG && $to_trace) {
3636 trace "Entire range is between $r->[$i-1] and $r->[$i]";
3639 trace "Entire range is before $r->[$i]";
3642 return if $operation ne '+'; # Deletion of a non-existent range is
3647 # Here part of the input range is not in the gap before $i. Thus,
3648 # there is at least one affected one, and $j points to the highest
3651 # At this point, here is the situation:
3652 # This is not an insertion of a multiple, nor of tentative ($NO)
3654 # $i points to the first element in the current range list that
3655 # may be affected by this operation. In fact, we know
3656 # that the range at $i is affected because we are in
3657 # the else branch of this 'if'
3658 # $j points to the highest affected range.
3660 # r[$i-1]->end < $start <= r[$i]->end
3662 # r[$i-1]->end < $start <= $end <= r[$j]->end
3665 # $clean_insert is a boolean which is set true if and only if
3666 # this is a "clean insertion", i.e., not a change nor a
3667 # deletion (multiple was handled above).
3669 # We now have enough information to decide if this call is a no-op
3670 # or not. It is a no-op if this is an insertion of already
3673 if (main::DEBUG && $to_trace && $clean_insert
3675 && $start >= $r->[$i]->start)
3679 return if $clean_insert
3680 && $i == $j # more than one affected range => not no-op
3682 # Here, r[$i-1]->end < $start <= $end <= r[$i]->end
3683 # Further, $start and/or $end is >= r[$i]->start
3684 # The test below hence guarantees that
3685 # r[$i]->start < $start <= $end <= r[$i]->end
3686 # This means the input range is contained entirely in
3687 # the one at $i, so is a no-op
3688 && $start >= $r->[$i]->start;
3691 # Here, we know that some action will have to be taken. We have
3692 # calculated the offset and length (though adjustments may be needed)
3693 # for the splice. Now start constructing the replacement list.
3695 my $splice_start = $i;
3700 # See if should extend any adjacent ranges.
3701 if ($operation eq '-') { # Don't extend deletions
3702 $extends_below = $extends_above = 0;
3704 else { # Here, should extend any adjacent ranges. See if there are
3706 $extends_below = ($i > 0
3707 # can't extend unless adjacent
3708 && $r->[$i-1]->end == $start -1
3709 # can't extend unless are same standard value
3710 && $r->[$i-1]->standard_form eq $standard_form
3711 # can't extend unless share type
3712 && $r->[$i-1]->type == $type);
3713 $extends_above = ($j+1 < $range_list_size
3714 && $r->[$j+1]->start == $end +1
3715 && $r->[$j+1]->standard_form eq $standard_form
3716 && $r->[$j+1]->type == $type);
3718 if ($extends_below && $extends_above) { # Adds to both
3719 $splice_start--; # start replace at element below
3720 $length += 2; # will replace on both sides
3721 trace "Extends both below and above ranges" if main::DEBUG && $to_trace;
3723 # The result will fill in any gap, replacing both sides, and
3724 # create one large range.
3725 @replacement = Range->new($r->[$i-1]->start,
3732 # Here we know that the result won't just be the conglomeration of
3733 # a new range with both its adjacent neighbors. But it could
3734 # extend one of them.
3736 if ($extends_below) {
3738 # Here the new element adds to the one below, but not to the
3739 # one above. If inserting, and only to that one range, can
3740 # just change its ending to include the new one.
3741 if ($length == 0 && $clean_insert) {
3742 $r->[$i-1]->set_end($end);
3743 trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace;
3747 trace "Changing inserted range to start at ", sprintf("%04X", $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace;
3748 $splice_start--; # start replace at element below
3749 $length++; # will replace the element below
3750 $start = $r->[$i-1]->start;
3753 elsif ($extends_above) {
3755 # Here the new element adds to the one above, but not below.
3756 # Mirror the code above
3757 if ($length == 0 && $clean_insert) {
3758 $r->[$j+1]->set_start($start);
3759 trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace;
3763 trace "Changing inserted range to end at ", sprintf("%04X", $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace;
3764 $length++; # will replace the element above
3765 $end = $r->[$j+1]->end;
3769 trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace;
3771 # Finally, here we know there will have to be a splice.
3772 # If the change or delete affects only the highest portion of the
3773 # first affected range, the range will have to be split. The
3774 # splice will remove the whole range, but will replace it by a new
3775 # range containing just the unaffected part. So, in this case,
3776 # add to the replacement list just this unaffected portion.
3777 if (! $extends_below
3778 && $start > $r->[$i]->start && $start <= $r->[$i]->end)
3781 Range->new($r->[$i]->start,
3783 Value => $r->[$i]->value,
3784 Type => $r->[$i]->type);
3787 # In the case of an insert or change, but not a delete, we have to
3788 # put in the new stuff; this comes next.
3789 if ($operation eq '+') {
3790 push @replacement, Range->new($start,
3796 trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i;
3797 #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace;
3799 # And finally, if we're changing or deleting only a portion of the
3800 # highest affected range, it must be split, as the lowest one was.
3801 if (! $extends_above
3802 && $j >= 0 # Remember that j can be -1 if before first
3804 && $end >= $r->[$j]->start
3805 && $end < $r->[$j]->end)
3808 Range->new($end + 1,
3810 Value => $r->[$j]->value,
3811 Type => $r->[$j]->type);
3815 # And do the splice, as calculated above
3816 if (main::DEBUG && $to_trace) {
3817 trace "replacing $length element(s) at $i with ";
3818 foreach my $replacement (@replacement) {
3819 trace " $replacement";
3821 trace "Before splice:";
3822 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3823 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3824 trace "i =[", $i, "]", $r->[$i];
3825 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3826 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3829 my @return = splice @$r, $splice_start, $length, @replacement;
3831 if (main::DEBUG && $to_trace) {
3832 trace "After splice:";
3833 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3834 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3835 trace "i =[", $i, "]", $r->[$i];
3836 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3837 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3838 trace "removed ", @return if @return;
3841 # An actual deletion could have changed the maximum in the list.
3842 # There was no deletion if the splice didn't return something, but
3843 # otherwise recalculate it. This is done too rarely to worry about
3845 if ($operation eq '-' && @return) {
3846 $max{$addr} = $r->[-1]->end;
3851 sub reset_each_range { # reset the iterator for each_range();
3853 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3856 undef $each_range_iterator{pack 'J', $self};
3861 # Iterate over each range in a range list. Results are undefined if
3862 # the range list is changed during the iteration.
3865 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3867 my $addr = do { no overloading; pack 'J', $self; };
3869 return if $self->is_empty;
3871 $each_range_iterator{$addr} = -1
3872 if ! defined $each_range_iterator{$addr};
3873 $each_range_iterator{$addr}++;
3874 return $ranges{$addr}->[$each_range_iterator{$addr}]
3875 if $each_range_iterator{$addr} < @{$ranges{$addr}};
3876 undef $each_range_iterator{$addr};
3880 sub count { # Returns count of code points in range list
3882 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3884 my $addr = do { no overloading; pack 'J', $self; };
3887 foreach my $range (@{$ranges{$addr}}) {
3888 $count += $range->end - $range->start + 1;
3893 sub delete_range { # Delete a range
3898 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3900 return $self->_add_delete('-', $start, $end, "");
3903 sub is_empty { # Returns boolean as to if a range list is empty
3905 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3908 return scalar @{$ranges{pack 'J', $self}} == 0;
3912 # Quickly returns a scalar suitable for separating tables into
3913 # buckets, i.e. it is a hash function of the contents of a table, so
3914 # there are relatively few conflicts.
3917 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3919 my $addr = do { no overloading; pack 'J', $self; };
3921 # These are quickly computable. Return looks like 'min..max;count'
3922 return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
3924 } # End closure for _Range_List_Base
3927 use base '_Range_List_Base';
3929 # A Range_List is a range list for match tables; i.e. the range values are
3930 # not significant. Thus a number of operations can be safely added to it,
3931 # such as inversion, intersection. Note that union is also an unsafe
3932 # operation when range values are cared about, and that method is in the base
3933 # class, not here. But things are set up so that that method is callable only
3934 # during initialization. Only in this derived class, is there an operation
3935 # that combines two tables. A Range_Map can thus be used to initialize a
3936 # Range_List, and its mappings will be in the list, but are not significant to
3939 sub trace { return main::trace(@_); }
3945 '+' => sub { my $self = shift;
3948 return $self->_union($other)
3950 '&' => sub { my $self = shift;
3953 return $self->_intersect($other, 0);
3960 # Returns a new Range_List that gives all code points not in $self.
3964 my $new = Range_List->new;
3966 # Go through each range in the table, finding the gaps between them
3967 my $max = -1; # Set so no gap before range beginning at 0
3968 for my $range ($self->ranges) {
3969 my $start = $range->start;
3970 my $end = $range->end;
3972 # If there is a gap before this range, the inverse will contain
3974 if ($start > $max + 1) {
3975 $new->add_range($max + 1, $start - 1);
3980 # And finally, add the gap from the end of the table to the max
3981 # possible code point
3982 if ($max < $LAST_UNICODE_CODEPOINT) {
3983 $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT);
3989 # Returns a new Range_List with the argument deleted from it. The
3990 # argument can be a single code point, a range, or something that has
3991 # a range, with the _range_list() method on it returning them
3995 my $reversed = shift;
3996 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3999 Carp::my_carp_bug("Can't cope with a "
4001 . " being the second parameter in a '-'. Subtraction ignored.");
4005 my $new = Range_List->new(Initialize => $self);
4007 if (! ref $other) { # Single code point
4008 $new->delete_range($other, $other);
4010 elsif ($other->isa('Range')) {
4011 $new->delete_range($other->start, $other->end);
4013 elsif ($other->can('_range_list')) {
4014 foreach my $range ($other->_range_list->ranges) {
4015 $new->delete_range($range->start, $range->end);
4019 Carp::my_carp_bug("Can't cope with a "
4021 . " argument to '-'. Subtraction ignored."
4030 # Returns either a boolean giving whether the two inputs' range lists
4031 # intersect (overlap), or a new Range_List containing the intersection
4032 # of the two lists. The optional final parameter being true indicates
4033 # to do the check instead of the intersection.
4035 my $a_object = shift;
4036 my $b_object = shift;
4037 my $check_if_overlapping = shift;
4038 $check_if_overlapping = 0 unless defined $check_if_overlapping;
4039 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4041 if (! defined $b_object) {
4043 $message .= $a_object->_owner_name_of if defined $a_object;
4044 Carp::my_carp_bug($message .= "Called with undefined value. Intersection not done.");
4048 # a & b = !(!a | !b), or in our terminology = ~ ( ~a + -b )
4049 # Thus the intersection could be much more simply be written:
4050 # return ~(~$a_object + ~$b_object);
4051 # But, this is slower, and when taking the inverse of a large
4052 # range_size_1 table, back when such tables were always stored that
4053 # way, it became prohibitively slow, hence the code was changed to the
4056 if ($b_object->isa('Range')) {
4057 $b_object = Range_List->new(Initialize => $b_object,
4058 Owner => $a_object->_owner_name_of);
4060 $b_object = $b_object->_range_list if $b_object->can('_range_list');
4062 my @a_ranges = $a_object->ranges;
4063 my @b_ranges = $b_object->ranges;
4065 #local $to_trace = 1 if main::DEBUG;
4066 trace "intersecting $a_object with ", scalar @a_ranges, "ranges and $b_object with", scalar @b_ranges, " ranges" if main::DEBUG && $to_trace;
4068 # Start with the first range in each list
4070 my $range_a = $a_ranges[$a_i];
4072 my $range_b = $b_ranges[$b_i];
4074 my $new = __PACKAGE__->new(Owner => $a_object->_owner_name_of)
4075 if ! $check_if_overlapping;
4077 # If either list is empty, there is no intersection and no overlap
4078 if (! defined $range_a || ! defined $range_b) {
4079 return $check_if_overlapping ? 0 : $new;
4081 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
4083 # Otherwise, must calculate the intersection/overlap. Start with the
4084 # very first code point in each list
4085 my $a = $range_a->start;
4086 my $b = $range_b->start;
4088 # Loop through all the ranges of each list; in each iteration, $a and
4089 # $b are the current code points in their respective lists
4092 # If $a and $b are the same code point, ...
4095 # it means the lists overlap. If just checking for overlap
4096 # know the answer now,
4097 return 1 if $check_if_overlapping;
4099 # The intersection includes this code point plus anything else
4100 # common to both current ranges.
4102 my $end = main::min($range_a->end, $range_b->end);
4103 if (! $check_if_overlapping) {
4104 trace "adding intersection range ", sprintf("%04X", $start) . ".." . sprintf("%04X", $end) if main::DEBUG && $to_trace;
4105 $new->add_range($start, $end);
4108 # Skip ahead to the end of the current intersect
4111 # If the current intersect ends at the end of either range (as
4112 # it must for at least one of them), the next possible one
4113 # will be the beginning code point in it's list's next range.
4114 if ($a == $range_a->end) {
4115 $range_a = $a_ranges[++$a_i];
4116 last unless defined $range_a;
4117 $a = $range_a->start;
4119 if ($b == $range_b->end) {
4120 $range_b = $b_ranges[++$b_i];
4121 last unless defined $range_b;
4122 $b = $range_b->start;
4125 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
4129 # Not equal, but if the range containing $a encompasses $b,
4130 # change $a to be the middle of the range where it does equal
4131 # $b, so the next iteration will get the intersection
4132 if ($range_a->end >= $b) {
4137 # Here, the current range containing $a is entirely below
4138 # $b. Go try to find a range that could contain $b.
4139 $a_i = $a_object->_search_ranges($b);
4141 # If no range found, quit.
4142 last unless defined $a_i;
4144 # The search returns $a_i, such that
4145 # range_a[$a_i-1]->end < $b <= range_a[$a_i]->end
4146 # Set $a to the beginning of this new range, and repeat.
4147 $range_a = $a_ranges[$a_i];
4148 $a = $range_a->start;
4151 else { # Here, $b < $a.
4153 # Mirror image code to the leg just above
4154 if ($range_b->end >= $a) {
4158 $b_i = $b_object->_search_ranges($a);
4159 last unless defined $b_i;
4160 $range_b = $b_ranges[$b_i];
4161 $b = $range_b->start;
4164 } # End of looping through ranges.
4166 # Intersection fully computed, or now know that there is no overlap
4167 return $check_if_overlapping ? 0 : $new;
4171 # Returns boolean giving whether the two arguments overlap somewhere
4175 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4177 return $self->_intersect($other, 1);
4181 # Add a range to the list.
4186 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4188 return $self->_add_delete('+', $start, $end, "");
4191 sub matches_identically_to {
4192 # Return a boolean as to whether or not two Range_Lists match identical
4193 # sets of code points.
4197 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4199 # These are ordered in increasing real time to figure out (at least
4200 # until a patch changes that and doesn't change this)
4201 return 0 if $self->max != $other->max;
4202 return 0 if $self->min != $other->min;
4203 return 0 if $self->range_count != $other->range_count;
4204 return 0 if $self->count != $other->count;
4206 # Here they could be identical because all the tests above passed.
4207 # The loop below is somewhat simpler since we know they have the same
4208 # number of elements. Compare range by range, until reach the end or
4209 # find something that differs.
4210 my @a_ranges = $self->ranges;
4211 my @b_ranges = $other->ranges;
4212 for my $i (0 .. @a_ranges - 1) {
4213 my $a = $a_ranges[$i];
4214 my $b = $b_ranges[$i];
4215 trace "self $a; other $b" if main::DEBUG && $to_trace;
4216 return 0 if $a->start != $b->start || $a->end != $b->end;
4221 sub is_code_point_usable {
4222 # This used only for making the test script. See if the input
4223 # proposed trial code point is one that Perl will handle. If second
4224 # parameter is 0, it won't select some code points for various
4225 # reasons, noted below.
4228 my $try_hard = shift;
4229 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4231 return 0 if $code < 0; # Never use a negative
4233 # shun null. I'm (khw) not sure why this was done, but NULL would be
4234 # the character very frequently used.
4235 return $try_hard if $code == 0x0000;
4237 # shun non-character code points.
4238 return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
4239 return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
4241 return $try_hard if $code > $LAST_UNICODE_CODEPOINT; # keep in range
4242 return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
4247 sub get_valid_code_point {
4248 # Return a code point that's part of the range list. Returns nothing
4249 # if the table is empty or we can't find a suitable code point. This
4250 # used only for making the test script.
4253 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4255 my $addr = do { no overloading; pack 'J', $self; };
4257 # On first pass, don't choose less desirable code points; if no good
4258 # one is found, repeat, allowing a less desirable one to be selected.
4259 for my $try_hard (0, 1) {
4261 # Look through all the ranges for a usable code point.
4262 for my $set ($self->ranges) {
4264 # Try the edge cases first, starting with the end point of the
4266 my $end = $set->end;
4267 return $end if is_code_point_usable($end, $try_hard);
4269 # End point didn't, work. Start at the beginning and try
4270 # every one until find one that does work.
4271 for my $trial ($set->start .. $end - 1) {
4272 return $trial if is_code_point_usable($trial, $try_hard);
4276 return (); # If none found, give up.
4279 sub get_invalid_code_point {
4280 # Return a code point that's not part of the table. Returns nothing
4281 # if the table covers all code points or a suitable code point can't
4282 # be found. This used only for making the test script.
4285 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4287 # Just find a valid code point of the inverse, if any.
4288 return Range_List->new(Initialize => ~ $self)->get_valid_code_point;
4290 } # end closure for Range_List
4293 use base '_Range_List_Base';
4295 # A Range_Map is a range list in which the range values (called maps) are
4296 # significant, and hence shouldn't be manipulated by our other code, which
4297 # could be ambiguous or lose things. For example, in taking the union of two
4298 # lists, which share code points, but which have differing values, which one
4299 # has precedence in the union?
4300 # It turns out that these operations aren't really necessary for map tables,
4301 # and so this class was created to make sure they aren't accidentally
4307 # Add a range containing a mapping value to the list
4310 # Rest of parameters passed on
4312 return $self->_add_delete('+', @_);
4316 # Adds entry to a range list which can duplicate an existing entry
4319 my $code_point = shift;
4321 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4323 return $self->add_map($code_point, $code_point,
4324 $value, Replace => $MULTIPLE);
4326 } # End of closure for package Range_Map
4328 package _Base_Table;
4330 # A table is the basic data structure that gets written out into a file for
4331 # use by the Perl core. This is the abstract base class implementing the
4332 # common elements from the derived ones. A list of the methods to be
4333 # furnished by an implementing class is just after the constructor.
4335 sub standardize { return main::standardize($_[0]); }
4336 sub trace { return main::trace(@_); }
4340 main::setup_package();
4343 # Object containing the ranges of the table.
4344 main::set_access('range_list', \%range_list, 'p_r', 'p_s');
4347 # The full table name.
4348 main::set_access('full_name', \%full_name, 'r');
4351 # The table name, almost always shorter
4352 main::set_access('name', \%name, 'r');
4355 # The shortest of all the aliases for this table, with underscores removed
4356 main::set_access('short_name', \%short_name);
4358 my %nominal_short_name_length;
4359 # The length of short_name before removing underscores
4360 main::set_access('nominal_short_name_length',
4361 \%nominal_short_name_length);
4364 # The complete name, including property.
4365 main::set_access('complete_name', \%complete_name, 'r');
4368 # Parent property this table is attached to.
4369 main::set_access('property', \%property, 'r');
4372 # Ordered list of aliases of the table's name. The first ones in the list
4373 # are output first in comments
4374 main::set_access('aliases', \%aliases, 'readable_array');
4377 # A comment associated with the table for human readers of the files
4378 main::set_access('comment', \%comment, 's');
4381 # A comment giving a short description of the table's meaning for human
4382 # readers of the files.
4383 main::set_access('description', \%description, 'readable_array');
4386 # A comment giving a short note about the table for human readers of the
4388 main::set_access('note', \%note, 'readable_array');
4391 # Boolean; if set means any file that contains this table is marked as for
4392 # internal-only use.
4393 main::set_access('internal_only', \%internal_only);
4395 my %find_table_from_alias;
4396 # The parent property passes this pointer to a hash which this class adds
4397 # all its aliases to, so that the parent can quickly take an alias and
4399 main::set_access('find_table_from_alias', \%find_table_from_alias, 'p_r');
4402 # After this table is made equivalent to another one; we shouldn't go
4403 # changing the contents because that could mean it's no longer equivalent
4404 main::set_access('locked', \%locked, 'r');
4407 # This gives the final path to the file containing the table. Each
4408 # directory in the path is an element in the array
4409 main::set_access('file_path', \%file_path, 'readable_array');
4412 # What is the table's status, normal, $OBSOLETE, etc. Enum
4413 main::set_access('status', \%status, 'r');
4416 # A comment about its being obsolete, or whatever non normal status it has
4417 main::set_access('status_info', \%status_info, 'r');
4419 my %caseless_equivalent;
4420 # The table this is equivalent to under /i matching, if any.
4421 main::set_access('caseless_equivalent', \%caseless_equivalent, 'r', 's');
4424 # Is the table to be output with each range only a single code point?
4425 # This is done to avoid breaking existing code that may have come to rely
4426 # on this behavior in previous versions of this program.)
4427 main::set_access('range_size_1', \%range_size_1, 'r', 's');
4430 # A boolean set iff this table is a Perl extension to the Unicode
4432 main::set_access('perl_extension', \%perl_extension, 'r');
4434 my %output_range_counts;
4435 # A boolean set iff this table is to have comments written in the
4436 # output file that contain the number of code points in the range.
4437 # The constructor can override the global flag of the same name.
4438 main::set_access('output_range_counts', \%output_range_counts, 'r');
4441 # The format of the entries of the table. This is calculated from the
4442 # data in the table (or passed in the constructor). This is an enum e.g.,
4444 main::set_access('format', \%format, 'r', 'p_s');
4447 # All arguments are key => value pairs, which you can see below, most
4448 # of which match fields documented above. Otherwise: Pod_Entry,
4449 # Externally_Ok, and Fuzzy apply to the names of the table, and are
4450 # documented in the Alias package
4452 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
4456 my $self = bless \do { my $anonymous_scalar }, $class;
4457 my $addr = do { no overloading; pack 'J', $self; };
4461 $name{$addr} = delete $args{'Name'};
4462 $find_table_from_alias{$addr} = delete $args{'_Alias_Hash'};
4463 $full_name{$addr} = delete $args{'Full_Name'};
4464 my $complete_name = $complete_name{$addr}
4465 = delete $args{'Complete_Name'};
4466 $format{$addr} = delete $args{'Format'};
4467 $internal_only{$addr} = delete $args{'Internal_Only_Warning'} || 0;
4468 $output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
4469 $property{$addr} = delete $args{'_Property'};
4470 $range_list{$addr} = delete $args{'_Range_List'};
4471 $status{$addr} = delete $args{'Status'} || $NORMAL;
4472 $status_info{$addr} = delete $args{'_Status_Info'} || "";
4473 $range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
4474 $caseless_equivalent{$addr} = delete $args{'Caseless_Equivalent'} || 0;
4476 my $description = delete $args{'Description'};
4477 my $externally_ok = delete $args{'Externally_Ok'};
4478 my $loose_match = delete $args{'Fuzzy'};
4479 my $note = delete $args{'Note'};
4480 my $make_pod_entry = delete $args{'Pod_Entry'};
4481 my $perl_extension = delete $args{'Perl_Extension'};
4483 # Shouldn't have any left over
4484 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4486 # Can't use || above because conceivably the name could be 0, and
4487 # can't use // operator in case this program gets used in Perl 5.8
4488 $full_name{$addr} = $name{$addr} if ! defined $full_name{$addr};
4489 $output_range_counts{$addr} = $output_range_counts if
4490 ! defined $output_range_counts{$addr};
4492 $aliases{$addr} = [ ];
4493 $comment{$addr} = [ ];
4494 $description{$addr} = [ ];
4496 $file_path{$addr} = [ ];
4497 $locked{$addr} = "";
4499 push @{$description{$addr}}, $description if $description;
4500 push @{$note{$addr}}, $note if $note;
4502 if ($status{$addr} eq $PLACEHOLDER) {
4504 # A placeholder table doesn't get documented, is a perl extension,
4505 # and quite likely will be empty
4506 $make_pod_entry = 0 if ! defined $make_pod_entry;
4507 $perl_extension = 1 if ! defined $perl_extension;
4508 push @tables_that_may_be_empty, $complete_name{$addr};
4510 elsif (! $status{$addr}) {
4512 # If hasn't set its status already, see if it is on one of the
4513 # lists of properties or tables that have particular statuses; if
4514 # not, is normal. The lists are prioritized so the most serious
4515 # ones are checked first
4516 if (exists $why_suppressed{$complete_name}
4517 # Don't suppress if overridden
4518 && ! grep { $_ eq $complete_name{$addr} }
4519 @output_mapped_properties)
4521 $status{$addr} = $SUPPRESSED;
4523 elsif (exists $why_deprecated{$complete_name}) {
4524 $status{$addr} = $DEPRECATED;
4526 elsif (exists $why_stabilized{$complete_name}) {
4527 $status{$addr} = $STABILIZED;
4529 elsif (exists $why_obsolete{$complete_name}) {
4530 $status{$addr} = $OBSOLETE;
4533 # Existence above doesn't necessarily mean there is a message
4534 # associated with it. Use the most serious message.
4535 if ($status{$addr}) {
4536 if ($why_suppressed{$complete_name}) {
4538 = $why_suppressed{$complete_name};
4540 elsif ($why_deprecated{$complete_name}) {
4542 = $why_deprecated{$complete_name};
4544 elsif ($why_stabilized{$complete_name}) {
4546 = $why_stabilized{$complete_name};
4548 elsif ($why_obsolete{$complete_name}) {
4550 = $why_obsolete{$complete_name};
4555 $perl_extension{$addr} = $perl_extension || 0;
4557 # By convention what typically gets printed only or first is what's
4558 # first in the list, so put the full name there for good output
4559 # clarity. Other routines rely on the full name being first on the
4561 $self->add_alias($full_name{$addr},
4562 Externally_Ok => $externally_ok,
4563 Fuzzy => $loose_match,
4564 Pod_Entry => $make_pod_entry,
4565 Status => $status{$addr},
4568 # Then comes the other name, if meaningfully different.
4569 if (standardize($full_name{$addr}) ne standardize($name{$addr})) {
4570 $self->add_alias($name{$addr},
4571 Externally_Ok => $externally_ok,
4572 Fuzzy => $loose_match,
4573 Pod_Entry => $make_pod_entry,
4574 Status => $status{$addr},
4581 # Here are the methods that are required to be defined by any derived
4584 handle_special_range
4588 # write() knows how to write out normal ranges, but it calls
4589 # handle_special_range() when it encounters a non-normal one.
4590 # append_to_body() is called by it after it has handled all
4591 # ranges to add anything after the main portion of the table.
4592 # And finally, pre_body() is called after all this to build up
4593 # anything that should appear before the main portion of the
4594 # table. Doing it this way allows things in the middle to
4595 # affect what should appear before the main portion of the
4600 Carp::my_carp_bug( __LINE__
4601 . ": Must create method '$sub()' for "
4609 "." => \&main::_operator_dot,
4610 '!=' => \&main::_operator_not_equal,
4611 '==' => \&main::_operator_equal,
4615 # Returns the array of ranges associated with this table.
4618 return $range_list{pack 'J', shift}->ranges;
4622 # Add a synonym for this table.
4624 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
4627 my $name = shift; # The name to add.
4628 my $pointer = shift; # What the alias hash should point to. For
4629 # map tables, this is the parent property;
4630 # for match tables, it is the table itself.
4633 my $loose_match = delete $args{'Fuzzy'};
4635 my $make_pod_entry = delete $args{'Pod_Entry'};
4636 $make_pod_entry = $YES unless defined $make_pod_entry;
4638 my $externally_ok = delete $args{'Externally_Ok'};
4639 $externally_ok = 1 unless defined $externally_ok;
4641 my $status = delete $args{'Status'};
4642 $status = $NORMAL unless defined $status;
4644 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4646 # Capitalize the first letter of the alias unless it is one of the CJK
4647 # ones which specifically begins with a lower 'k'. Do this because
4648 # Unicode has varied whether they capitalize first letters or not, and
4649 # have later changed their minds and capitalized them, but not the
4650 # other way around. So do it always and avoid changes from release to
4652 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
4654 my $addr = do { no overloading; pack 'J', $self; };
4656 # Figure out if should be loosely matched if not already specified.
4657 if (! defined $loose_match) {
4659 # Is a loose_match if isn't null, and doesn't begin with an
4660 # underscore and isn't just a number
4662 && substr($name, 0, 1) ne '_'
4663 && $name !~ qr{^[0-9_.+-/]+$})
4672 # If this alias has already been defined, do nothing.
4673 return if defined $find_table_from_alias{$addr}->{$name};
4675 # That includes if it is standardly equivalent to an existing alias,
4676 # in which case, add this name to the list, so won't have to search
4678 my $standard_name = main::standardize($name);
4679 if (defined $find_table_from_alias{$addr}->{$standard_name}) {
4680 $find_table_from_alias{$addr}->{$name}
4681 = $find_table_from_alias{$addr}->{$standard_name};
4685 # Set the index hash for this alias for future quick reference.
4686 $find_table_from_alias{$addr}->{$name} = $pointer;
4687 $find_table_from_alias{$addr}->{$standard_name} = $pointer;
4688 local $to_trace = 0 if main::DEBUG;
4689 trace "adding alias $name to $pointer" if main::DEBUG && $to_trace;
4690 trace "adding alias $standard_name to $pointer" if main::DEBUG && $to_trace;
4693 # Put the new alias at the end of the list of aliases unless the final
4694 # element begins with an underscore (meaning it is for internal perl
4695 # use) or is all numeric, in which case, put the new one before that
4696 # one. This floats any all-numeric or underscore-beginning aliases to
4697 # the end. This is done so that they are listed last in output lists,
4698 # to encourage the user to use a better name (either more descriptive
4699 # or not an internal-only one) instead. This ordering is relied on
4700 # implicitly elsewhere in this program, like in short_name()
4701 my $list = $aliases{$addr};
4702 my $insert_position = (@$list == 0
4703 || (substr($list->[-1]->name, 0, 1) ne '_'
4704 && $list->[-1]->name =~ /\D/))
4710 Alias->new($name, $loose_match, $make_pod_entry,
4711 $externally_ok, $status);
4713 # This name may be shorter than any existing ones, so clear the cache
4714 # of the shortest, so will have to be recalculated.
4716 undef $short_name{pack 'J', $self};
4721 # Returns a name suitable for use as the base part of a file name.
4722 # That is, shorter wins. It can return undef if there is no suitable
4723 # name. The name has all non-essential underscores removed.
4725 # The optional second parameter is a reference to a scalar in which
4726 # this routine will store the length the returned name had before the
4727 # underscores were removed, or undef if the return is undef.
4729 # The shortest name can change if new aliases are added. So using
4730 # this should be deferred until after all these are added. The code
4731 # that does that should clear this one's cache.
4732 # Any name with alphabetics is preferred over an all numeric one, even
4736 my $nominal_length_ptr = shift;
4737 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4739 my $addr = do { no overloading; pack 'J', $self; };
4741 # For efficiency, don't recalculate, but this means that adding new
4742 # aliases could change what the shortest is, so the code that does
4743 # that needs to undef this.
4744 if (defined $short_name{$addr}) {
4745 if ($nominal_length_ptr) {
4746 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4748 return $short_name{$addr};
4751 # Look at each alias
4752 foreach my $alias ($self->aliases()) {
4754 # Don't use an alias that isn't ok to use for an external name.
4755 next if ! $alias->externally_ok;
4757 my $name = main::Standardize($alias->name);
4758 trace $self, $name if main::DEBUG && $to_trace;
4760 # Take the first one, or a shorter one that isn't numeric. This
4761 # relies on numeric aliases always being last in the array
4762 # returned by aliases(). Any alpha one will have precedence.
4763 if (! defined $short_name{$addr}
4765 && length($name) < length($short_name{$addr})))
4767 # Remove interior underscores.
4768 ($short_name{$addr} = $name) =~ s/ (?<= . ) _ (?= . ) //xg;
4770 $nominal_short_name_length{$addr} = length $name;
4774 # If no suitable external name return undef
4775 if (! defined $short_name{$addr}) {
4776 $$nominal_length_ptr = undef if $nominal_length_ptr;
4780 # Don't allow a null external name.
4781 if ($short_name{$addr} eq "") {
4782 $short_name{$addr} = '_';
4783 $nominal_short_name_length{$addr} = 1;
4786 trace $self, $short_name{$addr} if main::DEBUG && $to_trace;
4788 if ($nominal_length_ptr) {
4789 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4791 return $short_name{$addr};
4795 # Returns the external name that this table should be known by. This
4796 # is usually the short_name, but not if the short_name is undefined.
4799 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4801 my $short = $self->short_name;
4802 return $short if defined $short;
4807 sub add_description { # Adds the parameter as a short description.
4810 my $description = shift;
4812 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4815 push @{$description{pack 'J', $self}}, $description;
4820 sub add_note { # Adds the parameter as a short note.
4825 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4828 push @{$note{pack 'J', $self}}, $note;
4833 sub add_comment { # Adds the parameter as a comment.
4835 return unless $debugging_build;
4838 my $comment = shift;
4839 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4844 push @{$comment{pack 'J', $self}}, $comment;
4850 # Return the current comment for this table. If called in list
4851 # context, returns the array of comments. In scalar, returns a string
4852 # of each element joined together with a period ending each.
4855 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4857 my $addr = do { no overloading; pack 'J', $self; };
4858 my @list = @{$comment{$addr}};
4859 return @list if wantarray;
4861 foreach my $sentence (@list) {
4862 $return .= '. ' if $return;
4863 $return .= $sentence;
4866 $return .= '.' if $return;
4871 # Initialize the table with the argument which is any valid
4872 # initialization for range lists.
4875 my $addr = do { no overloading; pack 'J', $self; };
4876 my $initialization = shift;
4877 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4879 # Replace the current range list with a new one of the same exact
4881 my $class = ref $range_list{$addr};
4882 $range_list{$addr} = $class->new(Owner => $self,
4883 Initialize => $initialization);
4889 # The header that is output for the table in the file it is written
4893 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4896 $return .= $DEVELOPMENT_ONLY if $compare_versions;
4899 $return .= $INTERNAL_ONLY if $internal_only{pack 'J', $self};
4904 # Write a representation of the table to its file. It calls several
4905 # functions furnished by sub-classes of this abstract base class to
4906 # handle non-normal ranges, to add stuff before the table, and at its
4910 my $tab_stops = shift; # The number of tab stops over to put any
4912 my $suppress_value = shift; # Optional, if the value associated with
4913 # a range equals this one, don't write
4915 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4917 my $addr = do { no overloading; pack 'J', $self; };
4919 # Start with the header
4920 my @HEADER = $self->header;
4923 push @HEADER, "\n", main::simple_fold($comment{$addr}, '# '), "\n"
4926 # Things discovered processing the main body of the document may
4927 # affect what gets output before it, therefore pre_body() isn't called
4928 # until after all other processing of the table is done.
4930 # The main body looks like a 'here' document. If annotating, get rid
4931 # of the comments before passing to the caller, as some callers, such
4932 # as charnames.pm, can't cope with them. (Outputting range counts
4933 # also introduces comments, but these don't show up in the tables that
4934 # can't cope with comments, and there aren't that many of them that
4935 # it's worth the extra real time to get rid of them).
4938 # Use the line below in Perls that don't have /r
4939 #push @OUT, 'return join "\n", map { s/\s*#.*//mg; $_ } split "\n", <<\'END\';' . "\n";
4940 push @OUT, "return <<'END' =~ s/\\s*#.*//mgr;\n";
4942 push @OUT, "return <<'END';\n";
4945 if ($range_list{$addr}->is_empty) {
4947 # This is a kludge for empty tables to silence a warning in
4948 # utf8.c, which can't really deal with empty tables, but it can
4949 # deal with a table that matches nothing, as the inverse of 'Any'
4951 push @OUT, "!utf8::IsAny\n";
4954 my $range_size_1 = $range_size_1{$addr};
4955 my $format; # Used only in $annotate option
4956 my $include_name; # Used only in $annotate option
4960 # if annotating each code point, must print 1 per line.
4961 # The variable could point to a subroutine, and we don't want
4962 # to lose that fact, so only set if not set already
4963 $range_size_1 = 1 if ! $range_size_1;
4965 $format = $self->format;
4967 # The name of the character is output only for tables that
4968 # don't already include the name in the output.
4969 my $property = $self->property;
4971 ! ($property == $perl_charname
4972 || $property == main::property_ref('Unicode_1_Name')
4973 || $property == main::property_ref('Name')
4974 || $property == main::property_ref('Name_Alias')
4978 # Output each range as part of the here document.
4980 for my $set ($range_list{$addr}->ranges) {
4981 if ($set->type != 0) {
4982 $self->handle_special_range($set);
4985 my $start = $set->start;
4986 my $end = $set->end;
4987 my $value = $set->value;
4989 # Don't output ranges whose value is the one to suppress
4990 next RANGE if defined $suppress_value
4991 && $value eq $suppress_value;
4993 # If there is a range and doesn't need a single point range
4995 if ($start != $end && ! $range_size_1) {
4996 push @OUT, sprintf "%04X\t%04X", $start, $end;
4997 $OUT[-1] .= "\t$value" if $value ne "";
4999 # Add a comment with the size of the range, if requested.
5000 # Expand Tabs to make sure they all start in the same
5001 # column, and then unexpand to use mostly tabs.
5002 if (! $output_range_counts{$addr}) {
5006 $OUT[-1] = Text::Tabs::expand($OUT[-1]);
5007 my $count = main::clarify_number($end - $start + 1);
5010 my $width = $tab_stops * 8 - 1;
5011 $OUT[-1] = sprintf("%-*s # [%s]\n",
5015 $OUT[-1] = Text::Tabs::unexpand($OUT[-1]);
5020 # Here to output a single code point per line
5022 # If not to annotate, use the simple formats
5025 # Use any passed in subroutine to output.
5026 if (ref $range_size_1 eq 'CODE') {
5027 for my $i ($start .. $end) {
5028 push @OUT, &{$range_size_1}($i, $value);
5033 # Here, caller is ok with default output.
5034 for (my $i = $start; $i <= $end; $i++) {
5035 push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
5041 # Here, wants annotation.
5042 for (my $i = $start; $i <= $end; $i++) {
5044 # Get character information if don't have it already
5045 main::populate_char_info($i)
5046 if ! defined $viacode[$i];
5047 my $type = $annotate_char_type[$i];
5049 # Figure out if should output the next code points as part
5050 # of a range or not. If this is not in an annotation
5051 # range, then won't output as a range, so returns $i.
5052 # Otherwise use the end of the annotation range, but no
5053 # further than the maximum possible end point of the loop.
5054 my $range_end = main::min($annotate_ranges->value_of($i)
5058 # Use a range if it is a range, and either is one of the
5059 # special annotation ranges, or the range is at most 3
5060 # long. This last case causes the algorithmically named
5061 # code points to be output individually in spans of at
5062 # most 3, as they are the ones whose $type is > 0.
5063 if ($range_end != $i
5064 && ( $type < 0 || $range_end - $i > 2))
5066 # Here is to output a range. We don't allow a
5067 # caller-specified output format--just use the
5069 push @OUT, sprintf "%04X\t%04X\t%s\t#", $i,
5072 my $range_name = $viacode[$i];
5074 # For the code points which end in their hex value, we
5075 # eliminate that from the output annotation, and
5076 # capitalize only the first letter of each word.
5077 if ($type == $CP_IN_NAME) {
5078 my $hex = sprintf "%04X", $i;
5079 $range_name =~ s/-$hex$//;
5080 my @words = split " ", $range_name;
5081 for my $word (@words) {
5082 $word = ucfirst(lc($word)) if $word ne 'CJK';
5084 $range_name = join " ", @words;
5086 elsif ($type == $HANGUL_SYLLABLE) {
5087 $range_name = "Hangul Syllable";
5090 $OUT[-1] .= " $range_name" if $range_name;
5092 # Include the number of code points in the range
5093 my $count = main::clarify_number($range_end - $i + 1);
5094 $OUT[-1] .= " [$count]\n";
5096 # Skip to the end of the range
5099 else { # Not in a range.
5102 # When outputting the names of each character, use
5103 # the character itself if printable
5104 $comment .= "'" . chr($i) . "' " if $printable[$i];
5106 # To make it more readable, use a minimum indentation
5109 # Determine the annotation
5110 if ($format eq $DECOMP_STRING_FORMAT) {
5112 # This is very specialized, with the type of
5113 # decomposition beginning the line enclosed in
5114 # <...>, and the code points that the code point
5115 # decomposes to separated by blanks. Create two
5116 # strings, one of the printable characters, and
5117 # one of their official names.
5118 (my $map = $value) =~ s/ \ * < .*? > \ +//x;
5122 foreach my $to (split " ", $map) {
5123 $to = CORE::hex $to;
5124 $to_name .= " + " if $to_name;
5125 $to_chr .= chr($to);
5126 main::populate_char_info($to)
5127 if ! defined $viacode[$to];
5128 $to_name .= $viacode[$to];
5132 "=> '$to_chr'; $viacode[$i] => $to_name";
5133 $comment_indent = 25; # Determined by experiment
5137 # Assume that any table that has hex format is a
5138 # mapping of one code point to another.
5139 if ($format eq $HEX_FORMAT) {
5140 my $decimal_value = CORE::hex $value;
5141 main::populate_char_info($decimal_value)
5142 if ! defined $viacode[$decimal_value];
5144 . chr($decimal_value)
5145 . "'; " if $printable[$decimal_value];
5147 $comment .= $viacode[$i] if $include_name
5149 if ($format eq $HEX_FORMAT) {
5150 my $decimal_value = CORE::hex $value;
5151 $comment .= " => $viacode[$decimal_value]"
5152 if $viacode[$decimal_value];
5155 # If including the name, no need to indent, as the
5156 # name will already be way across the line.
5157 $comment_indent = ($include_name) ? 0 : 60;
5160 # Use any passed in routine to output the base part of
5162 if (ref $range_size_1 eq 'CODE') {
5163 my $base_part = &{$range_size_1}($i, $value);
5165 push @OUT, $base_part;
5168 push @OUT, sprintf "%04X\t\t%s", $i, $value;
5171 # And add the annotation.
5172 $OUT[-1] = sprintf "%-*s\t# %s", $comment_indent,
5174 $comment if $comment;
5178 } # End of loop through all the table's ranges
5181 # Add anything that goes after the main body, but within the here
5183 my $append_to_body = $self->append_to_body;
5184 push @OUT, $append_to_body if $append_to_body;
5186 # And finish the here document.
5189 # Done with the main portion of the body. Can now figure out what
5190 # should appear before it in the file.
5191 my $pre_body = $self->pre_body;
5192 push @HEADER, $pre_body, "\n" if $pre_body;
5194 # All these files have a .pl suffix
5195 $file_path{$addr}->[-1] .= '.pl';
5197 main::write($file_path{$addr},
5198 $annotate, # utf8 iff annotating
5204 sub set_status { # Set the table's status
5206 my $status = shift; # The status enum value
5207 my $info = shift; # Any message associated with it.
5208 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5210 my $addr = do { no overloading; pack 'J', $self; };
5212 $status{$addr} = $status;
5213 $status_info{$addr} = $info;
5218 # Don't allow changes to the table from now on. This stores a stack
5219 # trace of where it was called, so that later attempts to modify it
5220 # can immediately show where it got locked.
5223 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5225 my $addr = do { no overloading; pack 'J', $self; };
5227 $locked{$addr} = "";
5229 my $line = (caller(0))[2];
5232 # Accumulate the stack trace
5234 my ($pkg, $file, $caller_line, $caller) = caller $i++;
5236 last unless defined $caller;
5238 $locked{$addr} .= " called from $caller() at line $line\n";
5239 $line = $caller_line;
5241 $locked{$addr} .= " called from main at line $line\n";
5246 sub carp_if_locked {
5247 # Return whether a table is locked or not, and, by the way, complain
5251 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5253 my $addr = do { no overloading; pack 'J', $self; };
5255 return 0 if ! $locked{$addr};
5256 Carp::my_carp_bug("Can't modify a locked table. Stack trace of locking:\n$locked{$addr}\n\n");
5260 sub set_file_path { # Set the final directory path for this table
5262 # Rest of parameters passed on
5265 @{$file_path{pack 'J', $self}} = @_;
5269 # Accessors for the range list stored in this table. First for
5278 matches_identically_to
5292 return $range_list{pack 'J', $self}->$sub(@_);
5296 # Then for ones that should fail if locked
5306 return if $self->carp_if_locked;
5308 return $range_list{pack 'J', $self}->$sub(@_);
5315 use base '_Base_Table';
5317 # A Map Table is a table that contains the mappings from code points to
5318 # values. There are two weird cases:
5319 # 1) Anomalous entries are ones that aren't maps of ranges of code points, but
5320 # are written in the table's file at the end of the table nonetheless. It
5321 # requires specially constructed code to handle these; utf8.c can not read
5322 # these in, so they should not go in $map_directory. As of this writing,
5323 # the only case that these happen is for named sequences used in
5324 # charnames.pm. But this code doesn't enforce any syntax on these, so
5325 # something else could come along that uses it.
5326 # 2) Specials are anything that doesn't fit syntactically into the body of the
5327 # table. The ranges for these have a map type of non-zero. The code below
5328 # knows about and handles each possible type. In most cases, these are
5329 # written as part of the header.
5331 # A map table deliberately can't be manipulated at will unlike match tables.
5332 # This is because of the ambiguities having to do with what to do with
5333 # overlapping code points. And there just isn't a need for those things;
5334 # what one wants to do is just query, add, replace, or delete mappings, plus
5335 # write the final result.
5336 # However, there is a method to get the list of possible ranges that aren't in
5337 # this table to use for defaulting missing code point mappings. And,
5338 # map_add_or_replace_non_nulls() does allow one to add another table to this
5339 # one, but it is clearly very specialized, and defined that the other's
5340 # non-null values replace this one's if there is any overlap.
5342 sub trace { return main::trace(@_); }
5346 main::setup_package();
5349 # Many input files omit some entries; this gives what the mapping for the
5350 # missing entries should be
5351 main::set_access('default_map', \%default_map, 'r');
5353 my %anomalous_entries;
5354 # Things that go in the body of the table which don't fit the normal
5355 # scheme of things, like having a range. Not much can be done with these
5356 # once there except to output them. This was created to handle named
5358 main::set_access('anomalous_entry', \%anomalous_entries, 'a');
5359 main::set_access('anomalous_entries', # Append singular, read plural
5360 \%anomalous_entries,
5364 # This is a string, solely for documentation, indicating how one can get
5365 # access to this property via the Perl core.
5366 main::set_access('core_access', \%core_access, 'r', 's');
5369 # Boolean as to whether or not to write out this map table
5370 main::set_access('to_output_map', \%to_output_map, 's');
5379 # Optional initialization data for the table.
5380 my $initialize = delete $args{'Initialize'};
5382 my $core_access = delete $args{'Core_Access'};
5383 my $default_map = delete $args{'Default_Map'};
5384 my $property = delete $args{'_Property'};
5385 my $full_name = delete $args{'Full_Name'};
5386 # Rest of parameters passed on
5388 my $range_list = Range_Map->new(Owner => $property);
5390 my $self = $class->SUPER::new(
5392 Complete_Name => $full_name,
5393 Full_Name => $full_name,
5394 _Property => $property,
5395 _Range_List => $range_list,
5398 my $addr = do { no overloading; pack 'J', $self; };
5400 $anomalous_entries{$addr} = [];
5401 $core_access{$addr} = $core_access;
5402 $default_map{$addr} = $default_map;
5404 $self->initialize($initialize) if defined $initialize;
5411 qw("") => "_operator_stringify",
5414 sub _operator_stringify {
5417 my $name = $self->property->full_name;
5418 $name = '""' if $name eq "";
5419 return "Map table for Property '$name'";
5423 # Add a synonym for this table (which means the property itself)
5426 # Rest of parameters passed on.
5428 $self->SUPER::add_alias($name, $self->property, @_);
5433 # Add a range of code points to the list of specially-handled code
5434 # points. $MULTI_CP is assumed if the type of special is not passed
5443 my $type = delete $args{'Type'} || 0;
5444 # Rest of parameters passed on
5446 # Can't change the table if locked.
5447 return if $self->carp_if_locked;
5449 my $addr = do { no overloading; pack 'J', $self; };
5451 $self->_range_list->add_map($lower, $upper,
5458 sub append_to_body {
5459 # Adds to the written HERE document of the table's body any anomalous
5460 # entries in the table..
5463 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5465 my $addr = do { no overloading; pack 'J', $self; };
5467 return "" unless @{$anomalous_entries{$addr}};
5468 return join("\n", @{$anomalous_entries{$addr}}) . "\n";
5471 sub map_add_or_replace_non_nulls {
5472 # This adds the mappings in the table $other to $self. Non-null
5473 # mappings from $other override those in $self. It essentially merges
5474 # the two tables, with the second having priority except for null
5479 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5481 return if $self->carp_if_locked;
5483 if (! $other->isa(__PACKAGE__)) {
5484 Carp::my_carp_bug("$other should be a "
5492 my $addr = do { no overloading; pack 'J', $self; };
5493 my $other_addr = do { no overloading; pack 'J', $other; };
5495 local $to_trace = 0 if main::DEBUG;
5497 my $self_range_list = $self->_range_list;
5498 my $other_range_list = $other->_range_list;
5499 foreach my $range ($other_range_list->ranges) {
5500 my $value = $range->value;
5501 next if $value eq "";
5502 $self_range_list->_add_delete('+',
5506 Type => $range->type,
5507 Replace => $UNCONDITIONALLY);
5513 sub set_default_map {
5514 # Define what code points that are missing from the input files should
5519 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5521 my $addr = do { no overloading; pack 'J', $self; };
5523 # Convert the input to the standard equivalent, if any (won't have any
5524 # for $STRING properties)
5525 my $standard = $self->_find_table_from_alias->{$map};
5526 $map = $standard->name if defined $standard;
5528 # Warn if there already is a non-equivalent default map for this
5529 # property. Note that a default map can be a ref, which means that
5530 # what it actually means is delayed until later in the program, and it
5531 # IS permissible to override it here without a message.
5532 my $default_map = $default_map{$addr};
5533 if (defined $default_map
5534 && ! ref($default_map)
5535 && $default_map ne $map
5536 && main::Standardize($map) ne $default_map)
5538 my $property = $self->property;
5539 my $map_table = $property->table($map);
5540 my $default_table = $property->table($default_map);
5541 if (defined $map_table
5542 && defined $default_table
5543 && $map_table != $default_table)
5545 Carp::my_carp("Changing the default mapping for "
5547 . " from $default_map to $map'");
5551 $default_map{$addr} = $map;
5553 # Don't also create any missing table for this map at this point,
5554 # because if we did, it could get done before the main table add is
5555 # done for PropValueAliases.txt; instead the caller will have to make
5556 # sure it exists, if desired.
5561 # Returns boolean: should we write this map table?
5564 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5566 my $addr = do { no overloading; pack 'J', $self; };
5568 # If overridden, use that
5569 return $to_output_map{$addr} if defined $to_output_map{$addr};
5571 my $full_name = $self->full_name;
5573 # If table says to output, do so; if says to suppress it, do do.
5574 return 1 if grep { $_ eq $full_name } @output_mapped_properties;
5575 return 0 if $self->status eq $SUPPRESSED;
5577 my $type = $self->property->type;
5579 # Don't want to output binary map tables even for debugging.
5580 return 0 if $type == $BINARY;
5582 # But do want to output string ones.
5583 return 1 if $type == $STRING;
5585 # Otherwise is an $ENUM, don't output it
5590 # Returns a Range_List that is gaps of the current table. That is,
5594 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5596 my $current = Range_List->new(Initialize => $self->_range_list,
5597 Owner => $self->property);
5601 sub set_final_comment {
5602 # Just before output, create the comment that heads the file
5603 # containing this table.
5605 return unless $debugging_build;
5608 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5610 # No sense generating a comment if aren't going to write it out.
5611 return if ! $self->to_output_map;
5613 my $addr = do { no overloading; pack 'J', $self; };
5615 my $property = $self->property;
5617 # Get all the possible names for this property. Don't use any that
5618 # aren't ok for use in a file name, etc. This is perhaps causing that
5619 # flag to do double duty, and may have to be changed in the future to
5620 # have our own flag for just this purpose; but it works now to exclude
5621 # Perl generated synonyms from the lists for properties, where the
5622 # name is always the proper Unicode one.
5623 my @property_aliases = grep { $_->externally_ok } $self->aliases;
5625 my $count = $self->count;
5626 my $default_map = $default_map{$addr};
5628 # The ranges that map to the default aren't output, so subtract that
5629 # to get those actually output. A property with matching tables
5630 # already has the information calculated.
5631 if ($property->type != $STRING) {
5632 $count -= $property->table($default_map)->count;
5634 elsif (defined $default_map) {
5636 # But for $STRING properties, must calculate now. Subtract the
5637 # count from each range that maps to the default.
5638 foreach my $range ($self->_range_list->ranges) {
5639 if ($range->value eq $default_map) {
5640 $count -= $range->end +1 - $range->start;
5646 # Get a string version of $count with underscores in large numbers,
5648 my $string_count = main::clarify_number($count);
5650 my $code_points = ($count == 1)
5651 ? 'single code point'
5652 : "$string_count code points";
5657 if (@property_aliases <= 1) {
5658 $mapping = 'mapping';
5659 $these_mappings = 'this mapping';
5663 $mapping = 'synonymous mappings';
5664 $these_mappings = 'these mappings';
5668 if ($count >= $MAX_UNICODE_CODEPOINTS) {
5669 $cp = "any code point in Unicode Version $string_version";
5673 if ($default_map eq "") {
5674 $map_to = 'the null string';
5676 elsif ($default_map eq $CODE_POINT) {
5680 $map_to = "'$default_map'";
5683 $cp = "the single code point";
5686 $cp = "one of the $code_points";
5688 $cp .= " in Unicode Version $string_version for which the mapping is not to $map_to";
5693 my $status = $self->status;
5695 my $warn = uc $status_past_participles{$status};
5698 !!!!!!! $warn !!!!!!!!!!!!!!!!!!!
5699 All property or property=value combinations contained in this file are $warn.
5700 See $unicode_reference_url for what this means.
5704 $comment .= "This file returns the $mapping:\n";
5706 for my $i (0 .. @property_aliases - 1) {
5707 $comment .= sprintf("%-8s%s\n",
5709 $property_aliases[$i]->name . '(cp)'
5713 "\nwhere 'cp' is $cp. Note that $these_mappings $are ";
5715 my $access = $core_access{$addr};
5717 $comment .= "accessible through the Perl core via $access.";
5720 $comment .= "not accessible through the Perl core directly.";
5723 # And append any commentary already set from the actual property.
5724 $comment .= "\n\n" . $self->comment if $self->comment;
5725 if ($self->description) {
5726 $comment .= "\n\n" . join " ", $self->description;
5729 $comment .= "\n\n" . join " ", $self->note;
5733 if (! $self->perl_extension) {
5736 For information about what this property really means, see:
5737 $unicode_reference_url
5741 if ($count) { # Format differs for empty table
5742 $comment.= "\nThe format of the ";
5743 if ($self->range_size_1) {
5745 main body of lines of this file is: CODE_POINT\\t\\tMAPPING where CODE_POINT
5746 is in hex; MAPPING is what CODE_POINT maps to.
5751 # There are tables which end up only having one element per
5752 # range, but it is not worth keeping track of for making just
5753 # this comment a little better.
5755 non-comment portions of the main body of lines of this file is:
5756 START\\tSTOP\\tMAPPING where START is the starting code point of the
5757 range, in hex; STOP is the ending point, or if omitted, the range has just one
5758 code point; MAPPING is what each code point between START and STOP maps to.
5760 if ($self->output_range_counts) {
5762 Numbers in comments in [brackets] indicate how many code points are in the
5763 range (omitted when the range is a single code point or if the mapping is to
5769 $self->set_comment(main::join_lines($comment));
5773 my %swash_keys; # Makes sure don't duplicate swash names.
5775 # The remaining variables are temporaries used while writing each table,
5776 # to output special ranges.
5777 my $has_hangul_syllables;
5778 my @multi_code_point_maps; # Map is to more than one code point.
5780 # The key is the base name of the code point, and the value is an
5781 # array giving all the ranges that use this base name. Each range
5782 # is actually a hash giving the 'low' and 'high' values of it.
5783 my %names_ending_in_code_point;
5785 # Inverse mapping. The list of ranges that have these kinds of
5786 # names. Each element contains the low, high, and base names in a
5788 my @code_points_ending_in_code_point;
5790 sub handle_special_range {
5791 # Called in the middle of write when it finds a range it doesn't know
5796 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5798 my $addr = do { no overloading; pack 'J', $self; };
5800 my $type = $range->type;
5802 my $low = $range->start;
5803 my $high = $range->end;
5804 my $map = $range->value;
5806 # No need to output the range if it maps to the default.
5807 return if $map eq $default_map{$addr};
5809 # Switch based on the map type...
5810 if ($type == $HANGUL_SYLLABLE) {
5812 # These are entirely algorithmically determinable based on
5813 # some constants furnished by Unicode; for now, just set a
5814 # flag to indicate that have them. After everything is figured
5815 # out, we will output the code that does the algorithm.
5816 $has_hangul_syllables = 1;
5818 elsif ($type == $CP_IN_NAME) {
5820 # Code points whose the name ends in their code point are also
5821 # algorithmically determinable, but need information about the map
5822 # to do so. Both the map and its inverse are stored in data
5823 # structures output in the file.
5824 push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
5825 push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
5827 push @code_points_ending_in_code_point, { low => $low,
5832 elsif ($range->type == $MULTI_CP || $range->type == $NULL) {
5834 # Multi-code point maps and null string maps have an entry
5835 # for each code point in the range. They use the same
5837 for my $code_point ($low .. $high) {
5839 # The pack() below can't cope with surrogates.
5840 if ($code_point >= 0xD800 && $code_point <= 0xDFFF) {
5841 Carp::my_carp("Surrogate code point '$code_point' in mapping to '$map' in $self. No map created");
5845 # Generate the hash entries for these in the form that
5846 # utf8.c understands.
5850 foreach my $to (split " ", $map) {
5851 if ($to !~ /^$code_point_re$/) {
5852 Carp::my_carp("Illegal code point '$to' in mapping '$map' from $code_point in $self. No map created");
5855 $tostr .= sprintf "\\x{%s}", $to;
5856 $to = CORE::hex $to;
5858 $to_name .= " + " if $to_name;
5859 $to_chr .= chr($to);
5860 main::populate_char_info($to)
5861 if ! defined $viacode[$to];
5862 $to_name .= $viacode[$to];
5866 # I (khw) have never waded through this line to
5867 # understand it well enough to comment it.
5868 my $utf8 = sprintf(qq["%s" => "$tostr",],
5869 join("", map { sprintf "\\x%02X", $_ }
5870 unpack("U0C*", pack("U", $code_point))));
5872 # Add a comment so that a human reader can more easily
5873 # see what's going on.
5874 push @multi_code_point_maps,
5875 sprintf("%-45s # U+%04X", $utf8, $code_point);
5877 $multi_code_point_maps[-1] .= " => $map";
5880 main::populate_char_info($code_point)
5881 if ! defined $viacode[$code_point];
5882 $multi_code_point_maps[-1] .= " '"
5884 . "' => '$to_chr'; $viacode[$code_point] => $to_name";
5889 Carp::my_carp("Unrecognized map type '$range->type' in '$range' in $self. Not written");
5896 # Returns the string that should be output in the file before the main
5897 # body of this table. It isn't called until the main body is
5898 # calculated, saving a pass. The string includes some hash entries
5899 # identifying the format of the body, and what the single value should
5900 # be for all ranges missing from it. It also includes any code points
5901 # which have map_types that don't go in the main table.
5904 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5906 my $addr = do { no overloading; pack 'J', $self; };
5908 my $name = $self->property->swash_name;
5910 if (defined $swash_keys{$name}) {
5911 Carp::my_carp(join_lines(<<END
5912 Already created a swash name '$name' for $swash_keys{$name}. This means that
5913 the same name desired for $self shouldn't be used. Bad News. This must be
5914 fixed before production use, but proceeding anyway
5918 $swash_keys{$name} = "$self";
5922 # Here we assume we were called after have gone through the whole
5923 # file. If we actually generated anything for each map type, add its
5924 # respective header and trailer
5925 if (@multi_code_point_maps) {
5928 # Some code points require special handling because their mappings are each to
5929 # multiple code points. These do not appear in the main body, but are defined
5930 # in the hash below.
5932 # Each key is the string of N bytes that together make up the UTF-8 encoding
5933 # for the code point. (i.e. the same as looking at the code point's UTF-8
5934 # under "use bytes"). Each value is the UTF-8 of the translation, for speed.
5935 %utf8::ToSpec$name = (
5937 $pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
5940 if ($has_hangul_syllables || @code_points_ending_in_code_point) {
5942 # Convert these structures to output format.
5943 my $code_points_ending_in_code_point =
5944 main::simple_dumper(\@code_points_ending_in_code_point,
5946 my $names = main::simple_dumper(\%names_ending_in_code_point,
5949 # Do the same with the Hangul names,
5955 if ($has_hangul_syllables) {
5957 # Construct a regular expression of all the possible
5958 # combinations of the Hangul syllables.
5959 my @L_re; # Leading consonants
5960 for my $i ($LBase .. $LBase + $LCount - 1) {
5961 push @L_re, $Jamo{$i}
5963 my @V_re; # Middle vowels
5964 for my $i ($VBase .. $VBase + $VCount - 1) {
5965 push @V_re, $Jamo{$i}
5967 my @T_re; # Trailing consonants
5968 for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
5969 push @T_re, $Jamo{$i}
5972 # The whole re is made up of the L V T combination.
5974 . join ('|', sort @L_re)
5976 . join ('|', sort @V_re)
5978 . join ('|', sort @T_re)
5981 # These hashes needed by the algorithm were generated
5982 # during reading of the Jamo.txt file
5983 $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
5984 $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
5985 $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
5986 $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
5991 # To achieve significant memory savings when this file is read in,
5992 # algorithmically derivable code points are omitted from the main body below.
5993 # Instead, the following routines can be used to translate between name and
5994 # code point and vice versa
5998 # Matches legal code point. 4-6 hex numbers, If there are 6, the
5999 # first two must be '10'; if there are 5, the first must not be a '0'.
6000 my \$code_point_re = qr/$code_point_re/;
6002 # In the following hash, the keys are the bases of names which includes
6003 # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
6004 # of each key is another hash which is used to get the low and high ends
6005 # for each range of code points that apply to the name
6006 my %names_ending_in_code_point = (
6010 # And the following array gives the inverse mapping from code points to
6011 # names. Lowest code points are first
6012 my \@code_points_ending_in_code_point = (
6013 $code_points_ending_in_code_point
6016 # Earlier releases didn't have Jamos. No sense outputting
6017 # them unless will be used.
6018 if ($has_hangul_syllables) {
6021 # Convert from code point to Jamo short name for use in composing Hangul
6027 # Leading consonant (can be null)
6037 # Optional trailing consonant
6042 # Computed re that splits up a Hangul name into LVT or LV syllables
6043 my \$syllable_re = qr/$jamo_re/;
6045 my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
6046 my \$HANGUL_SYLLABLE_LENGTH = length \$HANGUL_SYLLABLE;
6048 # These constants names and values were taken from the Unicode standard,
6049 # version 5.1, section 3.12. They are used in conjunction with Hangul
6051 my \$SBase = $SBase_string;
6052 my \$LBase = $LBase_string;
6053 my \$VBase = $VBase_string;
6054 my \$TBase = $TBase_string;
6055 my \$SCount = $SCount;
6056 my \$LCount = $LCount;
6057 my \$VCount = $VCount;
6058 my \$TCount = $TCount;
6059 my \$NCount = \$VCount * \$TCount;
6061 } # End of has Jamos
6063 $pre_body .= << 'END';
6065 sub name_to_code_point_special {
6068 # Returns undef if not one of the specially handled names; otherwise
6069 # returns the code point equivalent to the input name
6071 if ($has_hangul_syllables) {
6072 $pre_body .= << 'END';
6074 if (substr($name, 0, $HANGUL_SYLLABLE_LENGTH) eq $HANGUL_SYLLABLE) {
6075 $name = substr($name, $HANGUL_SYLLABLE_LENGTH);
6076 return if $name !~ qr/^$syllable_re$/;
6077 my $L = $Jamo_L{$1};
6078 my $V = $Jamo_V{$2};
6079 my $T = (defined $3) ? $Jamo_T{$3} : 0;
6080 return ($L * $VCount + $V) * $TCount + $T + $SBase;
6084 $pre_body .= << 'END';
6086 # Name must end in '-code_point' for this to handle.
6087 if ($name !~ /^ (.*) - ($code_point_re) $/x) {
6092 my $code_point = CORE::hex $2;
6094 # Name must be one of the ones which has the code point in it.
6095 return if ! $names_ending_in_code_point{$base};
6097 # Look through the list of ranges that apply to this name to see if
6098 # the code point is in one of them.
6099 for (my $i = 0; $i < scalar @{$names_ending_in_code_point{$base}{'low'}}; $i++) {
6100 return if $names_ending_in_code_point{$base}{'low'}->[$i] > $code_point;
6101 next if $names_ending_in_code_point{$base}{'high'}->[$i] < $code_point;
6103 # Here, the code point is in the range.
6107 # Here, looked like the name had a code point number in it, but
6108 # did not match one of the valid ones.
6112 sub code_point_to_name_special {
6113 my $code_point = shift;
6115 # Returns the name of a code point if algorithmically determinable;
6118 if ($has_hangul_syllables) {
6119 $pre_body .= << 'END';
6121 # If in the Hangul range, calculate the name based on Unicode's
6123 if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
6125 my $SIndex = $code_point - $SBase;
6126 my $L = $LBase + $SIndex / $NCount;
6127 my $V = $VBase + ($SIndex % $NCount) / $TCount;
6128 my $T = $TBase + $SIndex % $TCount;
6129 $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
6130 $name .= $Jamo{$T} if $T != $TBase;
6135 $pre_body .= << 'END';
6137 # Look through list of these code points for one in range.
6138 foreach my $hash (@code_points_ending_in_code_point) {
6139 return if $code_point < $hash->{'low'};
6140 if ($code_point <= $hash->{'high'}) {
6141 return sprintf("%s-%04X", $hash->{'name'}, $code_point);
6144 return; # None found
6149 } # End of has hangul or code point in name maps.
6151 my $format = $self->format;
6154 # The name this swash is to be known by, with the format of the mappings in
6155 # the main body of the table, and what all code points missing from this file
6157 \$utf8::SwashInfo{'To$name'}{'format'} = '$format'; # $map_table_formats{$format}
6159 my $default_map = $default_map{$addr};
6160 $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '$default_map';";
6162 if ($default_map eq $CODE_POINT) {
6163 $return .= ' # code point maps to itself';
6165 elsif ($default_map eq "") {
6166 $return .= ' # code point maps to the null string';
6170 $return .= $pre_body;
6176 # Write the table to the file.
6179 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6181 my $addr = do { no overloading; pack 'J', $self; };
6183 # Clear the temporaries
6184 $has_hangul_syllables = 0;
6185 undef @multi_code_point_maps;
6186 undef %names_ending_in_code_point;
6187 undef @code_points_ending_in_code_point;
6189 # Calculate the format of the table if not already done.
6190 my $format = $self->format;
6191 my $type = $self->property->type;
6192 my $default_map = $self->default_map;
6193 if (! defined $format) {
6194 if ($type == $BINARY) {
6196 # Don't bother checking the values, because we elsewhere
6197 # verify that a binary table has only 2 values.
6198 $format = $BINARY_FORMAT;
6201 my @ranges = $self->_range_list->ranges;
6203 # default an empty table based on its type and default map
6206 # But it turns out that the only one we can say is a
6207 # non-string (besides binary, handled above) is when the
6208 # table is a string and the default map is to a code point
6209 if ($type == $STRING && $default_map eq $CODE_POINT) {
6210 $format = $HEX_FORMAT;
6213 $format = $STRING_FORMAT;
6218 # Start with the most restrictive format, and as we find
6219 # something that doesn't fit with that, change to the next
6220 # most restrictive, and so on.
6221 $format = $DECIMAL_FORMAT;
6222 foreach my $range (@ranges) {
6223 next if $range->type != 0; # Non-normal ranges don't
6224 # affect the main body
6225 my $map = $range->value;
6226 if ($map ne $default_map) {
6227 last if $format eq $STRING_FORMAT; # already at
6230 $format = $INTEGER_FORMAT
6231 if $format eq $DECIMAL_FORMAT
6232 && $map !~ / ^ [0-9] $ /x;
6233 $format = $FLOAT_FORMAT
6234 if $format eq $INTEGER_FORMAT
6235 && $map !~ / ^ -? [0-9]+ $ /x;
6236 $format = $RATIONAL_FORMAT
6237 if $format eq $FLOAT_FORMAT
6238 && $map !~ / ^ -? [0-9]+ \. [0-9]* $ /x;
6239 $format = $HEX_FORMAT
6240 if $format eq $RATIONAL_FORMAT
6241 && $map !~ / ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x;
6242 $format = $STRING_FORMAT if $format eq $HEX_FORMAT
6243 && $map =~ /[^0-9A-F]/;
6248 } # end of calculating format
6250 if ($default_map eq $CODE_POINT
6251 && $format ne $HEX_FORMAT
6252 && ! defined $self->format) # manual settings are always
6255 Carp::my_carp_bug("Expecting hex format for mapping table for $self, instead got '$format'")
6258 $self->_set_format($format);
6260 return $self->SUPER::write(
6261 ($self->property == $block)
6262 ? 7 # block file needs more tab stops
6264 $default_map); # don't write defaulteds
6267 # Accessors for the underlying list that should fail if locked.
6277 return if $self->carp_if_locked;
6278 return $self->_range_list->$sub(@_);
6281 } # End closure for Map_Table
6283 package Match_Table;
6284 use base '_Base_Table';
6286 # A Match table is one which is a list of all the code points that have
6287 # the same property and property value, for use in \p{property=value}
6288 # constructs in regular expressions. It adds very little data to the base
6289 # structure, but many methods, as these lists can be combined in many ways to
6291 # There are only a few concepts added:
6292 # 1) Equivalents and Relatedness.
6293 # Two tables can match the identical code points, but have different names.
6294 # This always happens when there is a perl single form extension
6295 # \p{IsProperty} for the Unicode compound form \P{Property=True}. The two
6296 # tables are set to be related, with the Perl extension being a child, and
6297 # the Unicode property being the parent.
6299 # It may be that two tables match the identical code points and we don't
6300 # know if they are related or not. This happens most frequently when the
6301 # Block and Script properties have the exact range. But note that a
6302 # revision to Unicode could add new code points to the script, which would
6303 # now have to be in a different block (as the block was filled, or there
6304 # would have been 'Unknown' script code points in it and they wouldn't have
6305 # been identical). So we can't rely on any two properties from Unicode
6306 # always matching the same code points from release to release, and thus
6307 # these tables are considered coincidentally equivalent--not related. When
6308 # two tables are unrelated but equivalent, one is arbitrarily chosen as the
6309 # 'leader', and the others are 'equivalents'. This concept is useful
6310 # to minimize the number of tables written out. Only one file is used for
6311 # any identical set of code points, with entries in Heavy.pl mapping all
6312 # the involved tables to it.
6314 # Related tables will always be identical; we set them up to be so. Thus
6315 # if the Unicode one is deprecated, the Perl one will be too. Not so for
6316 # unrelated tables. Relatedness makes generating the documentation easier.
6318 # 2) Conflicting. It may be that there will eventually be name clashes, with
6319 # the same name meaning different things. For a while, there actually were
6320 # conflicts, but they have so far been resolved by changing Perl's or
6321 # Unicode's definitions to match the other, but when this code was written,
6322 # it wasn't clear that that was what was going to happen. (Unicode changed
6323 # because of protests during their beta period.) Name clashes are warned
6324 # about during compilation, and the documentation. The generated tables
6325 # are sane, free of name clashes, because the code suppresses the Perl
6326 # version. But manual intervention to decide what the actual behavior
6327 # should be may be required should this happen. The introductory comments
6328 # have more to say about this.
6330 sub standardize { return main::standardize($_[0]); }
6331 sub trace { return main::trace(@_); }
6336 main::setup_package();
6339 # The leader table of this one; initially $self.
6340 main::set_access('leader', \%leader, 'r');
6343 # An array of any tables that have this one as their leader
6344 main::set_access('equivalents', \%equivalents, 'readable_array');
6347 # The parent table to this one, initially $self. This allows us to
6348 # distinguish between equivalent tables that are related, and those which
6349 # may not be, but share the same output file because they match the exact
6350 # same set of code points in the current Unicode release.
6351 main::set_access('parent', \%parent, 'r');
6354 # An array of any tables that have this one as their parent
6355 main::set_access('children', \%children, 'readable_array');
6358 # Array of any tables that would have the same name as this one with
6359 # a different meaning. This is used for the generated documentation.
6360 main::set_access('conflicting', \%conflicting, 'readable_array');
6363 # Set in the constructor for tables that are expected to match all code
6365 main::set_access('matches_all', \%matches_all, 'r');
6372 # The property for which this table is a listing of property values.
6373 my $property = delete $args{'_Property'};
6375 my $name = delete $args{'Name'};
6376 my $full_name = delete $args{'Full_Name'};
6377 $full_name = $name if ! defined $full_name;
6380 my $initialize = delete $args{'Initialize'};
6381 my $matches_all = delete $args{'Matches_All'} || 0;
6382 my $format = delete $args{'Format'};
6383 # Rest of parameters passed on.
6385 my $range_list = Range_List->new(Initialize => $initialize,
6386 Owner => $property);
6388 my $complete = $full_name;
6389 $complete = '""' if $complete eq ""; # A null name shouldn't happen,
6390 # but this helps debug if it
6392 # The complete name for a match table includes it's property in a
6393 # compound form 'property=table', except if the property is the
6394 # pseudo-property, perl, in which case it is just the single form,
6395 # 'table' (If you change the '=' must also change the ':' in lots of
6396 # places in this program that assume an equal sign)
6397 $complete = $property->full_name . "=$complete" if $property != $perl;
6399 my $self = $class->SUPER::new(%args,
6401 Complete_Name => $complete,
6402 Full_Name => $full_name,
6403 _Property => $property,
6404 _Range_List => $range_list,
6405 Format => $EMPTY_FORMAT,
6407 my $addr = do { no overloading; pack 'J', $self; };
6409 $conflicting{$addr} = [ ];
6410 $equivalents{$addr} = [ ];
6411 $children{$addr} = [ ];
6412 $matches_all{$addr} = $matches_all;
6413 $leader{$addr} = $self;
6414 $parent{$addr} = $self;
6416 if (defined $format && $format ne $EMPTY_FORMAT) {
6417 Carp::my_carp_bug("'Format' must be '$EMPTY_FORMAT' in a match table instead of '$format'. Using '$EMPTY_FORMAT'");
6423 # See this program's beginning comment block about overloading these.
6426 qw("") => "_operator_stringify",
6430 return if $self->carp_if_locked;
6438 return $self->_range_list + $other;
6444 return $self->_range_list & $other;
6450 return if $self->carp_if_locked;
6452 my $addr = do { no overloading; pack 'J', $self; };
6456 # Change the range list of this table to be the
6458 $self->_set_range_list($self->_range_list
6461 else { # $other is just a simple value
6462 $self->add_range($other, $other);
6466 '-' => sub { my $self = shift;
6468 my $reversed = shift;
6471 Carp::my_carp_bug("Can't cope with a "
6473 . " being the first parameter in a '-'. Subtraction ignored.");
6477 return $self->_range_list - $other;
6479 '~' => sub { my $self = shift;
6480 return ~ $self->_range_list;
6484 sub _operator_stringify {
6487 my $name = $self->complete_name;
6488 return "Table '$name'";
6492 # Add a synonym for this table. See the comments in the base class
6496 # Rest of parameters passed on.
6498 $self->SUPER::add_alias($name, $self, @_);
6502 sub add_conflicting {
6503 # Add the name of some other object to the list of ones that name
6504 # clash with this match table.
6507 my $conflicting_name = shift; # The name of the conflicting object
6508 my $p = shift || 'p'; # Optional, is this a \p{} or \P{} ?
6509 my $conflicting_object = shift; # Optional, the conflicting object
6510 # itself. This is used to
6511 # disambiguate the text if the input
6512 # name is identical to any of the
6513 # aliases $self is known by.
6514 # Sometimes the conflicting object is
6515 # merely hypothetical, so this has to
6516 # be an optional parameter.
6517 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6519 my $addr = do { no overloading; pack 'J', $self; };
6521 # Check if the conflicting name is exactly the same as any existing
6522 # alias in this table (as long as there is a real object there to
6523 # disambiguate with).
6524 if (defined $conflicting_object) {
6525 foreach my $alias ($self->aliases) {
6526 if ($alias->name eq $conflicting_name) {
6528 # Here, there is an exact match. This results in
6529 # ambiguous comments, so disambiguate by changing the
6530 # conflicting name to its object's complete equivalent.
6531 $conflicting_name = $conflicting_object->complete_name;
6537 # Convert to the \p{...} final name
6538 $conflicting_name = "\\$p" . "{$conflicting_name}";
6541 return if grep { $conflicting_name eq $_ } @{$conflicting{$addr}};
6543 push @{$conflicting{$addr}}, $conflicting_name;
6548 sub is_set_equivalent_to {
6549 # Return boolean of whether or not the other object is a table of this
6550 # type and has been marked equivalent to this one.
6554 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6556 return 0 if ! defined $other; # Can happen for incomplete early
6558 unless ($other->isa(__PACKAGE__)) {
6559 my $ref_other = ref $other;
6560 my $ref_self = ref $self;
6561 Carp::my_carp_bug("Argument to 'is_set_equivalent_to' must be another $ref_self, not a '$ref_other'. $other not set equivalent to $self.");
6565 # Two tables are equivalent if they have the same leader.
6567 return $leader{pack 'J', $self} == $leader{pack 'J', $other};
6571 sub set_equivalent_to {
6572 # Set $self equivalent to the parameter table.
6573 # The required Related => 'x' parameter is a boolean indicating
6574 # whether these tables are related or not. If related, $other becomes
6575 # the 'parent' of $self; if unrelated it becomes the 'leader'
6577 # Related tables share all characteristics except names; equivalents
6578 # not quite so many.
6579 # If they are related, one must be a perl extension. This is because
6580 # we can't guarantee that Unicode won't change one or the other in a
6581 # later release even if they are identical now.
6587 my $related = delete $args{'Related'};
6589 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
6591 return if ! defined $other; # Keep on going; happens in some early
6594 if (! defined $related) {
6595 Carp::my_carp_bug("set_equivalent_to must have 'Related => [01] parameter. Assuming $self is not related to $other");
6599 # If already are equivalent, no need to re-do it; if subroutine
6600 # returns null, it found an error, also do nothing
6601 my $are_equivalent = $self->is_set_equivalent_to($other);
6602 return if ! defined $are_equivalent || $are_equivalent;
6604 my $addr = do { no overloading; pack 'J', $self; };
6605 my $current_leader = ($related) ? $parent{$addr} : $leader{$addr};
6608 if ($current_leader->perl_extension) {
6609 if ($other->perl_extension) {
6610 Carp::my_carp_bug("Use add_alias() to set two Perl tables '$self' and '$other', equivalent.");
6613 } elsif (! $other->perl_extension) {
6614 Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
6619 if (! $self->is_empty && ! $self->matches_identically_to($other)) {
6620 Carp::my_carp_bug("$self should be empty or match identically to $other. Not setting equivalent");
6624 my $leader = do { no overloading; pack 'J', $current_leader; };
6625 my $other_addr = do { no overloading; pack 'J', $other; };
6627 # Any tables that are equivalent to or children of this table must now
6628 # instead be equivalent to or (children) to the new leader (parent),
6629 # still equivalent. The equivalency includes their matches_all info,
6630 # and for related tables, their status
6631 # All related tables are of necessity equivalent, but the converse
6632 # isn't necessarily true
6633 my $status = $other->status;
6634 my $status_info = $other->status_info;
6635 my $matches_all = $matches_all{other_addr};
6636 my $caseless_equivalent = $other->caseless_equivalent;
6637 foreach my $table ($current_leader, @{$equivalents{$leader}}) {
6638 next if $table == $other;
6639 trace "setting $other to be the leader of $table, status=$status" if main::DEBUG && $to_trace;
6641 my $table_addr = do { no overloading; pack 'J', $table; };
6642 $leader{$table_addr} = $other;
6643 $matches_all{$table_addr} = $matches_all;
6644 $self->_set_range_list($other->_range_list);
6645 push @{$equivalents{$other_addr}}, $table;
6647 $parent{$table_addr} = $other;
6648 push @{$children{$other_addr}}, $table;
6649 $table->set_status($status, $status_info);
6650 $self->set_caseless_equivalent($caseless_equivalent);
6654 # Now that we've declared these to be equivalent, any changes to one
6655 # of the tables would invalidate that equivalency.
6661 sub add_range { # Add a range to the list for this table.
6663 # Rest of parameters passed on
6665 return if $self->carp_if_locked;
6666 return $self->_range_list->add_range(@_);
6669 sub pre_body { # Does nothing for match tables.
6673 sub append_to_body { # Does nothing for match tables.
6679 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6681 return $self->SUPER::write(2); # 2 tab stops
6684 sub set_final_comment {
6685 # This creates a comment for the file that is to hold the match table
6686 # $self. It is somewhat convoluted to make the English read nicely,
6687 # but, heh, it's just a comment.
6688 # This should be called only with the leader match table of all the
6689 # ones that share the same file. It lists all such tables, ordered so
6690 # that related ones are together.
6692 return unless $debugging_build;
6694 my $leader = shift; # Should only be called on the leader table of
6695 # an equivalent group
6696 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6698 my $addr = do { no overloading; pack 'J', $leader; };
6700 if ($leader{$addr} != $leader) {
6701 Carp::my_carp_bug(<<END
6702 set_final_comment() must be called on a leader table, which $leader is not.
6703 It is equivalent to $leader{$addr}. No comment created
6709 # Get the number of code points matched by each of the tables in this
6710 # file, and add underscores for clarity.
6711 my $count = $leader->count;
6712 my $string_count = main::clarify_number($count);
6714 my $loose_count = 0; # how many aliases loosely matched
6715 my $compound_name = ""; # ? Are any names compound?, and if so, an
6717 my $properties_with_compound_names = 0; # count of these
6720 my %flags; # The status flags used in the file
6721 my $total_entries = 0; # number of entries written in the comment
6722 my $matches_comment = ""; # The portion of the comment about the
6724 my @global_comments; # List of all the tables' comments that are
6725 # there before this routine was called.
6727 # Get list of all the parent tables that are equivalent to this one
6728 # (including itself).
6729 my @parents = grep { $parent{main::objaddr $_} == $_ }
6730 main::uniques($leader, @{$equivalents{$addr}});
6731 my $has_unrelated = (@parents >= 2); # boolean, ? are there unrelated
6734 for my $parent (@parents) {
6736 my $property = $parent->property;
6738 # Special case 'N' tables in properties with two match tables when
6739 # the other is a 'Y' one. These are likely to be binary tables,
6740 # but not necessarily. In either case, \P{} will match the
6741 # complement of \p{}, and so if something is a synonym of \p, the
6742 # complement of that something will be the synonym of \P. This
6743 # would be true of any property with just two match tables, not
6744 # just those whose values are Y and N; but that would require a
6745 # little extra work, and there are none such so far in Unicode.
6746 my $perl_p = 'p'; # which is it? \p{} or \P{}
6747 my @yes_perl_synonyms; # list of any synonyms for the 'Y' table
6749 if (scalar $property->tables == 2
6750 && $parent == $property->table('N')
6751 && defined (my $yes = $property->table('Y')))
6753 my $yes_addr = do { no overloading; pack 'J', $yes; };
6755 = grep { $_->property == $perl }
6758 $parent{$yes_addr}->children);
6760 # But these synonyms are \P{} ,not \p{}
6764 my @description; # Will hold the table description
6765 my @note; # Will hold the table notes.
6766 my @conflicting; # Will hold the table conflicts.
6768 # Look at the parent, any yes synonyms, and all the children
6769 my $parent_addr = do { no overloading; pack 'J', $parent; };
6770 for my $table ($parent,
6772 @{$children{$parent_addr}})
6774 my $table_addr = do { no overloading; pack 'J', $table; };
6775 my $table_property = $table->property;
6777 # Tables are separated by a blank line to create a grouping.
6778 $matches_comment .= "\n" if $matches_comment;
6780 # The table is named based on the property and value
6781 # combination it is for, like script=greek. But there may be
6782 # a number of synonyms for each side, like 'sc' for 'script',
6783 # and 'grek' for 'greek'. Any combination of these is a valid
6784 # name for this table. In this case, there are three more,
6785 # 'sc=grek', 'sc=greek', and 'script='grek'. Rather than
6786 # listing all possible combinations in the comment, we make
6787 # sure that each synonym occurs at least once, and add
6788 # commentary that the other combinations are possible.
6789 my @property_aliases = $table_property->aliases;
6790 my @table_aliases = $table->aliases;
6792 Carp::my_carp_bug("$table doesn't have any names. Proceeding anyway.") unless @table_aliases;
6794 # The alias lists above are already ordered in the order we
6795 # want to output them. To ensure that each synonym is listed,
6796 # we must use the max of the two numbers.
6797 my $listed_combos = main::max(scalar @table_aliases,
6798 scalar @property_aliases);
6799 trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG;
6801 my $property_had_compound_name = 0;
6803 for my $i (0 .. $listed_combos - 1) {
6806 # The current alias for the property is the next one on
6807 # the list, or if beyond the end, start over. Similarly
6808 # for the table (\p{prop=table})
6809 my $property_alias = $property_aliases
6810 [$i % @property_aliases]->name;
6811 my $table_alias_object = $table_aliases
6812 [$i % @table_aliases];
6813 my $table_alias = $table_alias_object->name;
6814 my $loose_match = $table_alias_object->loose_match;
6816 if ($table_alias !~ /\D/) { # Clarify large numbers.
6817 $table_alias = main::clarify_number($table_alias)
6820 # Add a comment for this alias combination
6821 my $current_match_comment;
6822 if ($table_property == $perl) {
6823 $current_match_comment = "\\$perl_p"
6827 $current_match_comment
6828 = "\\p{$property_alias=$table_alias}";
6829 $property_had_compound_name = 1;
6832 # Flag any abnormal status for this table.
6833 my $flag = $property->status
6835 || $table_alias_object->status;
6837 if ($flag ne $PLACEHOLDER) {
6838 $flags{$flag} = $status_past_participles{$flag};
6840 $flags{$flag} = <<END;
6841 a placeholder because it is not in Version $string_version of Unicode, but is
6842 needed by the Perl core to work gracefully. Because it is not in this version
6843 of Unicode, it will not be listed in $pod_file.pod
6850 # Pretty up the comment. Note the \b; it says don't make
6851 # this line a continuation.
6852 $matches_comment .= sprintf("\b%-1s%-s%s\n",
6855 $current_match_comment);
6856 } # End of generating the entries for this table.
6858 # Save these for output after this group of related tables.
6859 push @description, $table->description;
6860 push @note, $table->note;
6861 push @conflicting, $table->conflicting;
6863 # And this for output after all the tables.
6864 push @global_comments, $table->comment;
6866 # Compute an alternate compound name using the final property
6867 # synonym and the first table synonym with a colon instead of
6868 # the equal sign used elsewhere.
6869 if ($property_had_compound_name) {
6870 $properties_with_compound_names ++;
6871 if (! $compound_name || @property_aliases > 1) {
6872 $compound_name = $property_aliases[-1]->name
6874 . $table_aliases[0]->name;
6877 } # End of looping through all children of this table
6879 # Here have assembled in $matches_comment all the related tables
6880 # to the current parent (preceded by the same info for all the
6881 # previous parents). Put out information that applies to all of
6882 # the current family.
6885 # But output the conflicting information now, as it applies to
6887 my $conflicting = join ", ", @conflicting;
6889 $matches_comment .= <<END;
6891 Note that contrary to what you might expect, the above is NOT the same as
6893 $matches_comment .= "any of: " if @conflicting > 1;
6894 $matches_comment .= "$conflicting\n";
6898 $matches_comment .= "\n Meaning: "
6899 . join('; ', @description)
6903 $matches_comment .= "\n Note: "
6904 . join("\n ", @note)
6907 } # End of looping through all tables
6915 $code_points = 'single code point';
6919 $code_points = "$string_count code points";
6924 if ($total_entries <= 1) {
6927 $any_of_these = 'this'
6930 $synonyms = " any of the following regular expression constructs";
6931 $entries = 'entries';
6932 $any_of_these = 'any of these'
6936 if ($has_unrelated) {
6938 This file is for tables that are not necessarily related: To conserve
6939 resources, every table that matches the identical set of code points in this
6940 version of Unicode uses this file. Each one is listed in a separate group
6941 below. It could be that the tables will match the same set of code points in
6942 other Unicode releases, or it could be purely coincidence that they happen to
6943 be the same in Unicode $string_version, and hence may not in other versions.
6949 foreach my $flag (sort keys %flags) {
6951 '$flag' below means that this form is $flags{$flag}.
6953 next if $flag eq $PLACEHOLDER;
6954 $comment .= "Consult $pod_file.pod\n";
6960 This file returns the $code_points in Unicode Version $string_version that
6964 $pod_file.pod should be consulted for the syntax rules for $any_of_these,
6965 including if adding or subtracting white space, underscore, and hyphen
6966 characters matters or doesn't matter, and other permissible syntactic
6967 variants. Upper/lower case distinctions never matter.
6970 if ($compound_name) {
6973 A colon can be substituted for the equals sign, and
6975 if ($properties_with_compound_names > 1) {
6977 within each group above,
6980 $compound_name = sprintf("%-8s\\p{%s}", " ", $compound_name);
6982 # Note the \b below, it says don't make that line a continuation.
6984 anything to the left of the equals (or colon) can be combined with anything to
6985 the right. Thus, for example,
6991 # And append any comment(s) from the actual tables. They are all
6992 # gathered here, so may not read all that well.
6993 if (@global_comments) {
6994 $comment .= "\n" . join("\n\n", @global_comments) . "\n";
6997 if ($count) { # The format differs if no code points, and needs no
6998 # explanation in that case
7001 The format of the lines of this file is:
7004 START\\tSTOP\\twhere START is the starting code point of the range, in hex;
7005 STOP is the ending point, or if omitted, the range has just one code point.
7007 if ($leader->output_range_counts) {
7009 Numbers in comments in [brackets] indicate how many code points are in the
7015 $leader->set_comment(main::join_lines($comment));
7019 # Accessors for the underlying list
7021 get_valid_code_point
7022 get_invalid_code_point
7030 return $self->_range_list->$sub(@_);
7033 } # End closure for Match_Table
7037 # The Property class represents a Unicode property, or the $perl
7038 # pseudo-property. It contains a map table initialized empty at construction
7039 # time, and for properties accessible through regular expressions, various
7040 # match tables, created through the add_match_table() method, and referenced
7041 # by the table('NAME') or tables() methods, the latter returning a list of all
7042 # of the match tables. Otherwise table operations implicitly are for the map
7045 # Most of the data in the property is actually about its map table, so it
7046 # mostly just uses that table's accessors for most methods. The two could
7047 # have been combined into one object, but for clarity because of their
7048 # differing semantics, they have been kept separate. It could be argued that
7049 # the 'file' and 'directory' fields should be kept with the map table.
7051 # Each property has a type. This can be set in the constructor, or in the
7052 # set_type accessor, but mostly it is figured out by the data. Every property
7053 # starts with unknown type, overridden by a parameter to the constructor, or
7054 # as match tables are added, or ranges added to the map table, the data is
7055 # inspected, and the type changed. After the table is mostly or entirely
7056 # filled, compute_type() should be called to finalize they analysis.
7058 # There are very few operations defined. One can safely remove a range from
7059 # the map table, and property_add_or_replace_non_nulls() adds the maps from another
7060 # table to this one, replacing any in the intersection of the two.
7062 sub standardize { return main::standardize($_[0]); }
7063 sub trace { return main::trace(@_) if main::DEBUG && $to_trace }
7067 # This hash will contain as keys, all the aliases of all properties, and
7068 # as values, pointers to their respective property objects. This allows
7069 # quick look-up of a property from any of its names.
7070 my %alias_to_property_of;
7072 sub dump_alias_to_property_of {
7075 print "\n", main::simple_dumper (\%alias_to_property_of), "\n";
7080 # This is a package subroutine, not called as a method.
7081 # If the single parameter is a literal '*' it returns a list of all
7082 # defined properties.
7083 # Otherwise, the single parameter is a name, and it returns a pointer
7084 # to the corresponding property object, or undef if none.
7086 # Properties can have several different names. The 'standard' form of
7087 # each of them is stored in %alias_to_property_of as they are defined.
7088 # But it's possible that this subroutine will be called with some
7089 # variant, so if the initial lookup fails, it is repeated with the
7090 # standardized form of the input name. If found, besides returning the
7091 # result, the input name is added to the list so future calls won't
7092 # have to do the conversion again.
7096 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7098 if (! defined $name) {
7099 Carp::my_carp_bug("Undefined input property. No action taken.");
7103 return main::uniques(values %alias_to_property_of) if $name eq '*';
7105 # Return cached result if have it.
7106 my $result = $alias_to_property_of{$name};
7107 return $result if defined $result;
7109 # Convert the input to standard form.
7110 my $standard_name = standardize($name);
7112 $result = $alias_to_property_of{$standard_name};
7113 return unless defined $result; # Don't cache undefs
7115 # Cache the result before returning it.
7116 $alias_to_property_of{$name} = $result;
7121 main::setup_package();
7124 # A pointer to the map table object for this property
7125 main::set_access('map', \%map);
7128 # The property's full name. This is a duplicate of the copy kept in the
7129 # map table, but is needed because stringify needs it during
7130 # construction of the map table, and then would have a chicken before egg
7132 main::set_access('full_name', \%full_name, 'r');
7135 # This hash will contain as keys, all the aliases of any match tables
7136 # attached to this property, and as values, the pointers to their
7137 # respective tables. This allows quick look-up of a table from any of its
7139 main::set_access('table_ref', \%table_ref);
7142 # The type of the property, $ENUM, $BINARY, etc
7143 main::set_access('type', \%type, 'r');
7146 # The filename where the map table will go (if actually written).
7147 # Normally defaulted, but can be overridden.
7148 main::set_access('file', \%file, 'r', 's');
7151 # The directory where the map table will go (if actually written).
7152 # Normally defaulted, but can be overridden.
7153 main::set_access('directory', \%directory, 's');
7155 my %pseudo_map_type;
7156 # This is used to affect the calculation of the map types for all the
7157 # ranges in the table. It should be set to one of the values that signify
7158 # to alter the calculation.
7159 main::set_access('pseudo_map_type', \%pseudo_map_type, 'r');
7161 my %has_only_code_point_maps;
7162 # A boolean used to help in computing the type of data in the map table.
7163 main::set_access('has_only_code_point_maps', \%has_only_code_point_maps);
7166 # A list of the first few distinct mappings this property has. This is
7167 # used to disambiguate between binary and enum property types, so don't
7168 # have to keep more than three.
7169 main::set_access('unique_maps', \%unique_maps);
7172 # The only required parameter is the positionally first, name. All
7173 # other parameters are key => value pairs. See the documentation just
7174 # above for the meanings of the ones not passed directly on to the map
7175 # table constructor.
7178 my $name = shift || "";
7180 my $self = property_ref($name);
7181 if (defined $self) {
7182 my $options_string = join ", ", @_;
7183 $options_string = ". Ignoring options $options_string" if $options_string;
7184 Carp::my_carp("$self is already in use. Using existing one$options_string;");
7190 $self = bless \do { my $anonymous_scalar }, $class;
7191 my $addr = do { no overloading; pack 'J', $self; };
7193 $directory{$addr} = delete $args{'Directory'};
7194 $file{$addr} = delete $args{'File'};
7195 $full_name{$addr} = delete $args{'Full_Name'} || $name;
7196 $type{$addr} = delete $args{'Type'} || $UNKNOWN;
7197 $pseudo_map_type{$addr} = delete $args{'Map_Type'};
7198 # Rest of parameters passed on.
7200 $has_only_code_point_maps{$addr} = 1;
7201 $table_ref{$addr} = { };
7202 $unique_maps{$addr} = { };
7204 $map{$addr} = Map_Table->new($name,
7205 Full_Name => $full_name{$addr},
7206 _Alias_Hash => \%alias_to_property_of,
7212 # See this program's beginning comment block about overloading the copy
7213 # constructor. Few operations are defined on properties, but a couple are
7214 # useful. It is safe to take the inverse of a property, and to remove a
7215 # single code point from it.
7218 qw("") => "_operator_stringify",
7219 "." => \&main::_operator_dot,
7220 '==' => \&main::_operator_equal,
7221 '!=' => \&main::_operator_not_equal,
7222 '=' => sub { return shift },
7223 '-=' => "_minus_and_equal",
7226 sub _operator_stringify {
7227 return "Property '" . shift->full_name . "'";
7230 sub _minus_and_equal {
7231 # Remove a single code point from the map table of a property.
7235 my $reversed = shift;
7236 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7239 Carp::my_carp_bug("Can't cope with a "
7241 . " argument to '-='. Subtraction ignored.");
7244 elsif ($reversed) { # Shouldn't happen in a -=, but just in case
7245 Carp::my_carp_bug("Can't cope with a "
7247 . " being the first parameter in a '-='. Subtraction ignored.");
7252 $map{pack 'J', $self}->delete_range($other, $other);
7257 sub add_match_table {
7258 # Add a new match table for this property, with name given by the
7259 # parameter. It returns a pointer to the table.
7265 my $addr = do { no overloading; pack 'J', $self; };
7267 my $table = $table_ref{$addr}{$name};
7268 my $standard_name = main::standardize($name);
7270 || (defined ($table = $table_ref{$addr}{$standard_name})))
7272 Carp::my_carp("Table '$name' in $self is already in use. Using existing one");
7273 $table_ref{$addr}{$name} = $table;
7278 # See if this is a perl extension, if not passed in.
7279 my $perl_extension = delete $args{'Perl_Extension'};
7281 = $self->perl_extension if ! defined $perl_extension;
7283 $table = Match_Table->new(
7285 Perl_Extension => $perl_extension,
7286 _Alias_Hash => $table_ref{$addr},
7289 # gets property's status by default
7290 Status => $self->status,
7291 _Status_Info => $self->status_info,
7293 Internal_Only_Warning => 1); # Override any
7295 return unless defined $table;
7298 # Save the names for quick look up
7299 $table_ref{$addr}{$standard_name} = $table;
7300 $table_ref{$addr}{$name} = $table;
7302 # Perhaps we can figure out the type of this property based on the
7303 # fact of adding this match table. First, string properties don't
7304 # have match tables; second, a binary property can't have 3 match
7306 if ($type{$addr} == $UNKNOWN) {
7307 $type{$addr} = $NON_STRING;
7309 elsif ($type{$addr} == $STRING) {
7310 Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News.");
7311 $type{$addr} = $NON_STRING;
7313 elsif ($type{$addr} != $ENUM) {
7314 if (scalar main::uniques(values %{$table_ref{$addr}}) > 2
7315 && $type{$addr} == $BINARY)
7317 Carp::my_carp("$self now has more than 2 tables (with the addition of '$name'), and so is no longer binary. Changing its type to 'enum'. Bad News.");
7318 $type{$addr} = $ENUM;
7326 # Return a pointer to the match table (with name given by the
7327 # parameter) associated with this property; undef if none.
7331 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7333 my $addr = do { no overloading; pack 'J', $self; };
7335 return $table_ref{$addr}{$name} if defined $table_ref{$addr}{$name};
7337 # If quick look-up failed, try again using the standard form of the
7338 # input name. If that succeeds, cache the result before returning so
7339 # won't have to standardize this input name again.
7340 my $standard_name = main::standardize($name);
7341 return unless defined $table_ref{$addr}{$standard_name};
7343 $table_ref{$addr}{$name} = $table_ref{$addr}{$standard_name};
7344 return $table_ref{$addr}{$name};
7348 # Return a list of pointers to all the match tables attached to this
7352 return main::uniques(values %{$table_ref{pack 'J', shift}});
7356 # Returns the directory the map table for this property should be
7357 # output in. If a specific directory has been specified, that has
7358 # priority; 'undef' is returned if the type isn't defined;
7359 # or $map_directory for everything else.
7361 my $addr = do { no overloading; pack 'J', shift; };
7363 return $directory{$addr} if defined $directory{$addr};
7364 return undef if $type{$addr} == $UNKNOWN;
7365 return $map_directory;
7369 # Return the name that is used to both:
7370 # 1) Name the file that the map table is written to.
7371 # 2) The name of swash related stuff inside that file.
7372 # The reason for this is that the Perl core historically has used
7373 # certain names that aren't the same as the Unicode property names.
7374 # To continue using these, $file is hard-coded in this file for those,
7375 # but otherwise the standard name is used. This is different from the
7376 # external_name, so that the rest of the files, like in lib can use
7377 # the standard name always, without regard to historical precedent.
7380 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7382 my $addr = do { no overloading; pack 'J', $self; };
7384 return $file{$addr} if defined $file{$addr};
7385 return $map{$addr}->external_name;
7388 sub to_create_match_tables {
7389 # Returns a boolean as to whether or not match tables should be
7390 # created for this property.
7393 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7395 # The whole point of this pseudo property is match tables.
7396 return 1 if $self == $perl;
7398 my $addr = do { no overloading; pack 'J', $self; };
7400 # Don't generate tables of code points that match the property values
7401 # of a string property. Such a list would most likely have many
7402 # property values, each with just one or very few code points mapping
7404 return 0 if $type{$addr} == $STRING;
7406 # Don't generate anything for unimplemented properties.
7407 return 0 if grep { $self->complete_name eq $_ }
7408 @unimplemented_properties;
7413 sub property_add_or_replace_non_nulls {
7414 # This adds the mappings in the property $other to $self. Non-null
7415 # mappings from $other override those in $self. It essentially merges
7416 # the two properties, with the second having priority except for null
7421 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7423 if (! $other->isa(__PACKAGE__)) {
7424 Carp::my_carp_bug("$other should be a "
7433 return $map{pack 'J', $self}->map_add_or_replace_non_nulls($map{pack 'J', $other});
7437 # Set the type of the property. Mostly this is figured out by the
7438 # data in the table. But this is used to set it explicitly. The
7439 # reason it is not a standard accessor is that when setting a binary
7440 # property, we need to make sure that all the true/false aliases are
7441 # present, as they were omitted in early Unicode releases.
7445 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7447 if ($type != $ENUM && $type != $BINARY && $type != $STRING) {
7448 Carp::my_carp("Unrecognized type '$type'. Type not set");
7452 { no overloading; $type{pack 'J', $self} = $type; }
7453 return if $type != $BINARY;
7455 my $yes = $self->table('Y');
7456 $yes = $self->table('Yes') if ! defined $yes;
7457 $yes = $self->add_match_table('Y') if ! defined $yes;
7458 $yes->add_alias('Yes');
7459 $yes->add_alias('T');
7460 $yes->add_alias('True');
7462 my $no = $self->table('N');
7463 $no = $self->table('No') if ! defined $no;
7464 $no = $self->add_match_table('N') if ! defined $no;
7465 $no->add_alias('No');
7466 $no->add_alias('F');
7467 $no->add_alias('False');
7472 # Add a map to the property's map table. This also keeps
7473 # track of the maps so that the property type can be determined from
7477 my $start = shift; # First code point in range
7478 my $end = shift; # Final code point in range
7479 my $map = shift; # What the range maps to.
7480 # Rest of parameters passed on.
7482 my $addr = do { no overloading; pack 'J', $self; };
7484 # If haven't the type of the property, gather information to figure it
7486 if ($type{$addr} == $UNKNOWN) {
7488 # If the map contains an interior blank or dash, or most other
7489 # nonword characters, it will be a string property. This
7490 # heuristic may actually miss some string properties. If so, they
7491 # may need to have explicit set_types called for them. This
7492 # happens in the Unihan properties.
7493 if ($map =~ / (?<= . ) [ -] (?= . ) /x
7494 || $map =~ / [^\w.\/\ -] /x)
7496 $self->set_type($STRING);
7498 # $unique_maps is used for disambiguating between ENUM and
7499 # BINARY later; since we know the property is not going to be
7500 # one of those, no point in keeping the data around
7501 undef $unique_maps{$addr};
7505 # Not necessarily a string. The final decision has to be
7506 # deferred until all the data are in. We keep track of if all
7507 # the values are code points for that eventual decision.
7508 $has_only_code_point_maps{$addr} &=
7509 $map =~ / ^ $code_point_re $/x;
7511 # For the purposes of disambiguating between binary and other
7512 # enumerations at the end, we keep track of the first three
7513 # distinct property values. Once we get to three, we know
7514 # it's not going to be binary, so no need to track more.
7515 if (scalar keys %{$unique_maps{$addr}} < 3) {
7516 $unique_maps{$addr}{main::standardize($map)} = 1;
7521 # Add the mapping by calling our map table's method
7522 return $map{$addr}->add_map($start, $end, $map, @_);
7526 # Compute the type of the property: $ENUM, $STRING, or $BINARY. This
7527 # should be called after the property is mostly filled with its maps.
7528 # We have been keeping track of what the property values have been,
7529 # and now have the necessary information to figure out the type.
7532 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7534 my $addr = do { no overloading; pack 'J', $self; };
7536 my $type = $type{$addr};
7538 # If already have figured these out, no need to do so again, but we do
7539 # a double check on ENUMS to make sure that a string property hasn't
7540 # improperly been classified as an ENUM, so continue on with those.
7541 return if $type == $STRING || $type == $BINARY;
7543 # If every map is to a code point, is a string property.
7544 if ($type == $UNKNOWN
7545 && ($has_only_code_point_maps{$addr}
7546 || (defined $map{$addr}->default_map
7547 && $map{$addr}->default_map eq "")))
7549 $self->set_type($STRING);
7553 # Otherwise, it is to some sort of enumeration. (The case where
7554 # it is a Unicode miscellaneous property, and treated like a
7555 # string in this program is handled in add_map()). Distinguish
7556 # between binary and some other enumeration type. Of course, if
7557 # there are more than two values, it's not binary. But more
7558 # subtle is the test that the default mapping is defined means it
7559 # isn't binary. This in fact may change in the future if Unicode
7560 # changes the way its data is structured. But so far, no binary
7561 # properties ever have @missing lines for them, so the default map
7562 # isn't defined for them. The few properties that are two-valued
7563 # and aren't considered binary have the default map defined
7564 # starting in Unicode 5.0, when the @missing lines appeared; and
7565 # this program has special code to put in a default map for them
7566 # for earlier than 5.0 releases.
7568 || scalar keys %{$unique_maps{$addr}} > 2
7569 || defined $self->default_map)
7571 my $tables = $self->tables;
7572 my $count = $self->count;
7573 if ($verbosity && $count > 500 && $tables/$count > .1) {
7574 Carp::my_carp_bug("It appears that $self should be a \$STRING property, not an \$ENUM because it has too many match tables: $count\n");
7576 $self->set_type($ENUM);
7579 $self->set_type($BINARY);
7582 undef $unique_maps{$addr}; # Garbage collect
7586 # Most of the accessors for a property actually apply to its map table.
7587 # Setup up accessor functions for those, referring to %map
7636 # 'property' above is for symmetry, so that one can take
7637 # the property of a property and get itself, and so don't
7638 # have to distinguish between properties and tables in
7646 return $map{pack 'J', $self}->$sub(@_);
7656 # Returns lines of the input joined together, so that they can be folded
7658 # This causes continuation lines to be joined together into one long line
7659 # for folding. A continuation line is any line that doesn't begin with a
7660 # space or "\b" (the latter is stripped from the output). This is so
7661 # lines can be be in a HERE document so as to fit nicely in the terminal
7662 # width, but be joined together in one long line, and then folded with
7663 # indents, '#' prefixes, etc, properly handled.
7664 # A blank separates the joined lines except if there is a break; an extra
7665 # blank is inserted after a period ending a line.
7667 # Initialize the return with the first line.
7668 my ($return, @lines) = split "\n", shift;
7670 # If the first line is null, it was an empty line, add the \n back in
7671 $return = "\n" if $return eq "";
7673 # Now join the remainder of the physical lines.
7674 for my $line (@lines) {
7676 # An empty line means wanted a blank line, so add two \n's to get that
7677 # effect, and go to the next line.
7678 if (length $line == 0) {
7683 # Look at the last character of what we have so far.
7684 my $previous_char = substr($return, -1, 1);
7686 # And at the next char to be output.
7687 my $next_char = substr($line, 0, 1);
7689 if ($previous_char ne "\n") {
7691 # Here didn't end wth a nl. If the next char a blank or \b, it
7692 # means that here there is a break anyway. So add a nl to the
7694 if ($next_char eq " " || $next_char eq "\b") {
7695 $previous_char = "\n";
7696 $return .= $previous_char;
7699 # Add an extra space after periods.
7700 $return .= " " if $previous_char eq '.';
7703 # Here $previous_char is still the latest character to be output. If
7704 # it isn't a nl, it means that the next line is to be a continuation
7705 # line, with a blank inserted between them.
7706 $return .= " " if $previous_char ne "\n";
7709 substr($line, 0, 1) = "" if $next_char eq "\b";
7711 # And append this next line.
7718 sub simple_fold($;$$$) {
7719 # Returns a string of the input (string or an array of strings) folded
7720 # into multiple-lines each of no more than $MAX_LINE_WIDTH characters plus
7722 # This is tailored for the kind of text written by this program,
7723 # especially the pod file, which can have very long names with
7724 # underscores in the middle, or words like AbcDefgHij.... We allow
7725 # breaking in the middle of such constructs if the line won't fit
7726 # otherwise. The break in such cases will come either just after an
7727 # underscore, or just before one of the Capital letters.
7729 local $to_trace = 0 if main::DEBUG;
7732 my $prefix = shift; # Optional string to prepend to each output
7734 $prefix = "" unless defined $prefix;
7736 my $hanging_indent = shift; # Optional number of spaces to indent
7737 # continuation lines
7738 $hanging_indent = 0 unless $hanging_indent;
7740 my $right_margin = shift; # Optional number of spaces to narrow the
7742 $right_margin = 0 unless defined $right_margin;
7744 # Call carp with the 'nofold' option to avoid it from trying to call us
7746 Carp::carp_extra_args(\@_, 'nofold') if main::DEBUG && @_;
7748 # The space available doesn't include what's automatically prepended
7749 # to each line, or what's reserved on the right.
7750 my $max = $MAX_LINE_WIDTH - length($prefix) - $right_margin;
7751 # XXX Instead of using the 'nofold' perhaps better to look up the stack
7753 if (DEBUG && $hanging_indent >= $max) {
7754 Carp::my_carp("Too large a hanging indent ($hanging_indent); must be < $max. Using 0", 'nofold');
7755 $hanging_indent = 0;
7758 # First, split into the current physical lines.
7760 if (ref $line) { # Better be an array, because not bothering to
7762 foreach my $line (@{$line}) {
7763 push @line, split /\n/, $line;
7767 @line = split /\n/, $line;
7770 #local $to_trace = 1 if main::DEBUG;
7771 trace "", join(" ", @line), "\n" if main::DEBUG && $to_trace;
7773 # Look at each current physical line.
7774 for (my $i = 0; $i < @line; $i++) {
7775 Carp::my_carp("Tabs don't work well.", 'nofold') if $line[$i] =~ /\t/;
7776 #local $to_trace = 1 if main::DEBUG;
7777 trace "i=$i: $line[$i]\n" if main::DEBUG && $to_trace;
7779 # Remove prefix, because will be added back anyway, don't want
7781 $line[$i] =~ s/^$prefix//;
7783 # Remove trailing space
7784 $line[$i] =~ s/\s+\Z//;
7786 # If the line is too long, fold it.
7787 if (length $line[$i] > $max) {
7790 # Here needs to fold. Save the leading space in the line for
7792 $line[$i] =~ /^ ( \s* )/x;
7793 my $leading_space = $1;
7794 trace "line length", length $line[$i], "; lead length", length($leading_space) if main::DEBUG && $to_trace;
7796 # If character at final permissible position is white space,
7797 # fold there, which will delete that white space
7798 if (substr($line[$i], $max - 1, 1) =~ /\s/) {
7799 $remainder = substr($line[$i], $max);
7800 $line[$i] = substr($line[$i], 0, $max - 1);
7804 # Otherwise fold at an acceptable break char closest to
7805 # the max length. Look at just the maximal initial
7806 # segment of the line
7807 my $segment = substr($line[$i], 0, $max - 1);
7809 /^ ( .{$hanging_indent} # Don't look before the
7811 \ * # Don't look in leading
7812 # blanks past the indent
7813 [^ ] .* # Find the right-most
7814 (?: # acceptable break:
7815 [ \s = ] # space or equal
7816 | - (?! [.0-9] ) # or non-unary minus.
7817 ) # $1 includes the character
7820 # Split into the initial part that fits, and remaining
7822 $remainder = substr($line[$i], length $1);
7824 trace $line[$i] if DEBUG && $to_trace;
7825 trace $remainder if DEBUG && $to_trace;
7828 # If didn't find a good breaking spot, see if there is a
7829 # not-so-good breaking spot. These are just after
7830 # underscores or where the case changes from lower to
7831 # upper. Use \a as a soft hyphen, but give up
7832 # and don't break the line if there is actually a \a
7833 # already in the input. We use an ascii character for the
7834 # soft-hyphen to avoid any attempt by miniperl to try to
7835 # access the files that this program is creating.
7836 elsif ($segment !~ /\a/
7837 && ($segment =~ s/_/_\a/g
7838 || $segment =~ s/ ( [a-z] ) (?= [A-Z] )/$1\a/xg))
7840 # Here were able to find at least one place to insert
7841 # our substitute soft hyphen. Find the right-most one
7842 # and replace it by a real hyphen.
7843 trace $segment if DEBUG && $to_trace;
7845 rindex($segment, "\a"),
7848 # Then remove the soft hyphen substitutes.
7849 $segment =~ s/\a//g;
7850 trace $segment if DEBUG && $to_trace;
7852 # And split into the initial part that fits, and
7853 # remainder of the line
7854 my $pos = rindex($segment, '-');
7855 $remainder = substr($line[$i], $pos);
7856 trace $remainder if DEBUG && $to_trace;
7857 $line[$i] = substr($segment, 0, $pos + 1);
7861 # Here we know if we can fold or not. If we can, $remainder
7862 # is what remains to be processed in the next iteration.
7863 if (defined $remainder) {
7864 trace "folded='$line[$i]'" if main::DEBUG && $to_trace;
7866 # Insert the folded remainder of the line as a new element
7867 # of the array. (It may still be too long, but we will
7868 # deal with that next time through the loop.) Omit any
7869 # leading space in the remainder.
7870 $remainder =~ s/^\s+//;
7871 trace "remainder='$remainder'" if main::DEBUG && $to_trace;
7873 # But then indent by whichever is larger of:
7874 # 1) the leading space on the input line;
7875 # 2) the hanging indent.
7876 # This preserves indentation in the original line.
7877 my $lead = ($leading_space)
7878 ? length $leading_space
7880 $lead = max($lead, $hanging_indent);
7881 splice @line, $i+1, 0, (" " x $lead) . $remainder;
7885 # Ready to output the line. Get rid of any trailing space
7886 # And prefix by the required $prefix passed in.
7887 $line[$i] =~ s/\s+$//;
7888 $line[$i] = "$prefix$line[$i]\n";
7889 } # End of looping through all the lines.
7891 return join "", @line;
7894 sub property_ref { # Returns a reference to a property object.
7895 return Property::property_ref(@_);
7898 sub force_unlink ($) {
7899 my $filename = shift;
7900 return unless file_exists($filename);
7901 return if CORE::unlink($filename);
7903 # We might need write permission
7904 chmod 0777, $filename;
7905 CORE::unlink($filename) or Carp::my_carp("Couldn't unlink $filename. Proceeding anyway: $!");
7910 # Given a filename and references to arrays of lines, write the lines of
7911 # each array to the file
7912 # Filename can be given as an arrayref of directory names
7914 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
7917 my $use_utf8 = shift;
7919 # Get into a single string if an array, and get rid of, in Unix terms, any
7921 $file= File::Spec->join(@$file) if ref $file eq 'ARRAY';
7922 $file = File::Spec->canonpath($file);
7924 # If has directories, make sure that they all exist
7925 (undef, my $directories, undef) = File::Spec->splitpath($file);
7926 File::Path::mkpath($directories) if $directories && ! -d $directories;
7928 push @files_actually_output, $file;
7930 force_unlink ($file);
7933 if (not open $OUT, ">", $file) {
7934 Carp::my_carp("can't open $file for output. Skipping this file: $!");
7938 binmode $OUT, ":utf8" if $use_utf8;
7940 while (defined (my $lines_ref = shift)) {
7941 unless (@$lines_ref) {
7942 Carp::my_carp("An array of lines for writing to file '$file' is empty; writing it anyway;");
7945 print $OUT @$lines_ref or die Carp::my_carp("write to '$file' failed: $!");
7947 close $OUT or die Carp::my_carp("close '$file' failed: $!");
7949 print "$file written.\n" if $verbosity >= $VERBOSE;
7955 sub Standardize($) {
7956 # This converts the input name string into a standardized equivalent to
7960 unless (defined $name) {
7961 Carp::my_carp_bug("Standardize() called with undef. Returning undef.");
7965 # Remove any leading or trailing white space
7969 # Convert interior white space and hyphens into underscores.
7970 $name =~ s/ (?<= .) [ -]+ (.) /_$1/xg;
7972 # Capitalize the letter following an underscore, and convert a sequence of
7973 # multiple underscores to a single one
7974 $name =~ s/ (?<= .) _+ (.) /_\u$1/xg;
7976 # And capitalize the first letter, but not for the special cjk ones.
7977 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
7981 sub standardize ($) {
7982 # Returns a lower-cased standardized name, without underscores. This form
7983 # is chosen so that it can distinguish between any real versus superficial
7984 # Unicode name differences. It relies on the fact that Unicode doesn't
7985 # have interior underscores, white space, nor dashes in any
7986 # stricter-matched name. It should not be used on Unicode code point
7987 # names (the Name property), as they mostly, but not always follow these
7990 my $name = Standardize(shift);
7991 return if !defined $name;
7993 $name =~ s/ (?<= .) _ (?= . ) //xg;
7997 sub utf8_heavy_name ($$) {
7998 # Returns the name that utf8_heavy.pl will use to find a table. XXX
7999 # perhaps this function should be placed somewhere, like Heavy.pl so that
8000 # utf8_heavy can use it directly without duplicating code that can get
8005 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8007 my $property = $table->property;
8008 $property = ($property == $perl)
8009 ? "" # 'perl' is never explicitly stated
8010 : standardize($property->name) . '=';
8011 if ($alias->loose_match) {
8012 return $property . standardize($alias->name);
8015 return lc ($property . $alias->name);
8023 my $indent_increment = " " x 2;
8026 $main::simple_dumper_nesting = 0;
8029 # Like Simple Data::Dumper. Good enough for our needs. We can't use
8030 # the real thing as we have to run under miniperl.
8032 # It is designed so that on input it is at the beginning of a line,
8033 # and the final thing output in any call is a trailing ",\n".
8037 $indent = "" if ! defined $indent;
8039 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8041 # nesting level is localized, so that as the call stack pops, it goes
8042 # back to the prior value.
8043 local $main::simple_dumper_nesting = $main::simple_dumper_nesting;
8044 undef %already_output if $main::simple_dumper_nesting == 0;
8045 $main::simple_dumper_nesting++;
8046 #print STDERR __LINE__, ": $main::simple_dumper_nesting: $indent$item\n";
8048 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8050 # Determine the indent for recursive calls.
8051 my $next_indent = $indent . $indent_increment;
8056 # Dump of scalar: just output it in quotes if not a number. To do
8057 # so we must escape certain characters, and therefore need to
8058 # operate on a copy to avoid changing the original
8060 $copy = $UNDEF unless defined $copy;
8062 # Quote non-numbers (numbers also have optional leading '-' and
8064 if ($copy eq "" || $copy !~ /^ -? \d+ ( \. \d+ )? $/x) {
8066 # Escape apostrophe and backslash
8067 $copy =~ s/ ( ['\\] ) /\\$1/xg;
8070 $output = "$indent$copy,\n";
8074 # Keep track of cycles in the input, and refuse to infinitely loop
8075 my $addr = do { no overloading; pack 'J', $item; };
8076 if (defined $already_output{$addr}) {
8077 return "${indent}ALREADY OUTPUT: $item\n";
8079 $already_output{$addr} = $item;
8081 if (ref $item eq 'ARRAY') {
8084 if ($main::simple_dumper_nesting > 1) {
8086 $using_brackets = 1;
8089 $using_brackets = 0;
8092 # If the array is empty, put the closing bracket on the same
8093 # line. Otherwise, recursively add each array element
8099 for (my $i = 0; $i < @$item; $i++) {
8101 # Indent array elements one level
8102 $output .= &simple_dumper($item->[$i], $next_indent);
8103 $output =~ s/\n$//; # Remove trailing nl so as to
8104 $output .= " # [$i]\n"; # add a comment giving the
8107 $output .= $indent; # Indent closing ']' to orig level
8109 $output .= ']' if $using_brackets;
8112 elsif (ref $item eq 'HASH') {
8117 # No surrounding braces at top level
8119 if ($main::simple_dumper_nesting > 1) {
8122 $body_indent = $next_indent;
8123 $next_indent .= $indent_increment;
8128 $body_indent = $indent;
8132 # Output hashes sorted alphabetically instead of apparently
8133 # random. Use caseless alphabetic sort
8134 foreach my $key (sort { lc $a cmp lc $b } keys %$item)
8136 if ($is_first_line) {
8140 $output .= "$body_indent";
8143 # The key must be a scalar, but this recursive call quotes
8145 $output .= &simple_dumper($key);
8147 # And change the trailing comma and nl to the hash fat
8148 # comma for clarity, and so the value can be on the same
8150 $output =~ s/,\n$/ => /;
8152 # Recursively call to get the value's dump.
8153 my $next = &simple_dumper($item->{$key}, $next_indent);
8155 # If the value is all on one line, remove its indent, so
8156 # will follow the => immediately. If it takes more than
8157 # one line, start it on a new line.
8158 if ($next !~ /\n.*\n/) {
8167 $output .= "$indent},\n" if $using_braces;
8169 elsif (ref $item eq 'CODE' || ref $item eq 'GLOB') {
8170 $output = $indent . ref($item) . "\n";
8171 # XXX see if blessed
8173 elsif ($item->can('dump')) {
8175 # By convention in this program, objects furnish a 'dump'
8176 # method. Since not doing any output at this level, just pass
8177 # on the input indent
8178 $output = $item->dump($indent);
8181 Carp::my_carp("Can't cope with dumping a " . ref($item) . ". Skipping.");
8188 sub dump_inside_out {
8189 # Dump inside-out hashes in an object's state by converting them to a
8190 # regular hash and then calling simple_dumper on that.
8193 my $fields_ref = shift;
8194 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8196 my $addr = do { no overloading; pack 'J', $object; };
8199 foreach my $key (keys %$fields_ref) {
8200 $hash{$key} = $fields_ref->{$key}{$addr};
8203 return simple_dumper(\%hash, @_);
8207 # Overloaded '.' method that is common to all packages. It uses the
8208 # package's stringify method.
8212 my $reversed = shift;
8213 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8215 $other = "" unless defined $other;
8217 foreach my $which (\$self, \$other) {
8218 next unless ref $$which;
8219 if ($$which->can('_operator_stringify')) {
8220 $$which = $$which->_operator_stringify;
8223 my $ref = ref $$which;
8224 my $addr = do { no overloading; pack 'J', $$which; };
8225 $$which = "$ref ($addr)";
8233 sub _operator_equal {
8234 # Generic overloaded '==' routine. To be equal, they must be the exact
8240 return 0 unless defined $other;
8241 return 0 unless ref $other;
8243 return $self == $other;
8246 sub _operator_not_equal {
8250 return ! _operator_equal($self, $other);
8253 sub process_PropertyAliases($) {
8254 # This reads in the PropertyAliases.txt file, which contains almost all
8255 # the character properties in Unicode and their equivalent aliases:
8256 # scf ; Simple_Case_Folding ; sfc
8258 # Field 0 is the preferred short name for the property.
8259 # Field 1 is the full name.
8260 # Any succeeding ones are other accepted names.
8263 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8265 # This whole file was non-existent in early releases, so use our own
8267 $file->insert_lines(get_old_property_aliases())
8268 if ! -e 'PropertyAliases.txt';
8270 # Add any cjk properties that may have been defined.
8271 $file->insert_lines(@cjk_properties);
8273 while ($file->next_line) {
8275 my @data = split /\s*;\s*/;
8277 my $full = $data[1];
8279 my $this = Property->new($data[0], Full_Name => $full);
8281 # Start looking for more aliases after these two.
8282 for my $i (2 .. @data - 1) {
8283 $this->add_alias($data[$i]);
8290 sub finish_property_setup {
8291 # Finishes setting up after PropertyAliases.
8294 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8296 # This entry was missing from this file in earlier Unicode versions
8297 if (-e 'Jamo.txt') {
8298 my $jsn = property_ref('JSN');
8299 if (! defined $jsn) {
8300 $jsn = Property->new('JSN', Full_Name => 'Jamo_Short_Name');
8304 # This entry is still missing as of 6.0, perhaps because no short name for
8306 if (-e 'NameAliases.txt') {
8307 my $aliases = property_ref('Name_Alias');
8308 if (! defined $aliases) {
8309 $aliases = Property->new('Name_Alias');
8313 # These are used so much, that we set globals for them.
8314 $gc = property_ref('General_Category');
8315 $block = property_ref('Block');
8317 # Perl adds this alias.
8318 $gc->add_alias('Category');
8320 # For backwards compatibility, these property files have particular names.
8321 my $upper = property_ref('Uppercase_Mapping');
8322 $upper->set_core_access('uc()');
8323 $upper->set_file('Upper'); # This is what utf8.c calls it
8325 my $lower = property_ref('Lowercase_Mapping');
8326 $lower->set_core_access('lc()');
8327 $lower->set_file('Lower');
8329 my $title = property_ref('Titlecase_Mapping');
8330 $title->set_core_access('ucfirst()');
8331 $title->set_file('Title');
8333 my $fold = property_ref('Case_Folding');
8334 $fold->set_file('Fold') if defined $fold;
8336 # utf8.c has a different meaning for non range-size-1 for map properties
8337 # that this program doesn't currently handle; and even if it were changed
8338 # to do so, some other code may be using them expecting range size 1.
8339 foreach my $property (qw {
8346 property_ref($property)->set_range_size_1(1);
8349 # These two properties aren't actually used in the core, but unfortunately
8350 # the names just above that are in the core interfere with these, so
8351 # choose different names. These aren't a problem unless the map tables
8352 # for these files get written out.
8353 my $lowercase = property_ref('Lowercase');
8354 $lowercase->set_file('IsLower') if defined $lowercase;
8355 my $uppercase = property_ref('Uppercase');
8356 $uppercase->set_file('IsUpper') if defined $uppercase;
8358 # Set up the hard-coded default mappings, but only on properties defined
8360 foreach my $property (keys %default_mapping) {
8361 my $property_object = property_ref($property);
8362 next if ! defined $property_object;
8363 my $default_map = $default_mapping{$property};
8364 $property_object->set_default_map($default_map);
8366 # A map of <code point> implies the property is string.
8367 if ($property_object->type == $UNKNOWN
8368 && $default_map eq $CODE_POINT)
8370 $property_object->set_type($STRING);
8374 # The following use the Multi_Default class to create objects for
8377 # Bidi class has a complicated default, but the derived file takes care of
8378 # the complications, leaving just 'L'.
8379 if (file_exists("${EXTRACTED}DBidiClass.txt")) {
8380 property_ref('Bidi_Class')->set_default_map('L');
8385 # The derived file was introduced in 3.1.1. The values below are
8386 # taken from table 3-8, TUS 3.0
8388 'my $default = Range_List->new;
8389 $default->add_range(0x0590, 0x05FF);
8390 $default->add_range(0xFB1D, 0xFB4F);'
8393 # The defaults apply only to unassigned characters
8394 $default_R .= '$gc->table("Unassigned") & $default;';
8396 if ($v_version lt v3.0.0) {
8397 $default = Multi_Default->new(R => $default_R, 'L');
8401 # AL apparently not introduced until 3.0: TUS 2.x references are
8402 # not on-line to check it out
8404 'my $default = Range_List->new;
8405 $default->add_range(0x0600, 0x07BF);
8406 $default->add_range(0xFB50, 0xFDFF);
8407 $default->add_range(0xFE70, 0xFEFF);'
8410 # Non-character code points introduced in this release; aren't AL
8411 if ($v_version ge 3.1.0) {
8412 $default_AL .= '$default->delete_range(0xFDD0, 0xFDEF);';
8414 $default_AL .= '$gc->table("Unassigned") & $default';
8415 $default = Multi_Default->new(AL => $default_AL,
8419 property_ref('Bidi_Class')->set_default_map($default);
8422 # Joining type has a complicated default, but the derived file takes care
8423 # of the complications, leaving just 'U' (or Non_Joining), except the file
8425 if (file_exists("${EXTRACTED}DJoinType.txt") || -e 'ArabicShaping.txt') {
8426 if (file_exists("${EXTRACTED}DJoinType.txt") && $v_version ne 3.1.0) {
8427 property_ref('Joining_Type')->set_default_map('Non_Joining');
8431 # Otherwise, there are not one, but two possibilities for the
8432 # missing defaults: T and U.
8433 # The missing defaults that evaluate to T are given by:
8434 # T = Mn + Cf - ZWNJ - ZWJ
8435 # where Mn and Cf are the general category values. In other words,
8436 # any non-spacing mark or any format control character, except
8437 # U+200C ZERO WIDTH NON-JOINER (joining type U) and U+200D ZERO
8438 # WIDTH JOINER (joining type C).
8439 my $default = Multi_Default->new(
8440 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C - 0x200D',
8442 property_ref('Joining_Type')->set_default_map($default);
8446 # Line break has a complicated default in early releases. It is 'Unknown'
8447 # for non-assigned code points; 'AL' for assigned.
8448 if (file_exists("${EXTRACTED}DLineBreak.txt") || -e 'LineBreak.txt') {
8449 my $lb = property_ref('Line_Break');
8450 if ($v_version gt 3.2.0) {
8451 $lb->set_default_map('Unknown');
8454 my $default = Multi_Default->new( 'Unknown' => '$gc->table("Cn")',
8456 $lb->set_default_map($default);
8459 # If has the URS property, make sure that the standard aliases are in
8460 # it, since not in the input tables in some versions.
8461 my $urs = property_ref('Unicode_Radical_Stroke');
8463 $urs->add_alias('cjkRSUnicode');
8464 $urs->add_alias('kRSUnicode');
8470 sub get_old_property_aliases() {
8471 # Returns what would be in PropertyAliases.txt if it existed in very old
8472 # versions of Unicode. It was derived from the one in 3.2, and pared
8473 # down based on the data that was actually in the older releases.
8474 # An attempt was made to use the existence of files to mean inclusion or
8475 # not of various aliases, but if this was not sufficient, using version
8476 # numbers was resorted to.
8480 # These are to be used in all versions (though some are constructed by
8481 # this program if missing)
8482 push @return, split /\n/, <<'END';
8484 Bidi_M ; Bidi_Mirrored
8486 ccc ; Canonical_Combining_Class
8487 dm ; Decomposition_Mapping
8488 dt ; Decomposition_Type
8489 gc ; General_Category
8491 lc ; Lowercase_Mapping
8493 na1 ; Unicode_1_Name
8496 sfc ; Simple_Case_Folding
8497 slc ; Simple_Lowercase_Mapping
8498 stc ; Simple_Titlecase_Mapping
8499 suc ; Simple_Uppercase_Mapping
8500 tc ; Titlecase_Mapping
8501 uc ; Uppercase_Mapping
8504 if (-e 'Blocks.txt') {
8505 push @return, "blk ; Block\n";
8507 if (-e 'ArabicShaping.txt') {
8508 push @return, split /\n/, <<'END';
8513 if (-e 'PropList.txt') {
8515 # This first set is in the original old-style proplist.
8516 push @return, split /\n/, <<'END';
8518 Bidi_C ; Bidi_Control
8526 Join_C ; Join_Control
8528 QMark ; Quotation_Mark
8529 Term ; Terminal_Punctuation
8530 WSpace ; White_Space
8532 # The next sets were added later
8533 if ($v_version ge v3.0.0) {
8534 push @return, split /\n/, <<'END';
8539 if ($v_version ge v3.0.1) {
8540 push @return, split /\n/, <<'END';
8541 NChar ; Noncharacter_Code_Point
8544 # The next sets were added in the new-style
8545 if ($v_version ge v3.1.0) {
8546 push @return, split /\n/, <<'END';
8547 OAlpha ; Other_Alphabetic
8548 OLower ; Other_Lowercase
8550 OUpper ; Other_Uppercase
8553 if ($v_version ge v3.1.1) {
8554 push @return, "AHex ; ASCII_Hex_Digit\n";
8557 if (-e 'EastAsianWidth.txt') {
8558 push @return, "ea ; East_Asian_Width\n";
8560 if (-e 'CompositionExclusions.txt') {
8561 push @return, "CE ; Composition_Exclusion\n";
8563 if (-e 'LineBreak.txt') {
8564 push @return, "lb ; Line_Break\n";
8566 if (-e 'BidiMirroring.txt') {
8567 push @return, "bmg ; Bidi_Mirroring_Glyph\n";
8569 if (-e 'Scripts.txt') {
8570 push @return, "sc ; Script\n";
8572 if (-e 'DNormalizationProps.txt') {
8573 push @return, split /\n/, <<'END';
8574 Comp_Ex ; Full_Composition_Exclusion
8575 FC_NFKC ; FC_NFKC_Closure
8576 NFC_QC ; NFC_Quick_Check
8577 NFD_QC ; NFD_Quick_Check
8578 NFKC_QC ; NFKC_Quick_Check
8579 NFKD_QC ; NFKD_Quick_Check
8580 XO_NFC ; Expands_On_NFC
8581 XO_NFD ; Expands_On_NFD
8582 XO_NFKC ; Expands_On_NFKC
8583 XO_NFKD ; Expands_On_NFKD
8586 if (-e 'DCoreProperties.txt') {
8587 push @return, split /\n/, <<'END';
8592 # These can also appear in some versions of PropList.txt
8593 push @return, "Lower ; Lowercase\n"
8594 unless grep { $_ =~ /^Lower\b/} @return;
8595 push @return, "Upper ; Uppercase\n"
8596 unless grep { $_ =~ /^Upper\b/} @return;
8599 # This flag requires the DAge.txt file to be copied into the directory.
8600 if (DEBUG && $compare_versions) {
8601 push @return, 'age ; Age';
8607 sub process_PropValueAliases {
8608 # This file contains values that properties look like:
8609 # bc ; AL ; Arabic_Letter
8610 # blk; n/a ; Greek_And_Coptic ; Greek
8612 # Field 0 is the property.
8613 # Field 1 is the short name of a property value or 'n/a' if no
8614 # short name exists;
8615 # Field 2 is the full property value name;
8616 # Any other fields are more synonyms for the property value.
8617 # Purely numeric property values are omitted from the file; as are some
8618 # others, fewer and fewer in later releases
8620 # Entries for the ccc property have an extra field before the
8622 # ccc; 0; NR ; Not_Reordered
8623 # It is the numeric value that the names are synonyms for.
8625 # There are comment entries for values missing from this file:
8626 # # @missing: 0000..10FFFF; ISO_Comment; <none>
8627 # # @missing: 0000..10FFFF; Lowercase_Mapping; <code point>
8630 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8632 # This whole file was non-existent in early releases, so use our own
8633 # internal one if necessary.
8634 if (! -e 'PropValueAliases.txt') {
8635 $file->insert_lines(get_old_property_value_aliases());
8638 # Add any explicit cjk values
8639 $file->insert_lines(@cjk_property_values);
8641 # This line is used only for testing the code that checks for name
8642 # conflicts. There is a script Inherited, and when this line is executed
8643 # it causes there to be a name conflict with the 'Inherited' that this
8644 # program generates for this block property value
8645 #$file->insert_lines('blk; n/a; Herited');
8648 # Process each line of the file ...
8649 while ($file->next_line) {
8651 my ($property, @data) = split /\s*;\s*/;
8653 # The full name for the ccc property value is in field 2 of the
8654 # remaining ones; field 1 for all other properties. Swap ccc fields 1
8655 # and 2. (Rightmost splice removes field 2, returning it; left splice
8656 # inserts that into field 1, thus shifting former field 1 to field 2.)
8657 splice (@data, 1, 0, splice(@data, 2, 1)) if $property eq 'ccc';
8659 # If there is no short name, use the full one in element 1
8660 $data[0] = $data[1] if $data[0] eq "n/a";
8662 # Earlier releases had the pseudo property 'qc' that should expand to
8663 # the ones that replace it below.
8664 if ($property eq 'qc') {
8665 if (lc $data[0] eq 'y') {
8666 $file->insert_lines('NFC_QC; Y ; Yes',
8672 elsif (lc $data[0] eq 'n') {
8673 $file->insert_lines('NFC_QC; N ; No',
8679 elsif (lc $data[0] eq 'm') {
8680 $file->insert_lines('NFC_QC; M ; Maybe',
8681 'NFKC_QC; M ; Maybe',
8685 $file->carp_bad_line("qc followed by unexpected '$data[0]");
8690 # The first field is the short name, 2nd is the full one.
8691 my $property_object = property_ref($property);
8692 my $table = $property_object->add_match_table($data[0],
8693 Full_Name => $data[1]);
8695 # Start looking for more aliases after these two.
8696 for my $i (2 .. @data - 1) {
8697 $table->add_alias($data[$i]);
8699 } # End of looping through the file
8701 # As noted in the comments early in the program, it generates tables for
8702 # the default values for all releases, even those for which the concept
8703 # didn't exist at the time. Here we add those if missing.
8704 my $age = property_ref('age');
8705 if (defined $age && ! defined $age->table('Unassigned')) {
8706 $age->add_match_table('Unassigned');
8708 $block->add_match_table('No_Block') if -e 'Blocks.txt'
8709 && ! defined $block->table('No_Block');
8712 # Now set the default mappings of the properties from the file. This is
8713 # done after the loop because a number of properties have only @missings
8714 # entries in the file, and may not show up until the end.
8715 my @defaults = $file->get_missings;
8716 foreach my $default_ref (@defaults) {
8717 my $default = $default_ref->[0];
8718 my $property = property_ref($default_ref->[1]);
8719 $property->set_default_map($default);
8724 sub get_old_property_value_aliases () {
8725 # Returns what would be in PropValueAliases.txt if it existed in very old
8726 # versions of Unicode. It was derived from the one in 3.2, and pared
8727 # down. An attempt was made to use the existence of files to mean
8728 # inclusion or not of various aliases, but if this was not sufficient,
8729 # using version numbers was resorted to.
8731 my @return = split /\n/, <<'END';
8732 bc ; AN ; Arabic_Number
8733 bc ; B ; Paragraph_Separator
8734 bc ; CS ; Common_Separator
8735 bc ; EN ; European_Number
8736 bc ; ES ; European_Separator
8737 bc ; ET ; European_Terminator
8738 bc ; L ; Left_To_Right
8739 bc ; ON ; Other_Neutral
8740 bc ; R ; Right_To_Left
8741 bc ; WS ; White_Space
8743 # The standard combining classes are very much different in v1, so only use
8744 # ones that look right (not checked thoroughly)
8745 ccc; 0; NR ; Not_Reordered
8746 ccc; 1; OV ; Overlay
8748 ccc; 8; KV ; Kana_Voicing
8750 ccc; 202; ATBL ; Attached_Below_Left
8751 ccc; 216; ATAR ; Attached_Above_Right
8752 ccc; 218; BL ; Below_Left
8754 ccc; 222; BR ; Below_Right
8756 ccc; 228; AL ; Above_Left
8758 ccc; 232; AR ; Above_Right
8759 ccc; 234; DA ; Double_Above
8761 dt ; can ; canonical
8775 gc ; C ; Other # Cc | Cf | Cn | Co | Cs
8777 gc ; Cn ; Unassigned
8778 gc ; Co ; Private_Use
8779 gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu
8780 gc ; LC ; Cased_Letter # Ll | Lt | Lu
8781 gc ; Ll ; Lowercase_Letter
8782 gc ; Lm ; Modifier_Letter
8783 gc ; Lo ; Other_Letter
8784 gc ; Lu ; Uppercase_Letter
8785 gc ; M ; Mark # Mc | Me | Mn
8786 gc ; Mc ; Spacing_Mark
8787 gc ; Mn ; Nonspacing_Mark
8788 gc ; N ; Number # Nd | Nl | No
8789 gc ; Nd ; Decimal_Number
8790 gc ; No ; Other_Number
8791 gc ; P ; Punctuation # Pc | Pd | Pe | Pf | Pi | Po | Ps
8792 gc ; Pd ; Dash_Punctuation
8793 gc ; Pe ; Close_Punctuation
8794 gc ; Po ; Other_Punctuation
8795 gc ; Ps ; Open_Punctuation
8796 gc ; S ; Symbol # Sc | Sk | Sm | So
8797 gc ; Sc ; Currency_Symbol
8798 gc ; Sm ; Math_Symbol
8799 gc ; So ; Other_Symbol
8800 gc ; Z ; Separator # Zl | Zp | Zs
8801 gc ; Zl ; Line_Separator
8802 gc ; Zp ; Paragraph_Separator
8803 gc ; Zs ; Space_Separator
8811 if (-e 'ArabicShaping.txt') {
8812 push @return, split /\n/, <<'END';
8819 jg ; n/a ; NO_JOINING_GROUP
8827 jt ; C ; Join_Causing
8828 jt ; D ; Dual_Joining
8829 jt ; L ; Left_Joining
8830 jt ; R ; Right_Joining
8831 jt ; U ; Non_Joining
8832 jt ; T ; Transparent
8834 if ($v_version ge v3.0.0) {
8835 push @return, split /\n/, <<'END';
8839 jg ; n/a ; DALATH_RISH
8842 jg ; n/a ; FINAL_SEMKATH
8845 jg ; n/a ; HAMZA_ON_HEH_GOAL
8852 jg ; n/a ; KNOTTED_HEH
8859 jg ; n/a ; REVERSED_PE
8863 jg ; n/a ; SWASH_KAF
8865 jg ; n/a ; TEH_MARBUTA
8868 jg ; n/a ; YEH_BARREE
8869 jg ; n/a ; YEH_WITH_TAIL
8878 if (-e 'EastAsianWidth.txt') {
8879 push @return, split /\n/, <<'END';
8889 if (-e 'LineBreak.txt') {
8890 push @return, split /\n/, <<'END';
8892 lb ; AL ; Alphabetic
8893 lb ; B2 ; Break_Both
8894 lb ; BA ; Break_After
8895 lb ; BB ; Break_Before
8896 lb ; BK ; Mandatory_Break
8897 lb ; CB ; Contingent_Break
8898 lb ; CL ; Close_Punctuation
8899 lb ; CM ; Combining_Mark
8900 lb ; CR ; Carriage_Return
8901 lb ; EX ; Exclamation
8904 lb ; ID ; Ideographic
8905 lb ; IN ; Inseperable
8906 lb ; IS ; Infix_Numeric
8908 lb ; NS ; Nonstarter
8910 lb ; OP ; Open_Punctuation
8911 lb ; PO ; Postfix_Numeric
8912 lb ; PR ; Prefix_Numeric
8914 lb ; SA ; Complex_Context
8917 lb ; SY ; Break_Symbols
8923 if (-e 'DNormalizationProps.txt') {
8924 push @return, split /\n/, <<'END';
8931 if (-e 'Scripts.txt') {
8932 push @return, split /\n/, <<'END';
8934 sc ; Armn ; Armenian
8936 sc ; Bopo ; Bopomofo
8937 sc ; Cans ; Canadian_Aboriginal
8938 sc ; Cher ; Cherokee
8939 sc ; Cyrl ; Cyrillic
8940 sc ; Deva ; Devanagari
8942 sc ; Ethi ; Ethiopic
8943 sc ; Geor ; Georgian
8946 sc ; Gujr ; Gujarati
8947 sc ; Guru ; Gurmukhi
8951 sc ; Hira ; Hiragana
8952 sc ; Ital ; Old_Italic
8953 sc ; Kana ; Katakana
8958 sc ; Mlym ; Malayalam
8959 sc ; Mong ; Mongolian
8963 sc ; Qaai ; Inherited
8977 if ($v_version ge v2.0.0) {
8978 push @return, split /\n/, <<'END';
8982 dt ; vert ; vertical
8987 gc ; Lt ; Titlecase_Letter
8988 gc ; Me ; Enclosing_Mark
8989 gc ; Nl ; Letter_Number
8990 gc ; Pc ; Connector_Punctuation
8991 gc ; Sk ; Modifier_Symbol
8994 if ($v_version ge v2.1.2) {
8995 push @return, "bc ; S ; Segment_Separator\n";
8997 if ($v_version ge v2.1.5) {
8998 push @return, split /\n/, <<'END';
8999 gc ; Pf ; Final_Punctuation
9000 gc ; Pi ; Initial_Punctuation
9003 if ($v_version ge v2.1.8) {
9004 push @return, "ccc; 240; IS ; Iota_Subscript\n";
9007 if ($v_version ge v3.0.0) {
9008 push @return, split /\n/, <<'END';
9009 bc ; AL ; Arabic_Letter
9010 bc ; BN ; Boundary_Neutral
9011 bc ; LRE ; Left_To_Right_Embedding
9012 bc ; LRO ; Left_To_Right_Override
9013 bc ; NSM ; Nonspacing_Mark
9014 bc ; PDF ; Pop_Directional_Format
9015 bc ; RLE ; Right_To_Left_Embedding
9016 bc ; RLO ; Right_To_Left_Override
9018 ccc; 233; DB ; Double_Below
9022 if ($v_version ge v3.1.0) {
9023 push @return, "ccc; 226; R ; Right\n";
9029 sub output_perl_charnames_line ($$) {
9031 # Output the entries in Perl_charnames specially, using 5 digits instead
9032 # of four. This makes the entries a constant length, and simplifies
9033 # charnames.pm which this table is for. Unicode can have 6 digit
9034 # ordinals, but they are all private use or noncharacters which do not
9035 # have names, so won't be in this table.
9037 return sprintf "%05X\t%s\n", $_[0], $_[1];
9041 # This is used to store the range list of all the code points usable when
9042 # the little used $compare_versions feature is enabled.
9043 my $compare_versions_range_list;
9045 sub process_generic_property_file {
9046 # This processes a file containing property mappings and puts them
9047 # into internal map tables. It should be used to handle any property
9048 # files that have mappings from a code point or range thereof to
9049 # something else. This means almost all the UCD .txt files.
9050 # each_line_handlers() should be set to adjust the lines of these
9051 # files, if necessary, to what this routine understands:
9056 # the fields are: "codepoint-range ; property; map"
9058 # meaning the codepoints in the range all have the value 'map' under
9060 # Beginning and trailing white space in each field are not significant.
9061 # Note there is not a trailing semi-colon in the above. A trailing
9062 # semi-colon means the map is a null-string. An omitted map, as
9063 # opposed to a null-string, is assumed to be 'Y', based on Unicode
9064 # table syntax. (This could have been hidden from this routine by
9065 # doing it in the $file object, but that would require parsing of the
9066 # line there, so would have to parse it twice, or change the interface
9067 # to pass this an array. So not done.)
9069 # The map field may begin with a sequence of commands that apply to
9070 # this range. Each such command begins and ends with $CMD_DELIM.
9071 # These are used to indicate, for example, that the mapping for a
9072 # range has a non-default type.
9074 # This loops through the file, calling it's next_line() method, and
9075 # then taking the map and adding it to the property's table.
9076 # Complications arise because any number of properties can be in the
9077 # file, in any order, interspersed in any way. The first time a
9078 # property is seen, it gets information about that property and
9079 # caches it for quick retrieval later. It also normalizes the maps
9080 # so that only one of many synonyms is stored. The Unicode input
9081 # files do use some multiple synonyms.
9084 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9086 my %property_info; # To keep track of what properties
9087 # have already had entries in the
9088 # current file, and info about each,
9089 # so don't have to recompute.
9090 my $property_name; # property currently being worked on
9091 my $property_type; # and its type
9092 my $previous_property_name = ""; # name from last time through loop
9093 my $property_object; # pointer to the current property's
9095 my $property_addr; # the address of that object
9096 my $default_map; # the string that code points missing
9097 # from the file map to
9098 my $default_table; # For non-string properties, a
9099 # reference to the match table that
9100 # will contain the list of code
9101 # points that map to $default_map.
9103 # Get the next real non-comment line
9105 while ($file->next_line) {
9107 # Default replacement type; means that if parts of the range have
9108 # already been stored in our tables, the new map overrides them if
9109 # they differ more than cosmetically
9110 my $replace = $IF_NOT_EQUIVALENT;
9111 my $map_type; # Default type for the map of this range
9113 #local $to_trace = 1 if main::DEBUG;
9114 trace $_ if main::DEBUG && $to_trace;
9116 # Split the line into components
9117 my ($range, $property_name, $map, @remainder)
9118 = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
9120 # If more or less on the line than we are expecting, warn and skip
9123 $file->carp_bad_line('Extra fields');
9126 elsif ( ! defined $property_name) {
9127 $file->carp_bad_line('Missing property');
9131 # Examine the range.
9132 if ($range !~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x)
9134 $file->carp_bad_line("Range '$range' not of the form 'CP1' or 'CP1..CP2' (where CP1,2 are code points in hex)");
9138 my $high = (defined $2) ? hex $2 : $low;
9140 # For the very specialized case of comparing two Unicode
9142 if (DEBUG && $compare_versions) {
9143 if ($property_name eq 'Age') {
9145 # Only allow code points at least as old as the version
9147 my $age = pack "C*", split(/\./, $map); # v string
9148 next LINE if $age gt $compare_versions;
9152 # Again, we throw out code points younger than those of
9153 # the specified version. By now, the Age property is
9154 # populated. We use the intersection of each input range
9155 # with this property to find what code points in it are
9156 # valid. To do the intersection, we have to convert the
9157 # Age property map to a Range_list. We only have to do
9159 if (! defined $compare_versions_range_list) {
9160 my $age = property_ref('Age');
9161 if (! -e 'DAge.txt') {
9162 croak "Need to have 'DAge.txt' file to do version comparison";
9164 elsif ($age->count == 0) {
9165 croak "The 'Age' table is empty, but its file exists";
9167 $compare_versions_range_list
9168 = Range_List->new(Initialize => $age);
9171 # An undefined map is always 'Y'
9172 $map = 'Y' if ! defined $map;
9174 # Calculate the intersection of the input range with the
9175 # code points that are known in the specified version
9176 my @ranges = ($compare_versions_range_list
9177 & Range->new($low, $high))->ranges;
9179 # If the intersection is empty, throw away this range
9180 next LINE unless @ranges;
9182 # Only examine the first range this time through the loop.
9183 my $this_range = shift @ranges;
9185 # Put any remaining ranges in the queue to be processed
9186 # later. Note that there is unnecessary work here, as we
9187 # will do the intersection again for each of these ranges
9188 # during some future iteration of the LINE loop, but this
9189 # code is not used in production. The later intersections
9190 # are guaranteed to not splinter, so this will not become
9192 my $line = join ';', $property_name, $map;
9193 foreach my $range (@ranges) {
9194 $file->insert_adjusted_lines(sprintf("%04X..%04X; %s",
9200 # And process the first range, like any other.
9201 $low = $this_range->start;
9202 $high = $this_range->end;
9204 } # End of $compare_versions
9206 # If changing to a new property, get the things constant per
9208 if ($previous_property_name ne $property_name) {
9210 $property_object = property_ref($property_name);
9211 if (! defined $property_object) {
9212 $file->carp_bad_line("Unexpected property '$property_name'. Skipped");
9215 { no overloading; $property_addr = pack 'J', $property_object; }
9217 # Defer changing names until have a line that is acceptable
9218 # (the 'next' statement above means is unacceptable)
9219 $previous_property_name = $property_name;
9221 # If not the first time for this property, retrieve info about
9223 if (defined ($property_info{$property_addr}{'type'})) {
9224 $property_type = $property_info{$property_addr}{'type'};
9225 $default_map = $property_info{$property_addr}{'default'};
9227 = $property_info{$property_addr}{'pseudo_map_type'};
9229 = $property_info{$property_addr}{'default_table'};
9233 # Here, is the first time for this property. Set up the
9235 $property_type = $property_info{$property_addr}{'type'}
9236 = $property_object->type;
9238 = $property_info{$property_addr}{'pseudo_map_type'}
9239 = $property_object->pseudo_map_type;
9241 # The Unicode files are set up so that if the map is not
9242 # defined, it is a binary property
9243 if (! defined $map && $property_type != $BINARY) {
9244 if ($property_type != $UNKNOWN
9245 && $property_type != $NON_STRING)
9247 $file->carp_bad_line("No mapping defined on a non-binary property. Using 'Y' for the map");
9250 $property_object->set_type($BINARY);
9252 = $property_info{$property_addr}{'type'}
9257 # Get any @missings default for this property. This
9258 # should precede the first entry for the property in the
9259 # input file, and is located in a comment that has been
9260 # stored by the Input_file class until we access it here.
9261 # It's possible that there is more than one such line
9262 # waiting for us; collect them all, and parse
9263 my @missings_list = $file->get_missings
9264 if $file->has_missings_defaults;
9265 foreach my $default_ref (@missings_list) {
9266 my $default = $default_ref->[0];
9267 my $addr = do { no overloading; pack 'J', property_ref($default_ref->[1]); };
9269 # For string properties, the default is just what the
9270 # file says, but non-string properties should already
9271 # have set up a table for the default property value;
9272 # use the table for these, so can resolve synonyms
9273 # later to a single standard one.
9274 if ($property_type == $STRING
9275 || $property_type == $UNKNOWN)
9277 $property_info{$addr}{'missings'} = $default;
9280 $property_info{$addr}{'missings'}
9281 = $property_object->table($default);
9285 # Finished storing all the @missings defaults in the input
9286 # file so far. Get the one for the current property.
9287 my $missings = $property_info{$property_addr}{'missings'};
9289 # But we likely have separately stored what the default
9290 # should be. (This is to accommodate versions of the
9291 # standard where the @missings lines are absent or
9292 # incomplete.) Hopefully the two will match. But check
9294 $default_map = $property_object->default_map;
9296 # If the map is a ref, it means that the default won't be
9297 # processed until later, so undef it, so next few lines
9298 # will redefine it to something that nothing will match
9299 undef $default_map if ref $default_map;
9301 # Create a $default_map if don't have one; maybe a dummy
9302 # that won't match anything.
9303 if (! defined $default_map) {
9305 # Use any @missings line in the file.
9306 if (defined $missings) {
9307 if (ref $missings) {
9308 $default_map = $missings->full_name;
9309 $default_table = $missings;
9312 $default_map = $missings;
9315 # And store it with the property for outside use.
9316 $property_object->set_default_map($default_map);
9320 # Neither an @missings nor a default map. Create
9321 # a dummy one, so won't have to test definedness
9323 $default_map = '_Perl This will never be in a file
9328 # Here, we have $default_map defined, possibly in terms of
9329 # $missings, but maybe not, and possibly is a dummy one.
9330 if (defined $missings) {
9332 # Make sure there is no conflict between the two.
9333 # $missings has priority.
9334 if (ref $missings) {
9336 = $property_object->table($default_map);
9337 if (! defined $default_table
9338 || $default_table != $missings)
9340 if (! defined $default_table) {
9341 $default_table = $UNDEF;
9343 $file->carp_bad_line(<<END
9344 The \@missings line for $property_name in $file says that missings default to
9345 $missings, but we expect it to be $default_table. $missings used.
9348 $default_table = $missings;
9349 $default_map = $missings->full_name;
9351 $property_info{$property_addr}{'default_table'}
9354 elsif ($default_map ne $missings) {
9355 $file->carp_bad_line(<<END
9356 The \@missings line for $property_name in $file says that missings default to
9357 $missings, but we expect it to be $default_map. $missings used.
9360 $default_map = $missings;
9364 $property_info{$property_addr}{'default'}
9367 # If haven't done so already, find the table corresponding
9368 # to this map for non-string properties.
9369 if (! defined $default_table
9370 && $property_type != $STRING
9371 && $property_type != $UNKNOWN)
9373 $default_table = $property_info{$property_addr}
9375 = $property_object->table($default_map);
9377 } # End of is first time for this property
9378 } # End of switching properties.
9380 # Ready to process the line.
9381 # The Unicode files are set up so that if the map is not defined,
9382 # it is a binary property with value 'Y'
9383 if (! defined $map) {
9388 # If the map begins with a special command to us (enclosed in
9389 # delimiters), extract the command(s).
9390 while ($map =~ s/ ^ $CMD_DELIM (.*?) $CMD_DELIM //x) {
9392 if ($command =~ / ^ $REPLACE_CMD= (.*) /x) {
9395 elsif ($command =~ / ^ $MAP_TYPE_CMD= (.*) /x) {
9399 $file->carp_bad_line("Unknown command line: '$1'");
9405 if ($default_map eq $CODE_POINT && $map =~ / ^ $code_point_re $/x)
9408 # Here, we have a map to a particular code point, and the
9409 # default map is to a code point itself. If the range
9410 # includes the particular code point, change that portion of
9411 # the range to the default. This makes sure that in the final
9412 # table only the non-defaults are listed.
9413 my $decimal_map = hex $map;
9414 if ($low <= $decimal_map && $decimal_map <= $high) {
9416 # If the range includes stuff before or after the map
9417 # we're changing, split it and process the split-off parts
9419 if ($low < $decimal_map) {
9420 $file->insert_adjusted_lines(
9421 sprintf("%04X..%04X; %s; %s",
9427 if ($high > $decimal_map) {
9428 $file->insert_adjusted_lines(
9429 sprintf("%04X..%04X; %s; %s",
9435 $low = $high = $decimal_map;
9440 # If we can tell that this is a synonym for the default map, use
9441 # the default one instead.
9442 if ($property_type != $STRING
9443 && $property_type != $UNKNOWN)
9445 my $table = $property_object->table($map);
9446 if (defined $table && $table == $default_table) {
9447 $map = $default_map;
9451 # And figure out the map type if not known.
9452 if (! defined $map_type || $map_type == $COMPUTE_NO_MULTI_CP) {
9453 if ($map eq "") { # Nulls are always $NULL map type
9455 } # Otherwise, non-strings, and those that don't allow
9456 # $MULTI_CP, and those that aren't multiple code points are
9459 (($property_type != $STRING && $property_type != $UNKNOWN)
9460 || (defined $map_type && $map_type == $COMPUTE_NO_MULTI_CP)
9461 || $map !~ /^ $code_point_re ( \ $code_point_re )+ $ /x)
9466 $map_type = $MULTI_CP;
9470 $property_object->add_map($low, $high,
9473 Replace => $replace);
9474 } # End of loop through file's lines
9480 { # Closure for UnicodeData.txt handling
9482 # This file was the first one in the UCD; its design leads to some
9483 # awkwardness in processing. Here is a sample line:
9484 # 0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061;
9485 # The fields in order are:
9486 my $i = 0; # The code point is in field 0, and is shifted off.
9487 my $CHARNAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A")
9488 my $CATEGORY = $i++; # category (e.g. "Lu")
9489 my $CCC = $i++; # Canonical combining class (e.g. "230")
9490 my $BIDI = $i++; # directional class (e.g. "L")
9491 my $PERL_DECOMPOSITION = $i++; # decomposition mapping
9492 my $PERL_DECIMAL_DIGIT = $i++; # decimal digit value
9493 my $NUMERIC_TYPE_OTHER_DIGIT = $i++; # digit value, like a superscript
9494 # Dual-use in this program; see below
9495 my $NUMERIC = $i++; # numeric value
9496 my $MIRRORED = $i++; # ? mirrored
9497 my $UNICODE_1_NAME = $i++; # name in Unicode 1.0
9498 my $COMMENT = $i++; # iso comment
9499 my $UPPER = $i++; # simple uppercase mapping
9500 my $LOWER = $i++; # simple lowercase mapping
9501 my $TITLE = $i++; # simple titlecase mapping
9502 my $input_field_count = $i;
9504 # This routine in addition outputs these extra fields:
9505 my $DECOMP_TYPE = $i++; # Decomposition type
9507 # These fields are modifications of ones above, and are usually
9508 # suppressed; they must come last, as for speed, the loop upper bound is
9509 # normally set to ignore them
9510 my $NAME = $i++; # This is the strict name field, not the one that
9512 my $DECOMP_MAP = $i++; # Strict decomposition mapping; not the one used
9513 # by Unicode::Normalize
9514 my $last_field = $i - 1;
9516 # All these are read into an array for each line, with the indices defined
9517 # above. The empty fields in the example line above indicate that the
9518 # value is defaulted. The handler called for each line of the input
9519 # changes these to their defaults.
9521 # Here are the official names of the properties, in a parallel array:
9523 $field_names[$BIDI] = 'Bidi_Class';
9524 $field_names[$CATEGORY] = 'General_Category';
9525 $field_names[$CCC] = 'Canonical_Combining_Class';
9526 $field_names[$CHARNAME] = 'Perl_Charnames';
9527 $field_names[$COMMENT] = 'ISO_Comment';
9528 $field_names[$DECOMP_MAP] = 'Decomposition_Mapping';
9529 $field_names[$DECOMP_TYPE] = 'Decomposition_Type';
9530 $field_names[$LOWER] = 'Lowercase_Mapping';
9531 $field_names[$MIRRORED] = 'Bidi_Mirrored';
9532 $field_names[$NAME] = 'Name';
9533 $field_names[$NUMERIC] = 'Numeric_Value';
9534 $field_names[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric_Type';
9535 $field_names[$PERL_DECIMAL_DIGIT] = 'Perl_Decimal_Digit';
9536 $field_names[$PERL_DECOMPOSITION] = 'Perl_Decomposition_Mapping';
9537 $field_names[$TITLE] = 'Titlecase_Mapping';
9538 $field_names[$UNICODE_1_NAME] = 'Unicode_1_Name';
9539 $field_names[$UPPER] = 'Uppercase_Mapping';
9541 # Some of these need a little more explanation:
9542 # The $PERL_DECIMAL_DIGIT field does not lead to an official Unicode
9543 # property, but is used in calculating the Numeric_Type. Perl however,
9544 # creates a file from this field, so a Perl property is created from it.
9545 # Similarly, the Other_Digit field is used only for calculating the
9546 # Numeric_Type, and so it can be safely re-used as the place to store
9547 # the value for Numeric_Type; hence it is referred to as
9548 # $NUMERIC_TYPE_OTHER_DIGIT.
9549 # The input field named $PERL_DECOMPOSITION is a combination of both the
9550 # decomposition mapping and its type. Perl creates a file containing
9551 # exactly this field, so it is used for that. The two properties are
9552 # separated into two extra output fields, $DECOMP_MAP and $DECOMP_TYPE.
9553 # $DECOMP_MAP is usually suppressed (unless the lists are changed to
9554 # output it), as Perl doesn't use it directly.
9555 # The input field named here $CHARNAME is used to construct the
9556 # Perl_Charnames property, which is a combination of the Name property
9557 # (which the input field contains), and the Unicode_1_Name property, and
9558 # others from other files. Since, the strict Name property is not used
9559 # by Perl, this field is used for the table that Perl does use. The
9560 # strict Name property table is usually suppressed (unless the lists are
9561 # changed to output it), so it is accumulated in a separate field,
9562 # $NAME, which to save time is discarded unless the table is actually to
9565 # This file is processed like most in this program. Control is passed to
9566 # process_generic_property_file() which calls filter_UnicodeData_line()
9567 # for each input line. This filter converts the input into line(s) that
9568 # process_generic_property_file() understands. There is also a setup
9569 # routine called before any of the file is processed, and a handler for
9570 # EOF processing, all in this closure.
9572 # A huge speed-up occurred at the cost of some added complexity when these
9573 # routines were altered to buffer the outputs into ranges. Almost all the
9574 # lines of the input file apply to just one code point, and for most
9575 # properties, the map for the next code point up is the same as the
9576 # current one. So instead of creating a line for each property for each
9577 # input line, filter_UnicodeData_line() remembers what the previous map
9578 # of a property was, and doesn't generate a line to pass on until it has
9579 # to, as when the map changes; and that passed-on line encompasses the
9580 # whole contiguous range of code points that have the same map for that
9581 # property. This means a slight amount of extra setup, and having to
9582 # flush these buffers on EOF, testing if the maps have changed, plus
9583 # remembering state information in the closure. But it means a lot less
9584 # real time in not having to change the data base for each property on
9587 # Another complication is that there are already a few ranges designated
9588 # in the input. There are two lines for each, with the same maps except
9589 # the code point and name on each line. This was actually the hardest
9590 # thing to design around. The code points in those ranges may actually
9591 # have real maps not given by these two lines. These maps will either
9592 # be algorithmically determinable, or in the extracted files furnished
9593 # with the UCD. In the event of conflicts between these extracted files,
9594 # and this one, Unicode says that this one prevails. But it shouldn't
9595 # prevail for conflicts that occur in these ranges. The data from the
9596 # extracted files prevails in those cases. So, this program is structured
9597 # so that those files are processed first, storing maps. Then the other
9598 # files are processed, generally overwriting what the extracted files
9599 # stored. But just the range lines in this input file are processed
9600 # without overwriting. This is accomplished by adding a special string to
9601 # the lines output to tell process_generic_property_file() to turn off the
9602 # overwriting for just this one line.
9603 # A similar mechanism is used to tell it that the map is of a non-default
9606 sub setup_UnicodeData { # Called before any lines of the input are read
9608 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9610 # Create a new property specially located that is a combination of the
9611 # various Name properties: Name, Unicode_1_Name, Named Sequences, and
9612 # Name_Alias properties. (The final duplicates elements of the
9613 # first.) A comment for it will later be constructed based on the
9614 # actual properties present and used
9615 $perl_charname = Property->new('Perl_Charnames',
9616 Core_Access => '\N{...} and "use charnames"',
9618 Directory => File::Spec->curdir(),
9620 Internal_Only_Warning => 1,
9621 Perl_Extension => 1,
9622 Range_Size_1 => \&output_perl_charnames_line,
9626 my $Perl_decomp = Property->new('Perl_Decomposition_Mapping',
9627 Directory => File::Spec->curdir(),
9628 File => 'Decomposition',
9629 Format => $DECOMP_STRING_FORMAT,
9630 Internal_Only_Warning => 1,
9631 Perl_Extension => 1,
9632 Default_Map => $CODE_POINT,
9634 # normalize.pm can't cope with these
9635 Output_Range_Counts => 0,
9637 # This is a specially formatted table
9638 # explicitly for normalize.pm, which
9639 # is expecting a particular format,
9640 # which means that mappings containing
9641 # multiple code points are in the main
9643 Map_Type => $COMPUTE_NO_MULTI_CP,
9646 $Perl_decomp->add_comment(join_lines(<<END
9647 This mapping is a combination of the Unicode 'Decomposition_Type' and
9648 'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is
9649 identical to the official Unicode 'Decomposition_Mapping' property except for
9651 1) It omits the algorithmically determinable Hangul syllable decompositions,
9652 which normalize.pm handles algorithmically.
9653 2) It contains the decomposition type as well. Non-canonical decompositions
9654 begin with a word in angle brackets, like <super>, which denotes the
9655 compatible decomposition type. If the map does not begin with the <angle
9656 brackets>, the decomposition is canonical.
9660 my $Decimal_Digit = Property->new("Perl_Decimal_Digit",
9662 Perl_Extension => 1,
9663 File => 'Digit', # Trad. location
9664 Directory => $map_directory,
9668 $Decimal_Digit->add_comment(join_lines(<<END
9669 This file gives the mapping of all code points which represent a single
9670 decimal digit [0-9] to their respective digits. For example, the code point
9671 U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those
9672 that have Numeric_Type=Decimal; not special things, like subscripts nor Roman
9677 # These properties are not used for generating anything else, and are
9678 # usually not output. By making them last in the list, we can just
9679 # change the high end of the loop downwards to avoid the work of
9680 # generating a table(s) that is/are just going to get thrown away.
9681 if (! property_ref('Decomposition_Mapping')->to_output_map
9682 && ! property_ref('Name')->to_output_map)
9684 $last_field = min($NAME, $DECOMP_MAP) - 1;
9685 } elsif (property_ref('Decomposition_Mapping')->to_output_map) {
9686 $last_field = $DECOMP_MAP;
9687 } elsif (property_ref('Name')->to_output_map) {
9688 $last_field = $NAME;
9693 my $first_time = 1; # ? Is this the first line of the file
9694 my $in_range = 0; # ? Are we in one of the file's ranges
9695 my $previous_cp; # hex code point of previous line
9696 my $decimal_previous_cp = -1; # And its decimal equivalent
9697 my @start; # For each field, the current starting
9698 # code point in hex for the range
9699 # being accumulated.
9700 my @fields; # The input fields;
9701 my @previous_fields; # And those from the previous call
9703 sub filter_UnicodeData_line {
9704 # Handle a single input line from UnicodeData.txt; see comments above
9705 # Conceptually this takes a single line from the file containing N
9706 # properties, and converts it into N lines with one property per line,
9707 # which is what the final handler expects. But there are
9708 # complications due to the quirkiness of the input file, and to save
9709 # time, it accumulates ranges where the property values don't change
9710 # and only emits lines when necessary. This is about an order of
9711 # magnitude fewer lines emitted.
9714 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9716 # $_ contains the input line.
9717 # -1 in split means retain trailing null fields
9718 (my $cp, @fields) = split /\s*;\s*/, $_, -1;
9720 #local $to_trace = 1 if main::DEBUG;
9721 trace $cp, @fields , $input_field_count if main::DEBUG && $to_trace;
9722 if (@fields > $input_field_count) {
9723 $file->carp_bad_line('Extra fields');
9728 my $decimal_cp = hex $cp;
9730 # We have to output all the buffered ranges when the next code point
9731 # is not exactly one after the previous one, which means there is a
9732 # gap in the ranges.
9733 my $force_output = ($decimal_cp != $decimal_previous_cp + 1);
9735 # The decomposition mapping field requires special handling. It looks
9738 # <compat> 0032 0020
9741 # The decomposition type is enclosed in <brackets>; if missing, it
9742 # means the type is canonical. There are two decomposition mapping
9743 # tables: the one for use by Perl's normalize.pm has a special format
9744 # which is this field intact; the other, for general use is of
9745 # standard format. In either case we have to find the decomposition
9746 # type. Empty fields have None as their type, and map to the code
9748 if ($fields[$PERL_DECOMPOSITION] eq "") {
9749 $fields[$DECOMP_TYPE] = 'None';
9750 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION] = $CODE_POINT;
9753 ($fields[$DECOMP_TYPE], my $map) = $fields[$PERL_DECOMPOSITION]
9754 =~ / < ( .+? ) > \s* ( .+ ) /x;
9755 if (! defined $fields[$DECOMP_TYPE]) {
9756 $fields[$DECOMP_TYPE] = 'Canonical';
9757 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION];
9760 $fields[$DECOMP_MAP] = $map;
9764 # The 3 numeric fields also require special handling. The 2 digit
9765 # fields must be either empty or match the number field. This means
9766 # that if it is empty, they must be as well, and the numeric type is
9767 # None, and the numeric value is 'Nan'.
9768 # The decimal digit field must be empty or match the other digit
9769 # field. If the decimal digit field is non-empty, the code point is
9770 # a decimal digit, and the other two fields will have the same value.
9771 # If it is empty, but the other digit field is non-empty, the code
9772 # point is an 'other digit', and the number field will have the same
9773 # value as the other digit field. If the other digit field is empty,
9774 # but the number field is non-empty, the code point is a generic
9776 if ($fields[$NUMERIC] eq "") {
9777 if ($fields[$PERL_DECIMAL_DIGIT] ne ""
9778 || $fields[$NUMERIC_TYPE_OTHER_DIGIT] ne ""
9780 $file->carp_bad_line("Numeric values inconsistent. Trying to process anyway");
9782 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'None';
9783 $fields[$NUMERIC] = 'NaN';
9786 $file->carp_bad_line("'$fields[$NUMERIC]' should be a whole or rational number. Processing as if it were") if $fields[$NUMERIC] !~ qr{ ^ -? \d+ ( / \d+ )? $ }x;
9787 if ($fields[$PERL_DECIMAL_DIGIT] ne "") {
9788 $file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$PERL_DECIMAL_DIGIT] != $fields[$NUMERIC];
9789 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Decimal';
9791 elsif ($fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "") {
9792 $file->carp_bad_line("$fields[$NUMERIC_TYPE_OTHER_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$NUMERIC_TYPE_OTHER_DIGIT] != $fields[$NUMERIC];
9793 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Digit';
9796 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric';
9798 # Rationals require extra effort.
9799 register_fraction($fields[$NUMERIC])
9800 if $fields[$NUMERIC] =~ qr{/};
9804 # For the properties that have empty fields in the file, and which
9805 # mean something different from empty, change them to that default.
9806 # Certain fields just haven't been empty so far in any Unicode
9807 # version, so don't look at those, namely $MIRRORED, $BIDI, $CCC,
9808 # $CATEGORY. This leaves just the two fields, and so we hard-code in
9809 # the defaults; which are very unlikely to ever change.
9810 $fields[$UPPER] = $CODE_POINT if $fields[$UPPER] eq "";
9811 $fields[$LOWER] = $CODE_POINT if $fields[$LOWER] eq "";
9813 # UAX44 says that if title is empty, it is the same as whatever upper
9815 $fields[$TITLE] = $fields[$UPPER] if $fields[$TITLE] eq "";
9817 # There are a few pairs of lines like:
9818 # AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
9819 # D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
9820 # that define ranges. These should be processed after the fields are
9821 # adjusted above, as they may override some of them; but mostly what
9822 # is left is to possibly adjust the $CHARNAME field. The names of all the
9823 # paired lines start with a '<', but this is also true of '<control>,
9824 # which isn't one of these special ones.
9825 if ($fields[$CHARNAME] eq '<control>') {
9827 # Some code points in this file have the pseudo-name
9828 # '<control>', but the official name for such ones is the null
9829 # string. For charnames.pm, we use the Unicode version 1 name
9830 $fields[$NAME] = "";
9831 $fields[$CHARNAME] = $fields[$UNICODE_1_NAME];
9833 # We had better not be in between range lines.
9835 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9839 elsif (substr($fields[$CHARNAME], 0, 1) ne '<') {
9841 # Here is a non-range line. We had better not be in between range
9844 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9847 if ($fields[$CHARNAME] =~ s/- $cp $//x) {
9849 # These are code points whose names end in their code points,
9850 # which means the names are algorithmically derivable from the
9851 # code points. To shorten the output Name file, the algorithm
9852 # for deriving these is placed in the file instead of each
9853 # code point, so they have map type $CP_IN_NAME
9854 $fields[$CHARNAME] = $CMD_DELIM
9859 . $fields[$CHARNAME];
9861 $fields[$NAME] = $fields[$CHARNAME];
9863 elsif ($fields[$CHARNAME] =~ /^<(.+), First>$/) {
9864 $fields[$CHARNAME] = $fields[$NAME] = $1;
9866 # Here we are at the beginning of a range pair.
9868 $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$CHARNAME]'. Trying anyway");
9872 # Because the properties in the range do not overwrite any already
9873 # in the db, we must flush the buffers of what's already there, so
9874 # they get handled in the normal scheme.
9878 elsif ($fields[$CHARNAME] !~ s/^<(.+), Last>$/$1/) {
9879 $file->carp_bad_line("Unexpected name starting with '<' $fields[$CHARNAME]. Ignoring this line.");
9883 else { # Here, we are at the last line of a range pair.
9886 $file->carp_bad_line("Unexpected end of range $fields[$CHARNAME] when not in one. Ignoring this line.");
9892 $fields[$NAME] = $fields[$CHARNAME];
9894 # Check that the input is valid: that the closing of the range is
9895 # the same as the beginning.
9896 foreach my $i (0 .. $last_field) {
9897 next if $fields[$i] eq $previous_fields[$i];
9898 $file->carp_bad_line("Expecting '$fields[$i]' to be the same as '$previous_fields[$i]'. Bad News. Trying anyway");
9901 # The processing differs depending on the type of range,
9902 # determined by its $CHARNAME
9903 if ($fields[$CHARNAME] =~ /^Hangul Syllable/) {
9905 # Check that the data looks right.
9906 if ($decimal_previous_cp != $SBase) {
9907 $file->carp_bad_line("Unexpected Hangul syllable start = $previous_cp. Bad News. Results will be wrong");
9909 if ($decimal_cp != $SBase + $SCount - 1) {
9910 $file->carp_bad_line("Unexpected Hangul syllable end = $cp. Bad News. Results will be wrong");
9913 # The Hangul syllable range has a somewhat complicated name
9914 # generation algorithm. Each code point in it has a canonical
9915 # decomposition also computable by an algorithm. The
9916 # perl decomposition map table built from these is used only
9917 # by normalize.pm, which has the algorithm built in it, so the
9918 # decomposition maps are not needed, and are large, so are
9919 # omitted from it. If the full decomposition map table is to
9920 # be output, the decompositions are generated for it, in the
9921 # EOF handling code for this input file.
9923 $previous_fields[$DECOMP_TYPE] = 'Canonical';
9925 # This range is stored in our internal structure with its
9926 # own map type, different from all others.
9927 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
9933 . $fields[$CHARNAME];
9935 elsif ($fields[$CHARNAME] =~ /^CJK/) {
9937 # The name for these contains the code point itself, and all
9938 # are defined to have the same base name, regardless of what
9939 # is in the file. They are stored in our internal structure
9940 # with a map type of $CP_IN_NAME
9941 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
9947 . 'CJK UNIFIED IDEOGRAPH';
9950 elsif ($fields[$CATEGORY] eq 'Co'
9951 || $fields[$CATEGORY] eq 'Cs')
9953 # The names of all the code points in these ranges are set to
9954 # null, as there are no names for the private use and
9955 # surrogate code points.
9957 $previous_fields[$CHARNAME] = $previous_fields[$NAME] = "";
9960 $file->carp_bad_line("Unexpected code point range $fields[$CHARNAME] because category is $fields[$CATEGORY]. Attempting to process it.");
9963 # The first line of the range caused everything else to be output,
9964 # and then its values were stored as the beginning values for the
9965 # next set of ranges, which this one ends. Now, for each value,
9966 # add a command to tell the handler that these values should not
9967 # replace any existing ones in our database.
9968 foreach my $i (0 .. $last_field) {
9969 $previous_fields[$i] = $CMD_DELIM
9974 . $previous_fields[$i];
9977 # And change things so it looks like the entire range has been
9978 # gone through with this being the final part of it. Adding the
9979 # command above to each field will cause this range to be flushed
9980 # during the next iteration, as it guaranteed that the stored
9981 # field won't match whatever value the next one has.
9983 $decimal_previous_cp = $decimal_cp;
9985 # We are now set up for the next iteration; so skip the remaining
9986 # code in this subroutine that does the same thing, but doesn't
9987 # know about these ranges.
9993 # On the very first line, we fake it so the code below thinks there is
9994 # nothing to output, and initialize so that when it does get output it
9995 # uses the first line's values for the lowest part of the range.
9996 # (One could avoid this by using peek(), but then one would need to
9997 # know the adjustments done above and do the same ones in the setup
9998 # routine; not worth it)
10001 @previous_fields = @fields;
10002 @start = ($cp) x scalar @fields;
10003 $decimal_previous_cp = $decimal_cp - 1;
10006 # For each field, output the stored up ranges that this code point
10007 # doesn't fit in. Earlier we figured out if all ranges should be
10008 # terminated because of changing the replace or map type styles, or if
10009 # there is a gap between this new code point and the previous one, and
10010 # that is stored in $force_output. But even if those aren't true, we
10011 # need to output the range if this new code point's value for the
10012 # given property doesn't match the stored range's.
10013 #local $to_trace = 1 if main::DEBUG;
10014 foreach my $i (0 .. $last_field) {
10015 my $field = $fields[$i];
10016 if ($force_output || $field ne $previous_fields[$i]) {
10018 # Flush the buffer of stored values.
10019 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
10021 # Start a new range with this code point and its value
10023 $previous_fields[$i] = $field;
10027 # Set the values for the next time.
10028 $previous_cp = $cp;
10029 $decimal_previous_cp = $decimal_cp;
10031 # The input line has generated whatever adjusted lines are needed, and
10032 # should not be looked at further.
10037 sub EOF_UnicodeData {
10038 # Called upon EOF to flush the buffers, and create the Hangul
10039 # decomposition mappings if needed.
10042 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10044 # Flush the buffers.
10045 foreach my $i (1 .. $last_field) {
10046 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
10049 if (-e 'Jamo.txt') {
10051 # The algorithm is published by Unicode, based on values in
10052 # Jamo.txt, (which should have been processed before this
10053 # subroutine), and the results left in %Jamo
10055 Carp::my_carp_bug("Jamo.txt should be processed before Unicode.txt. Hangul syllables not generated.");
10059 # If the full decomposition map table is being output, insert
10060 # into it the Hangul syllable mappings. This is to avoid having
10061 # to publish a subroutine in it to compute them. (which would
10062 # essentially be this code.) This uses the algorithm published by
10064 if (property_ref('Decomposition_Mapping')->to_output_map) {
10065 for (my $S = $SBase; $S < $SBase + $SCount; $S++) {
10067 my $SIndex = $S - $SBase;
10068 my $L = $LBase + $SIndex / $NCount;
10069 my $V = $VBase + ($SIndex % $NCount) / $TCount;
10070 my $T = $TBase + $SIndex % $TCount;
10072 trace "L=$L, V=$V, T=$T" if main::DEBUG && $to_trace;
10073 my $decomposition = sprintf("%04X %04X", $L, $V);
10074 $decomposition .= sprintf(" %04X", $T) if $T != $TBase;
10075 $file->insert_adjusted_lines(
10076 sprintf("%04X; Decomposition_Mapping; %s",
10086 sub filter_v1_ucd {
10087 # Fix UCD lines in version 1. This is probably overkill, but this
10088 # fixes some glaring errors in Version 1 UnicodeData.txt. That file:
10089 # 1) had many Hangul (U+3400 - U+4DFF) code points that were later
10090 # removed. This program retains them
10091 # 2) didn't include ranges, which it should have, and which are now
10092 # added in @corrected_lines below. It was hand populated by
10093 # taking the data from Version 2, verified by analyzing
10095 # 3) There is a syntax error in the entry for U+09F8 which could
10096 # cause problems for utf8_heavy, and so is changed. It's
10097 # numeric value was simply a minus sign, without any number.
10098 # (Eventually Unicode changed the code point to non-numeric.)
10099 # 4) The decomposition types often don't match later versions
10100 # exactly, and the whole syntax of that field is different; so
10101 # the syntax is changed as well as the types to their later
10102 # terminology. Otherwise normalize.pm would be very unhappy
10103 # 5) Many ccc classes are different. These are left intact.
10104 # 6) U+FF10 - U+FF19 are missing their numeric values in all three
10105 # fields. These are unchanged because it doesn't really cause
10106 # problems for Perl.
10107 # 7) A number of code points, such as controls, don't have their
10108 # Unicode Version 1 Names in this file. These are unchanged.
10110 my @corrected_lines = split /\n/, <<'END';
10111 4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
10112 9FA5;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
10113 E000;<Private Use, First>;Co;0;L;;;;;N;;;;;
10114 F8FF;<Private Use, Last>;Co;0;L;;;;;N;;;;;
10115 F900;<CJK Compatibility Ideograph, First>;Lo;0;L;;;;;N;;;;;
10116 FA2D;<CJK Compatibility Ideograph, Last>;Lo;0;L;;;;;N;;;;;
10120 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10122 #local $to_trace = 1 if main::DEBUG;
10123 trace $_ if main::DEBUG && $to_trace;
10125 # -1 => retain trailing null fields
10126 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10128 # At the first place that is wrong in the input, insert all the
10129 # corrections, replacing the wrong line.
10130 if ($code_point eq '4E00') {
10131 my @copy = @corrected_lines;
10133 ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10135 $file->insert_lines(@copy);
10139 if ($fields[$NUMERIC] eq '-') {
10140 $fields[$NUMERIC] = '-1'; # This is what 2.0 made it.
10143 if ($fields[$PERL_DECOMPOSITION] ne "") {
10145 # Several entries have this change to superscript 2 or 3 in the
10146 # middle. Convert these to the modern version, which is to use
10147 # the actual U+00B2 and U+00B3 (the superscript forms) instead.
10148 # So 'HHHH HHHH <+sup> 0033 <-sup> HHHH' becomes
10149 # 'HHHH HHHH 00B3 HHHH'.
10150 # It turns out that all of these that don't have another
10151 # decomposition defined at the beginning of the line have the
10152 # <square> decomposition in later releases.
10153 if ($code_point ne '00B2' && $code_point ne '00B3') {
10154 if ($fields[$PERL_DECOMPOSITION]
10155 =~ s/<\+sup> 003([23]) <-sup>/00B$1/)
10157 if (substr($fields[$PERL_DECOMPOSITION], 0, 1) ne '<') {
10158 $fields[$PERL_DECOMPOSITION] = '<square> '
10159 . $fields[$PERL_DECOMPOSITION];
10164 # If is like '<+circled> 0052 <-circled>', convert to
10166 $fields[$PERL_DECOMPOSITION] =~
10167 s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/x;
10169 # Convert '<join> HHHH HHHH <join>' to '<medial> HHHH HHHH', etc.
10170 $fields[$PERL_DECOMPOSITION] =~
10171 s/ <join> \s* (.*?) \s* <no-join> /<final> $1/x
10172 or $fields[$PERL_DECOMPOSITION] =~
10173 s/ <join> \s* (.*?) \s* <join> /<medial> $1/x
10174 or $fields[$PERL_DECOMPOSITION] =~
10175 s/ <no-join> \s* (.*?) \s* <join> /<initial> $1/x
10176 or $fields[$PERL_DECOMPOSITION] =~
10177 s/ <no-join> \s* (.*?) \s* <no-join> /<isolated> $1/x;
10179 # Convert '<break> HHHH HHHH <break>' to '<break> HHHH', etc.
10180 $fields[$PERL_DECOMPOSITION] =~
10181 s/ <(break|no-break)> \s* (.*?) \s* <\1> /<$1> $2/x;
10183 # Change names to modern form.
10184 $fields[$PERL_DECOMPOSITION] =~ s/<font variant>/<font>/g;
10185 $fields[$PERL_DECOMPOSITION] =~ s/<no-break>/<noBreak>/g;
10186 $fields[$PERL_DECOMPOSITION] =~ s/<circled>/<circle>/g;
10187 $fields[$PERL_DECOMPOSITION] =~ s/<break>/<fraction>/g;
10189 # One entry has weird braces
10190 $fields[$PERL_DECOMPOSITION] =~ s/[{}]//g;
10193 $_ = join ';', $code_point, @fields;
10194 trace $_ if main::DEBUG && $to_trace;
10198 sub filter_v2_1_5_ucd {
10199 # A dozen entries in this 2.1.5 file had the mirrored and numeric
10200 # columns swapped; These all had mirrored be 'N'. So if the numeric
10201 # column appears to be N, swap it back.
10203 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10204 if ($fields[$NUMERIC] eq 'N') {
10205 $fields[$NUMERIC] = $fields[$MIRRORED];
10206 $fields[$MIRRORED] = 'N';
10207 $_ = join ';', $code_point, @fields;
10212 sub filter_v6_ucd {
10214 # Unicode 6.0 co-opted the name BELL for U+1F514, so change the input
10215 # to pretend that U+0007 is ALERT instead, and for Perl 5.14, don't
10216 # allow the BELL name for U+1F514, so that the old usage can be
10217 # deprecated for one cycle.
10219 return if $_ !~ /^(?:0007|1F514|070F);/;
10221 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10222 if ($code_point eq '0007') {
10223 $fields[$CHARNAME] = "ALERT";
10225 elsif ($code_point eq '070F') { # Unicode Corrigendum #8; see
10226 # http://www.unicode.org/versions/corrigendum8.html
10227 $fields[$BIDI] = "AL";
10229 elsif ($^V lt v5.15.0) { # For 5.16 will convert to use Unicode's name
10230 $fields[$CHARNAME] = "";
10233 $_ = join ';', $code_point, @fields;
10237 } # End closure for UnicodeData
10239 sub process_GCB_test {
10242 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10244 while ($file->next_line) {
10245 push @backslash_X_tests, $_;
10251 sub process_NamedSequences {
10252 # NamedSequences.txt entries are just added to an array. Because these
10253 # don't look like the other tables, they have their own handler.
10255 # LATIN CAPITAL LETTER A WITH MACRON AND GRAVE;0100 0300
10257 # This just adds the sequence to an array for later handling
10260 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10262 while ($file->next_line) {
10263 my ($name, $sequence, @remainder) = split /\s*;\s*/, $_, -1;
10265 $file->carp_bad_line(
10266 "Doesn't look like 'KHMER VOWEL SIGN OM;17BB 17C6'");
10270 # Note single \t in keeping with special output format of
10271 # Perl_charnames. But it turns out that the code points don't have to
10272 # be 5 digits long, like the rest, based on the internal workings of
10273 # charnames.pm. This could be easily changed for consistency.
10274 push @named_sequences, "$sequence\t$name";
10283 sub filter_early_ea_lb {
10284 # Fixes early EastAsianWidth.txt and LineBreak.txt files. These had a
10285 # third field be the name of the code point, which can be ignored in
10286 # most cases. But it can be meaningful if it marks a range:
10287 # 33FE;W;IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY THIRTY-ONE
10288 # 3400;W;<CJK Ideograph Extension A, First>
10290 # We need to see the First in the example above to know it's a range.
10291 # They did not use the later range syntaxes. This routine changes it
10292 # to use the modern syntax.
10293 # $1 is the Input_file object.
10295 my @fields = split /\s*;\s*/;
10296 if ($fields[2] =~ /^<.*, First>/) {
10297 $first_range = $fields[0];
10300 elsif ($fields[2] =~ /^<.*, Last>/) {
10301 $_ = $_ = "$first_range..$fields[0]; $fields[1]";
10304 undef $first_range;
10305 $_ = "$fields[0]; $fields[1]";
10312 sub filter_old_style_arabic_shaping {
10313 # Early versions used a different term for the later one.
10315 my @fields = split /\s*;\s*/;
10316 $fields[3] =~ s/<no shaping>/No_Joining_Group/;
10317 $fields[3] =~ s/\s+/_/g; # Change spaces to underscores
10318 $_ = join ';', @fields;
10322 sub filter_arabic_shaping_line {
10323 # ArabicShaping.txt has entries that look like:
10324 # 062A; TEH; D; BEH
10325 # The field containing 'TEH' is not used. The next field is Joining_Type
10326 # and the last is Joining_Group
10327 # This generates two lines to pass on, one for each property on the input
10331 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10333 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10336 $file->carp_bad_line('Extra fields');
10341 $file->insert_adjusted_lines("$fields[0]; Joining_Group; $fields[3]");
10342 $_ = "$fields[0]; Joining_Type; $fields[2]";
10347 sub setup_special_casing {
10348 # SpecialCasing.txt contains the non-simple case change mappings. The
10349 # simple ones are in UnicodeData.txt, which should already have been read
10350 # in to the full property data structures, so as to initialize these with
10351 # the simple ones. Then the SpecialCasing.txt entries overwrite the ones
10352 # which have different full mappings.
10354 # This routine sees if the simple mappings are to be output, and if so,
10355 # copies what has already been put into the full mapping tables, while
10356 # they still contain only the simple mappings.
10358 # The reason it is done this way is that the simple mappings are probably
10359 # not going to be output, so it saves work to initialize the full tables
10360 # with the simple mappings, and then overwrite those relatively few
10361 # entries in them that have different full mappings, and thus skip the
10362 # simple mapping tables altogether.
10365 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10367 # For each of the case change mappings...
10368 foreach my $case ('lc', 'tc', 'uc') {
10369 my $full = property_ref($case);
10370 unless (defined $full && ! $full->is_empty) {
10371 Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
10374 # The simple version's name in each mapping merely has an 's' in front
10375 # of the full one's
10376 my $simple = property_ref('s' . $case);
10377 $simple->initialize($full) if $simple->to_output_map();
10383 sub filter_special_casing_line {
10384 # Change the format of $_ from SpecialCasing.txt into something that the
10385 # generic handler understands. Each input line contains three case
10386 # mappings. This will generate three lines to pass to the generic handler
10387 # for each of those.
10389 # The input syntax (after stripping comments and trailing white space is
10390 # like one of the following (with the final two being entries that we
10392 # 00DF; 00DF; 0053 0073; 0053 0053; # LATIN SMALL LETTER SHARP S
10393 # 03A3; 03C2; 03A3; 03A3; Final_Sigma;
10394 # 0307; ; 0307; 0307; tr After_I; # COMBINING DOT ABOVE
10395 # Note the trailing semi-colon, unlike many of the input files. That
10396 # means that there will be an extra null field generated by the split
10399 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10401 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10403 # field #4 is when this mapping is conditional. If any of these get
10404 # implemented, it would be by hard-coding in the casing functions in the
10405 # Perl core, not through tables. But if there is a new condition we don't
10406 # know about, output a warning. We know about all the conditions through
10408 if ($fields[4] ne "") {
10409 my @conditions = split ' ', $fields[4];
10410 if ($conditions[0] ne 'tr' # We know that these languages have
10411 # conditions, and some are multiple
10412 && $conditions[0] ne 'az'
10413 && $conditions[0] ne 'lt'
10415 # And, we know about a single condition Final_Sigma, but
10417 && ($v_version gt v5.2.0
10418 && (@conditions > 1 || $conditions[0] ne 'Final_Sigma')))
10420 $file->carp_bad_line("Unknown condition '$fields[4]'. You should inspect it and either add code to handle it, or add to list of those that are to ignore");
10422 elsif ($conditions[0] ne 'Final_Sigma') {
10424 # Don't print out a message for Final_Sigma, because we have
10425 # hard-coded handling for it. (But the standard could change
10426 # what the rule should be, but it wouldn't show up here
10429 print "# SKIPPING Special Casing: $_\n"
10430 if $verbosity >= $VERBOSE;
10435 elsif (@fields > 6 || (@fields == 6 && $fields[5] ne "" )) {
10436 $file->carp_bad_line('Extra fields');
10441 $_ = "$fields[0]; lc; $fields[1]";
10442 $file->insert_adjusted_lines("$fields[0]; tc; $fields[2]");
10443 $file->insert_adjusted_lines("$fields[0]; uc; $fields[3]");
10448 sub filter_old_style_case_folding {
10449 # This transforms $_ containing the case folding style of 3.0.1, to 3.1
10450 # and later style. Different letters were used in the earlier.
10453 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10455 my @fields = split /\s*;\s*/;
10456 if ($fields[0] =~ /^ 013 [01] $/x) { # The two turkish fields
10459 elsif ($fields[1] eq 'L') {
10460 $fields[1] = 'C'; # L => C always
10462 elsif ($fields[1] eq 'E') {
10463 if ($fields[2] =~ / /) { # E => C if one code point; F otherwise
10471 $file->carp_bad_line("Expecting L or E in second field");
10475 $_ = join("; ", @fields) . ';';
10479 { # Closure for case folding
10481 # Create the map for simple only if are going to output it, for otherwise
10482 # it takes no part in anything we do.
10483 my $to_output_simple;
10485 sub setup_case_folding($) {
10486 # Read in the case foldings in CaseFolding.txt. This handles both
10487 # simple and full case folding.
10490 = property_ref('Simple_Case_Folding')->to_output_map;
10495 sub filter_case_folding_line {
10496 # Called for each line in CaseFolding.txt
10497 # Input lines look like:
10498 # 0041; C; 0061; # LATIN CAPITAL LETTER A
10499 # 00DF; F; 0073 0073; # LATIN SMALL LETTER SHARP S
10500 # 1E9E; S; 00DF; # LATIN CAPITAL LETTER SHARP S
10502 # 'C' means that folding is the same for both simple and full
10503 # 'F' that it is only for full folding
10504 # 'S' that it is only for simple folding
10505 # 'T' is locale-dependent, and ignored
10506 # 'I' is a type of 'F' used in some early releases.
10507 # Note the trailing semi-colon, unlike many of the input files. That
10508 # means that there will be an extra null field generated by the split
10509 # below, which we ignore and hence is not an error.
10512 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10514 my ($range, $type, $map, @remainder) = split /\s*;\s*/, $_, -1;
10515 if (@remainder > 1 || (@remainder == 1 && $remainder[0] ne "" )) {
10516 $file->carp_bad_line('Extra fields');
10521 if ($type eq 'T') { # Skip Turkic case folding, is locale dependent
10526 # C: complete, F: full, or I: dotted uppercase I -> dotless lowercase
10527 # I are all full foldings
10528 if ($type eq 'C' || $type eq 'F' || $type eq 'I') {
10529 $_ = "$range; Case_Folding; $map";
10533 if ($type ne 'S') {
10534 $file->carp_bad_line('Expecting C F I S or T in second field');
10539 # C and S are simple foldings, but simple case folding is not needed
10540 # unless we explicitly want its map table output.
10541 if ($to_output_simple && $type eq 'C' || $type eq 'S') {
10542 $file->insert_adjusted_lines("$range; Simple_Case_Folding; $map");
10548 } # End case fold closure
10550 sub filter_jamo_line {
10551 # Filter Jamo.txt lines. This routine mainly is used to populate hashes
10552 # from this file that is used in generating the Name property for Jamo
10553 # code points. But, it also is used to convert early versions' syntax
10554 # into the modern form. Here are two examples:
10555 # 1100; G # HANGUL CHOSEONG KIYEOK # Modern syntax
10556 # U+1100; G; HANGUL CHOSEONG KIYEOK # 2.0 syntax
10558 # The input is $_, the output is $_ filtered.
10560 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10562 # Let the caller handle unexpected input. In earlier versions, there was
10563 # a third field which is supposed to be a comment, but did not have a '#'
10565 return if @fields > (($v_version gt v3.0.0) ? 2 : 3);
10567 $fields[0] =~ s/^U\+//; # Also, early versions had this extraneous
10570 # Some 2.1 versions had this wrong. Causes havoc with the algorithm.
10571 $fields[1] = 'R' if $fields[0] eq '1105';
10573 # Add to structure so can generate Names from it.
10574 my $cp = hex $fields[0];
10575 my $short_name = $fields[1];
10576 $Jamo{$cp} = $short_name;
10577 if ($cp <= $LBase + $LCount) {
10578 $Jamo_L{$short_name} = $cp - $LBase;
10580 elsif ($cp <= $VBase + $VCount) {
10581 $Jamo_V{$short_name} = $cp - $VBase;
10583 elsif ($cp <= $TBase + $TCount) {
10584 $Jamo_T{$short_name} = $cp - $TBase;
10587 Carp::my_carp_bug("Unexpected Jamo code point in $_");
10591 # Reassemble using just the first two fields to look like a typical
10592 # property file line
10593 $_ = "$fields[0]; $fields[1]";
10598 sub register_fraction($) {
10599 # This registers the input rational number so that it can be passed on to
10600 # utf8_heavy.pl, both in rational and floating forms.
10602 my $rational = shift;
10604 my $float = eval $rational;
10605 $nv_floating_to_rational{$float} = $rational;
10609 sub filter_numeric_value_line {
10610 # DNumValues contains lines of a different syntax than the typical
10612 # 0F33 ; -0.5 ; ; -1/2 # No TIBETAN DIGIT HALF ZERO
10614 # This routine transforms $_ containing the anomalous syntax to the
10615 # typical, by filtering out the extra columns, and convert early version
10616 # decimal numbers to strings that look like rational numbers.
10619 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10621 # Starting in 5.1, there is a rational field. Just use that, omitting the
10622 # extra columns. Otherwise convert the decimal number in the second field
10623 # to a rational, and omit extraneous columns.
10624 my @fields = split /\s*;\s*/, $_, -1;
10627 if ($v_version ge v5.1.0) {
10628 if (@fields != 4) {
10629 $file->carp_bad_line('Not 4 semi-colon separated fields');
10633 $rational = $fields[3];
10634 $_ = join '; ', @fields[ 0, 3 ];
10638 # Here, is an older Unicode file, which has decimal numbers instead of
10639 # rationals in it. Use the fraction to calculate the denominator and
10640 # convert to rational.
10642 if (@fields != 2 && @fields != 3) {
10643 $file->carp_bad_line('Not 2 or 3 semi-colon separated fields');
10648 my $codepoints = $fields[0];
10649 my $decimal = $fields[1];
10650 if ($decimal =~ s/\.0+$//) {
10652 # Anything ending with a decimal followed by nothing but 0's is an
10654 $_ = "$codepoints; $decimal";
10655 $rational = $decimal;
10660 if ($decimal =~ /\.50*$/) {
10664 # Here have the hardcoded repeating decimals in the fraction, and
10665 # the denominator they imply. There were only a few denominators
10666 # in the older Unicode versions of this file which this code
10667 # handles, so it is easy to convert them.
10669 # The 4 is because of a round-off error in the Unicode 3.2 files
10670 elsif ($decimal =~ /\.33*[34]$/ || $decimal =~ /\.6+7$/) {
10673 elsif ($decimal =~ /\.[27]50*$/) {
10676 elsif ($decimal =~ /\.[2468]0*$/) {
10679 elsif ($decimal =~ /\.16+7$/ || $decimal =~ /\.83+$/) {
10682 elsif ($decimal =~ /\.(12|37|62|87)50*$/) {
10685 if ($denominator) {
10686 my $sign = ($decimal < 0) ? "-" : "";
10687 my $numerator = int((abs($decimal) * $denominator) + .5);
10688 $rational = "$sign$numerator/$denominator";
10689 $_ = "$codepoints; $rational";
10692 $file->carp_bad_line("Can't cope with number '$decimal'.");
10699 register_fraction($rational) if $rational =~ qr{/};
10704 my %unihan_properties;
10709 # Do any special setup for Unihan properties.
10711 # This property gives the wrong computed type, so override.
10712 my $usource = property_ref('kIRG_USource');
10713 $usource->set_type($STRING) if defined $usource;
10715 # This property is to be considered binary, so change all the values
10717 $iicore = property_ref('kIICore');
10718 if (defined $iicore) {
10719 $iicore->add_match_table('Y') if ! defined $iicore->table('Y');
10721 # We have to change the default map, because the @missing line is
10722 # misleading, given that we are treating it as binary.
10723 $iicore->set_default_map('N');
10724 $iicore->set_type($BINARY);
10730 sub filter_unihan_line {
10731 # Change unihan db lines to look like the others in the db. Here is
10733 # U+341C kCangjie IEKN
10735 # Tabs are used instead of semi-colons to separate fields; therefore
10736 # they may have semi-colons embedded in them. Change these to periods
10737 # so won't screw up the rest of the code.
10740 # Remove lines that don't look like ones we accept.
10741 if ($_ !~ /^ [^\t]* \t ( [^\t]* ) /x) {
10746 # Extract the property, and save a reference to its object.
10748 if (! exists $unihan_properties{$property}) {
10749 $unihan_properties{$property} = property_ref($property);
10752 # Don't do anything unless the property is one we're handling, which
10753 # we determine by seeing if there is an object defined for it or not
10754 if (! defined $unihan_properties{$property}) {
10759 # The iicore property is supposed to be a boolean, so convert to our
10760 # standard boolean form.
10761 if (defined $iicore && $unihan_properties{$property} == $iicore) {
10762 $_ =~ s/$property.*/$property\tY/
10765 # Convert the tab separators to our standard semi-colons, and convert
10766 # the U+HHHH notation to the rest of the standard's HHHH
10768 s/\b U \+ (?= $code_point_re )//xg;
10770 #local $to_trace = 1 if main::DEBUG;
10771 trace $_ if main::DEBUG && $to_trace;
10777 sub filter_blocks_lines {
10778 # In the Blocks.txt file, the names of the blocks don't quite match the
10779 # names given in PropertyValueAliases.txt, so this changes them so they
10780 # do match: Blanks and hyphens are changed into underscores. Also makes
10781 # early release versions look like later ones
10783 # $_ is transformed to the correct value.
10786 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10788 if ($v_version lt v3.2.0) {
10789 if (/FEFF.*Specials/) { # Bug in old versions: line wrongly inserted
10794 # Old versions used a different syntax to mark the range.
10795 $_ =~ s/;\s+/../ if $v_version lt v3.1.0;
10798 my @fields = split /\s*;\s*/, $_, -1;
10799 if (@fields != 2) {
10800 $file->carp_bad_line("Expecting exactly two fields");
10805 # Change hyphens and blanks in the block name field only
10806 $fields[1] =~ s/[ -]/_/g;
10807 $fields[1] =~ s/_ ( [a-z] ) /_\u$1/g; # Capitalize first letter of word
10809 $_ = join("; ", @fields);
10814 my $current_property;
10816 sub filter_old_style_proplist {
10817 # PropList.txt has been in Unicode since version 2.0. Until 3.1, it
10818 # was in a completely different syntax. Ken Whistler of Unicode says
10819 # that it was something he used as an aid for his own purposes, but
10820 # was never an official part of the standard. However, comments in
10821 # DAge.txt indicate that non-character code points were available in
10822 # the UCD as of 3.1. It is unclear to me (khw) how they could be
10823 # there except through this file (but on the other hand, they first
10824 # appeared there in 3.0.1), so maybe it was part of the UCD, and maybe
10825 # not. But the claim is that it was published as an aid to others who
10826 # might want some more information than was given in the official UCD
10827 # of the time. Many of the properties in it were incorporated into
10828 # the later PropList.txt, but some were not. This program uses this
10829 # early file to generate property tables that are otherwise not
10830 # accessible in the early UCD's, and most were probably not really
10831 # official at that time, so one could argue that it should be ignored,
10832 # and you can easily modify things to skip this. And there are bugs
10833 # in this file in various versions. (For example, the 2.1.9 version
10834 # removes from Alphabetic the CJK range starting at 4E00, and they
10835 # weren't added back in until 3.1.0.) Many of this file's properties
10836 # were later sanctioned, so this code generates tables for those
10837 # properties that aren't otherwise in the UCD of the time but
10838 # eventually did become official, and throws away the rest. Here is a
10839 # list of all the ones that are thrown away:
10840 # Bidi=* duplicates UnicodeData.txt
10841 # Combining never made into official property;
10843 # Composite never made into official property.
10844 # Currency Symbol duplicates UnicodeData.txt: gc=sc
10845 # Decimal Digit duplicates UnicodeData.txt: gc=nd
10846 # Delimiter never made into official property;
10848 # Format Control never made into official property;
10850 # High Surrogate duplicates Blocks.txt
10851 # Ignorable Control never made into official property;
10853 # ISO Control duplicates UnicodeData.txt: gc=cc
10854 # Left of Pair never made into official property;
10855 # Line Separator duplicates UnicodeData.txt: gc=zl
10856 # Low Surrogate duplicates Blocks.txt
10857 # Non-break was actually listed as a property
10858 # in 3.2, but without any code
10859 # points. Unicode denies that this
10860 # was ever an official property
10861 # Non-spacing duplicate UnicodeData.txt: gc=mn
10862 # Numeric duplicates UnicodeData.txt: gc=cc
10863 # Paired Punctuation never made into official property;
10864 # appears to be gc=ps + gc=pe
10865 # Paragraph Separator duplicates UnicodeData.txt: gc=cc
10866 # Private Use duplicates UnicodeData.txt: gc=co
10867 # Private Use High Surrogate duplicates Blocks.txt
10868 # Punctuation duplicates UnicodeData.txt: gc=p
10869 # Space different definition than eventual
10871 # Titlecase duplicates UnicodeData.txt: gc=lt
10872 # Unassigned Code Value duplicates UnicodeData.txt: gc=cc
10873 # Zero-width never made into official property;
10875 # Most of the properties have the same names in this file as in later
10876 # versions, but a couple do not.
10878 # This subroutine filters $_, converting it from the old style into
10879 # the new style. Here's a sample of the old-style
10881 # *******************************************
10883 # Property dump for: 0x100000A0 (Join Control)
10885 # 200C..200D (2 chars)
10887 # In the example, the property is "Join Control". It is kept in this
10888 # closure between calls to the subroutine. The numbers beginning with
10889 # 0x were internal to Ken's program that generated this file.
10891 # If this line contains the property name, extract it.
10892 if (/^Property dump for: [^(]*\((.*)\)/) {
10895 # Convert white space to underscores.
10898 # Convert the few properties that don't have the same name as
10899 # their modern counterparts
10900 s/Identifier_Part/ID_Continue/
10901 or s/Not_a_Character/NChar/;
10903 # If the name matches an existing property, use it.
10904 if (defined property_ref($_)) {
10905 trace "new property=", $_ if main::DEBUG && $to_trace;
10906 $current_property = $_;
10908 else { # Otherwise discard it
10909 trace "rejected property=", $_ if main::DEBUG && $to_trace;
10910 undef $current_property;
10912 $_ = ""; # The property is saved for the next lines of the
10913 # file, but this defining line is of no further use,
10914 # so clear it so that the caller won't process it
10917 elsif (! defined $current_property || $_ !~ /^$code_point_re/) {
10919 # Here, the input line isn't a header defining a property for the
10920 # following section, and either we aren't in such a section, or
10921 # the line doesn't look like one that defines the code points in
10922 # such a section. Ignore this line.
10927 # Here, we have a line defining the code points for the current
10928 # stashed property. Anything starting with the first blank is
10929 # extraneous. Otherwise, it should look like a normal range to
10930 # the caller. Append the property name so that it looks just like
10931 # a modern PropList entry.
10934 $_ .= "; $current_property";
10936 trace $_ if main::DEBUG && $to_trace;
10939 } # End closure for old style proplist
10941 sub filter_old_style_normalization_lines {
10942 # For early releases of Unicode, the lines were like:
10943 # 74..2A76 ; NFKD_NO
10944 # For later releases this became:
10945 # 74..2A76 ; NFKD_QC; N
10946 # Filter $_ to look like those in later releases.
10947 # Similarly for MAYBEs
10949 s/ _NO \b /_QC; N/x || s/ _MAYBE \b /_QC; M/x;
10951 # Also, the property FC_NFKC was abbreviated to FNC
10956 sub finish_Unicode() {
10957 # This routine should be called after all the Unicode files have been read
10959 # 1) Adds the mappings for code points missing from the files which have
10960 # defaults specified for them.
10961 # 2) At this this point all mappings are known, so it computes the type of
10962 # each property whose type hasn't been determined yet.
10963 # 3) Calculates all the regular expression match tables based on the
10965 # 3) Calculates and adds the tables which are defined by Unicode, but
10966 # which aren't derived by them
10968 # For each property, fill in any missing mappings, and calculate the re
10969 # match tables. If a property has more than one missing mapping, the
10970 # default is a reference to a data structure, and requires data from other
10971 # properties to resolve. The sort is used to cause these to be processed
10972 # last, after all the other properties have been calculated.
10973 # (Fortunately, the missing properties so far don't depend on each other.)
10974 foreach my $property
10975 (sort { (defined $a->default_map && ref $a->default_map) ? 1 : -1 }
10978 # $perl has been defined, but isn't one of the Unicode properties that
10979 # need to be finished up.
10980 next if $property == $perl;
10982 # Handle the properties that have more than one possible default
10983 if (ref $property->default_map) {
10984 my $default_map = $property->default_map;
10986 # These properties have stored in the default_map:
10988 # 1) A default map which applies to all code points in a
10990 # 2) an expression which will evaluate to the list of code
10991 # points in that class
10993 # 3) the default map which applies to every other missing code
10996 # Go through each list.
10997 while (my ($default, $eval) = $default_map->get_next_defaults) {
10999 # Get the class list, and intersect it with all the so-far
11000 # unspecified code points yielding all the code points
11001 # in the class that haven't been specified.
11002 my $list = eval $eval;
11004 Carp::my_carp("Can't set some defaults for missing code points for $property because eval '$eval' failed with '$@'");
11008 # Narrow down the list to just those code points we don't have
11010 $list = $list & $property->inverse_list;
11012 # Add mappings to the property for each code point in the list
11013 foreach my $range ($list->ranges) {
11014 $property->add_map($range->start, $range->end, $default,
11015 Replace => $CROAK);
11019 # All remaining code points have the other mapping. Set that up
11020 # so the normal single-default mapping code will work on them
11021 $property->set_default_map($default_map->other_default);
11023 # And fall through to do that
11026 # We should have enough data now to compute the type of the property.
11027 $property->compute_type;
11028 my $property_type = $property->type;
11030 next if ! $property->to_create_match_tables;
11032 # Here want to create match tables for this property
11034 # The Unicode db always (so far, and they claim into the future) have
11035 # the default for missing entries in binary properties be 'N' (unless
11036 # there is a '@missing' line that specifies otherwise)
11037 if ($property_type == $BINARY && ! defined $property->default_map) {
11038 $property->set_default_map('N');
11041 # Add any remaining code points to the mapping, using the default for
11042 # missing code points.
11043 if (defined (my $default_map = $property->default_map)) {
11045 # This fills in any missing values with the default.
11046 $property->add_map(0, $LAST_UNICODE_CODEPOINT,
11047 $default_map, Replace => $NO);
11049 # Make sure there is a match table for the default
11050 if (! defined $property->table($default_map)) {
11051 $property->add_match_table($default_map);
11055 # Have all we need to populate the match tables.
11056 my $property_name = $property->name;
11057 foreach my $range ($property->ranges) {
11058 my $map = $range->value;
11059 my $table = property_ref($property_name)->table($map);
11060 if (! defined $table) {
11062 # Integral and rational property values are not necessarily
11063 # defined in PropValueAliases, but all other ones should be,
11065 if ($v_version ge v5.1.0
11066 && $map !~ /^ -? \d+ ( \/ \d+ )? $/x)
11068 Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.")
11070 $table = property_ref($property_name)->add_match_table($map);
11073 $table->add_range($range->start, $range->end);
11076 # And add the Is_ prefix synonyms for Perl 5.6 compatibility, in which
11077 # all properties have this optional prefix. These do not get a
11078 # separate entry in the pod file, because are covered by a wild-card
11080 foreach my $alias ($property->aliases) {
11081 my $Is_name = 'Is_' . $alias->name;
11082 if (! defined (my $pre_existing = property_ref($Is_name))) {
11083 $property->add_alias($Is_name,
11085 Status => $alias->status,
11086 Externally_Ok => 0);
11090 # It seemed too much work to add in these warnings when it
11091 # appears that Unicode has made a decision never to begin a
11092 # property name with 'Is_', so this shouldn't happen, but just
11093 # in case, it is a warning.
11094 Carp::my_carp(<<END
11095 There is already an alias named $Is_name (from " . $pre_existing . "), so not
11096 creating this alias for $property. The generated table and pod files do not
11097 warn users of this conflict.
11100 $has_Is_conflicts++;
11102 } # End of loop through aliases for this property
11103 } # End of loop through all Unicode properties.
11105 # Fill in the mappings that Unicode doesn't completely furnish. First the
11106 # single letter major general categories. If Unicode were to start
11107 # delivering the values, this would be redundant, but better that than to
11108 # try to figure out if should skip and not get it right. Ths could happen
11109 # if a new major category were to be introduced, and the hard-coded test
11110 # wouldn't know about it.
11111 # This routine depends on the standard names for the general categories
11112 # being what it thinks they are, like 'Cn'. The major categories are the
11113 # union of all the general category tables which have the same first
11114 # letters. eg. L = Lu + Lt + Ll + Lo + Lm
11115 foreach my $minor_table ($gc->tables) {
11116 my $minor_name = $minor_table->name;
11117 next if length $minor_name == 1;
11118 if (length $minor_name != 2) {
11119 Carp::my_carp_bug("Unexpected general category '$minor_name'. Skipped.");
11123 my $major_name = uc(substr($minor_name, 0, 1));
11124 my $major_table = $gc->table($major_name);
11125 $major_table += $minor_table;
11128 # LC is Ll, Lu, and Lt. (used to be L& or L_, but PropValueAliases.txt
11129 # defines it as LC)
11130 my $LC = $gc->table('LC');
11131 $LC->add_alias('L_', Status => $DISCOURAGED); # For backwards...
11132 $LC->add_alias('L&', Status => $DISCOURAGED); # compatibility.
11135 if ($LC->is_empty) { # Assume if not empty that Unicode has started to
11136 # deliver the correct values in it
11137 $LC->initialize($gc->table('Ll') + $gc->table('Lu'));
11139 # Lt not in release 1.
11140 if (defined $gc->table('Lt')) {
11141 $LC += $gc->table('Lt');
11142 $gc->table('Lt')->set_caseless_equivalent($LC);
11145 $LC->add_description('[\p{Ll}\p{Lu}\p{Lt}]');
11147 $gc->table('Ll')->set_caseless_equivalent($LC);
11148 $gc->table('Lu')->set_caseless_equivalent($LC);
11150 my $Cs = $gc->table('Cs');
11153 # Folding information was introduced later into Unicode data. To get
11154 # Perl's case ignore (/i) to work at all in releases that don't have
11155 # folding, use the best available alternative, which is lower casing.
11156 my $fold = property_ref('Simple_Case_Folding');
11157 if ($fold->is_empty) {
11158 $fold->initialize(property_ref('Simple_Lowercase_Mapping'));
11159 $fold->add_note(join_lines(<<END
11160 WARNING: This table uses lower case as a substitute for missing fold
11166 # Multiple-character mapping was introduced later into Unicode data. If
11167 # missing, use the single-characters maps as best available alternative
11168 foreach my $map (qw { Uppercase_Mapping
11173 my $full = property_ref($map);
11174 if ($full->is_empty) {
11175 my $simple = property_ref('Simple_' . $map);
11176 $full->initialize($simple);
11177 $full->add_comment($simple->comment) if ($simple->comment);
11178 $full->add_note(join_lines(<<END
11179 WARNING: This table uses simple mapping (single-character only) as a
11180 substitute for missing multiple-character information
11188 sub compile_perl() {
11189 # Create perl-defined tables. Almost all are part of the pseudo-property
11190 # named 'perl' internally to this program. Many of these are recommended
11191 # in UTS#18 "Unicode Regular Expressions", and their derivations are based
11192 # on those found there.
11193 # Almost all of these are equivalent to some Unicode property.
11194 # A number of these properties have equivalents restricted to the ASCII
11195 # range, with their names prefaced by 'Posix', to signify that these match
11196 # what the Posix standard says they should match. A couple are
11197 # effectively this, but the name doesn't have 'Posix' in it because there
11198 # just isn't any Posix equivalent. 'XPosix' are the Posix tables extended
11199 # to the full Unicode range, by our guesses as to what is appropriate.
11201 # 'Any' is all code points. As an error check, instead of just setting it
11202 # to be that, construct it to be the union of all the major categories
11203 my $Any = $perl->add_match_table('Any',
11204 Description => "[\\x{0000}-\\x{$LAST_UNICODE_CODEPOINT_STRING}]",
11207 foreach my $major_table ($gc->tables) {
11209 # Major categories are the ones with single letter names.
11210 next if length($major_table->name) != 1;
11212 $Any += $major_table;
11215 if ($Any->max != $LAST_UNICODE_CODEPOINT) {
11216 Carp::my_carp_bug("Generated highest code point ("
11217 . sprintf("%X", $Any->max)
11218 . ") doesn't match expected value $LAST_UNICODE_CODEPOINT_STRING.")
11220 if ($Any->range_count != 1 || $Any->min != 0) {
11221 Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.")
11224 $Any->add_alias('All');
11226 # Assigned is the opposite of gc=unassigned
11227 my $Assigned = $perl->add_match_table('Assigned',
11228 Description => "All assigned code points",
11229 Initialize => ~ $gc->table('Unassigned'),
11232 # Our internal-only property should be treated as more than just a
11234 $perl->add_match_table('_CombAbove')
11235 ->set_equivalent_to(property_ref('ccc')->table('Above'),
11238 my $ASCII = $perl->add_match_table('ASCII', Description => '[[:ASCII:]]');
11239 if (defined $block) { # This is equivalent to the block if have it.
11240 my $Unicode_ASCII = $block->table('Basic_Latin');
11241 if (defined $Unicode_ASCII && ! $Unicode_ASCII->is_empty) {
11242 $ASCII->set_equivalent_to($Unicode_ASCII, Related => 1);
11246 # Very early releases didn't have blocks, so initialize ASCII ourselves if
11248 if ($ASCII->is_empty) {
11249 $ASCII->initialize([ 0..127 ]);
11252 # Get the best available case definitions. Early Unicode versions didn't
11253 # have Uppercase and Lowercase defined, so use the general category
11254 # instead for them.
11255 my $Lower = $perl->add_match_table('Lower');
11256 my $Unicode_Lower = property_ref('Lowercase');
11257 if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) {
11258 $Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1);
11259 $Unicode_Lower->table('Y')->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11260 $Unicode_Lower->table('N')->set_caseless_equivalent(property_ref('Cased')->table('N'));
11261 $Lower->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11265 $Lower->set_equivalent_to($gc->table('Lowercase_Letter'),
11268 $Lower->add_alias('XPosixLower');
11269 my $Posix_Lower = $perl->add_match_table("PosixLower",
11270 Description => "[a-z]",
11271 Initialize => $Lower & $ASCII,
11274 my $Upper = $perl->add_match_table('Upper');
11275 my $Unicode_Upper = property_ref('Uppercase');
11276 if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) {
11277 $Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1);
11278 $Unicode_Upper->table('Y')->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11279 $Unicode_Upper->table('N')->set_caseless_equivalent(property_ref('Cased')->table('N'));
11280 $Upper->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11283 $Upper->set_equivalent_to($gc->table('Uppercase_Letter'),
11286 $Upper->add_alias('XPosixUpper');
11287 my $Posix_Upper = $perl->add_match_table("PosixUpper",
11288 Description => "[A-Z]",
11289 Initialize => $Upper & $ASCII,
11292 # Earliest releases didn't have title case. Initialize it to empty if not
11293 # otherwise present
11294 my $Title = $perl->add_match_table('Title');
11295 my $lt = $gc->table('Lt');
11297 # Earlier versions of mktables had this related to $lt since they have
11298 # identical code points, but their casefolds are not equivalent, and so
11299 # now must be kept as separate entities.
11300 $Title += $lt if defined $lt;
11302 # If this Unicode version doesn't have Cased, set up our own. From
11303 # Unicode 5.1: Definition D120: A character C is defined to be cased if
11304 # and only if C has the Lowercase or Uppercase property or has a
11305 # General_Category value of Titlecase_Letter.
11306 my $Unicode_Cased = property_ref('Cased');
11307 unless (defined $Unicode_Cased) {
11308 my $cased = $perl->add_match_table('Cased',
11309 Initialize => $Lower + $Upper + $Title,
11310 Description => 'Uppercase or Lowercase or Titlecase',
11312 $Unicode_Cased = $cased;
11314 $Title->set_caseless_equivalent($Unicode_Cased->table('Y'));
11316 # Similarly, set up our own Case_Ignorable property if this Unicode
11317 # version doesn't have it. From Unicode 5.1: Definition D121: A character
11318 # C is defined to be case-ignorable if C has the value MidLetter or the
11319 # value MidNumLet for the Word_Break property or its General_Category is
11320 # one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
11321 # Modifier_Letter (Lm), or Modifier_Symbol (Sk).
11323 # Perl has long had an internal-only alias for this property.
11324 my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable');
11325 my $case_ignorable = property_ref('Case_Ignorable');
11326 if (defined $case_ignorable && ! $case_ignorable->is_empty) {
11327 $perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
11332 $perl_case_ignorable->initialize($gc->table('Mn') + $gc->table('Lm'));
11334 # The following three properties are not in early releases
11335 $perl_case_ignorable += $gc->table('Me') if defined $gc->table('Me');
11336 $perl_case_ignorable += $gc->table('Cf') if defined $gc->table('Cf');
11337 $perl_case_ignorable += $gc->table('Sk') if defined $gc->table('Sk');
11339 # For versions 4.1 - 5.0, there is no MidNumLet property, and
11340 # correspondingly the case-ignorable definition lacks that one. For
11341 # 4.0, it appears that it was meant to be the same definition, but was
11342 # inadvertently omitted from the standard's text, so add it if the
11343 # property actually is there
11344 my $wb = property_ref('Word_Break');
11346 my $midlet = $wb->table('MidLetter');
11347 $perl_case_ignorable += $midlet if defined $midlet;
11348 my $midnumlet = $wb->table('MidNumLet');
11349 $perl_case_ignorable += $midnumlet if defined $midnumlet;
11353 # In earlier versions of the standard, instead of the above two
11354 # properties , just the following characters were used:
11355 $perl_case_ignorable += 0x0027 # APOSTROPHE
11356 + 0x00AD # SOFT HYPHEN (SHY)
11357 + 0x2019; # RIGHT SINGLE QUOTATION MARK
11361 # The remaining perl defined tables are mostly based on Unicode TR 18,
11362 # "Annex C: Compatibility Properties". All of these have two versions,
11363 # one whose name generally begins with Posix that is posix-compliant, and
11364 # one that matches Unicode characters beyond the Posix, ASCII range
11366 my $Alpha = $perl->add_match_table('Alpha');
11368 # Alphabetic was not present in early releases
11369 my $Alphabetic = property_ref('Alphabetic');
11370 if (defined $Alphabetic && ! $Alphabetic->is_empty) {
11371 $Alpha->set_equivalent_to($Alphabetic->table('Y'), Related => 1);
11375 # For early releases, we don't get it exactly right. The below
11376 # includes more than it should, which in 5.2 terms is: L + Nl +
11377 # Other_Alphabetic. Other_Alphabetic contains many characters from
11378 # Mn and Mc. It's better to match more than we should, than less than
11380 $Alpha->initialize($gc->table('Letter')
11382 + $gc->table('Mc'));
11383 $Alpha += $gc->table('Nl') if defined $gc->table('Nl');
11384 $Alpha->add_description('Alphabetic');
11386 $Alpha->add_alias('XPosixAlpha');
11387 my $Posix_Alpha = $perl->add_match_table("PosixAlpha",
11388 Description => "[A-Za-z]",
11389 Initialize => $Alpha & $ASCII,
11391 $Posix_Upper->set_caseless_equivalent($Posix_Alpha);
11392 $Posix_Lower->set_caseless_equivalent($Posix_Alpha);
11394 my $Alnum = $perl->add_match_table('Alnum',
11395 Description => 'Alphabetic and (Decimal) Numeric',
11396 Initialize => $Alpha + $gc->table('Decimal_Number'),
11398 $Alnum->add_alias('XPosixAlnum');
11399 $perl->add_match_table("PosixAlnum",
11400 Description => "[A-Za-z0-9]",
11401 Initialize => $Alnum & $ASCII,
11404 my $Word = $perl->add_match_table('Word',
11405 Description => '\w, including beyond ASCII;'
11406 . ' = \p{Alnum} + \pM + \p{Pc}',
11407 Initialize => $Alnum + $gc->table('Mark'),
11409 $Word->add_alias('XPosixWord');
11410 my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
11411 $Word += $Pc if defined $Pc;
11413 # This is a Perl extension, so the name doesn't begin with Posix.
11414 my $PerlWord = $perl->add_match_table('PerlWord',
11415 Description => '\w, restricted to ASCII = [A-Za-z0-9_]',
11416 Initialize => $Word & $ASCII,
11418 $PerlWord->add_alias('PosixWord');
11420 my $Blank = $perl->add_match_table('Blank',
11421 Description => '\h, Horizontal white space',
11423 # 200B is Zero Width Space which is for line
11424 # break control, and was listed as
11425 # Space_Separator in early releases
11426 Initialize => $gc->table('Space_Separator')
11430 $Blank->add_alias('HorizSpace'); # Another name for it.
11431 $Blank->add_alias('XPosixBlank');
11432 $perl->add_match_table("PosixBlank",
11433 Description => "\\t and ' '",
11434 Initialize => $Blank & $ASCII,
11437 my $VertSpace = $perl->add_match_table('VertSpace',
11438 Description => '\v',
11439 Initialize => $gc->table('Line_Separator')
11440 + $gc->table('Paragraph_Separator')
11441 + 0x000A # LINE FEED
11442 + 0x000B # VERTICAL TAB
11443 + 0x000C # FORM FEED
11444 + 0x000D # CARRIAGE RETURN
11447 # No Posix equivalent for vertical space
11449 my $Space = $perl->add_match_table('Space',
11450 Description => '\s including beyond ASCII plus vertical tab',
11451 Initialize => $Blank + $VertSpace,
11453 $Space->add_alias('XPosixSpace');
11454 $perl->add_match_table("PosixSpace",
11455 Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
11456 Initialize => $Space & $ASCII,
11459 # Perl's traditional space doesn't include Vertical Tab
11460 my $XPerlSpace = $perl->add_match_table('XPerlSpace',
11461 Description => '\s, including beyond ASCII',
11462 Initialize => $Space - 0x000B,
11464 $XPerlSpace->add_alias('SpacePerl'); # A pre-existing synonym
11465 my $PerlSpace = $perl->add_match_table('PerlSpace',
11466 Description => '\s, restricted to ASCII',
11467 Initialize => $XPerlSpace & $ASCII,
11471 my $Cntrl = $perl->add_match_table('Cntrl',
11472 Description => 'Control characters');
11473 $Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1);
11474 $Cntrl->add_alias('XPosixCntrl');
11475 $perl->add_match_table("PosixCntrl",
11476 Description => "ASCII control characters: NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS, HT, LF, VT, FF, CR, SO, SI, DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EOM, SUB, ESC, FS, GS, RS, US, and DEL",
11477 Initialize => $Cntrl & $ASCII,
11480 # $controls is a temporary used to construct Graph.
11481 my $controls = Range_List->new(Initialize => $gc->table('Unassigned')
11482 + $gc->table('Control'));
11483 # Cs not in release 1
11484 $controls += $gc->table('Surrogate') if defined $gc->table('Surrogate');
11486 # Graph is ~space & ~(Cc|Cs|Cn) = ~(space + $controls)
11487 my $Graph = $perl->add_match_table('Graph',
11488 Description => 'Characters that are graphical',
11489 Initialize => ~ ($Space + $controls),
11491 $Graph->add_alias('XPosixGraph');
11492 $perl->add_match_table("PosixGraph",
11494 '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~0-9A-Za-z]',
11495 Initialize => $Graph & $ASCII,
11498 $print = $perl->add_match_table('Print',
11499 Description => 'Characters that are graphical plus space characters (but no controls)',
11500 Initialize => $Blank + $Graph - $gc->table('Control'),
11502 $print->add_alias('XPosixPrint');
11503 $perl->add_match_table("PosixPrint",
11505 '[- 0-9A-Za-z!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11506 Initialize => $print & $ASCII,
11509 my $Punct = $perl->add_match_table('Punct');
11510 $Punct->set_equivalent_to($gc->table('Punctuation'), Related => 1);
11512 # \p{punct} doesn't include the symbols, which posix does
11513 my $XPosixPunct = $perl->add_match_table('XPosixPunct',
11514 Description => '\p{Punct} + ASCII-range \p{Symbol}',
11515 Initialize => $gc->table('Punctuation')
11516 + ($ASCII & $gc->table('Symbol')),
11518 $perl->add_match_table('PosixPunct',
11519 Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11520 Initialize => $ASCII & $XPosixPunct,
11523 my $Digit = $perl->add_match_table('Digit',
11524 Description => '[0-9] + all other decimal digits');
11525 $Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1);
11526 $Digit->add_alias('XPosixDigit');
11527 my $PosixDigit = $perl->add_match_table("PosixDigit",
11528 Description => '[0-9]',
11529 Initialize => $Digit & $ASCII,
11532 # Hex_Digit was not present in first release
11533 my $Xdigit = $perl->add_match_table('XDigit');
11534 $Xdigit->add_alias('XPosixXDigit');
11535 my $Hex = property_ref('Hex_Digit');
11536 if (defined $Hex && ! $Hex->is_empty) {
11537 $Xdigit->set_equivalent_to($Hex->table('Y'), Related => 1);
11540 # (Have to use hex instead of e.g. '0', because could be running on an
11541 # non-ASCII machine, and we want the Unicode (ASCII) values)
11542 $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66,
11543 0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
11544 $Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
11546 $perl->add_match_table('PosixXDigit',
11547 Initialize => $ASCII & $Xdigit,
11548 Description => '[0-9A-Fa-f]',
11551 my $dt = property_ref('Decomposition_Type');
11552 $dt->add_match_table('Non_Canon', Full_Name => 'Non_Canonical',
11553 Initialize => ~ ($dt->table('None') + $dt->table('Canonical')),
11554 Perl_Extension => 1,
11555 Note => 'Union of all non-canonical decompositions',
11558 # _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
11559 # than SD appeared, construct it ourselves, based on the first release SD
11561 my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ');
11562 my $soft_dotted = property_ref('Soft_Dotted');
11563 if (defined $soft_dotted && ! $soft_dotted->is_empty) {
11564 $CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
11568 # This list came from 3.2 Soft_Dotted.
11569 $CanonDCIJ->initialize([ 0x0069,
11578 $CanonDCIJ = $CanonDCIJ & $Assigned;
11581 # These are used in Unicode's definition of \X
11582 my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1);
11583 my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1);
11585 my $gcb = property_ref('Grapheme_Cluster_Break');
11587 # The 'extended' grapheme cluster came in 5.1. The non-extended
11588 # definition differs too much from the traditional Perl one to use.
11589 if (defined $gcb && defined $gcb->table('SpacingMark')) {
11591 # Note that assumes HST is defined; it came in an earlier release than
11592 # GCB. In the line below, two negatives means: yes hangul
11593 $begin += ~ property_ref('Hangul_Syllable_Type')
11594 ->table('Not_Applicable')
11595 + ~ ($gcb->table('Control')
11596 + $gcb->table('CR')
11597 + $gcb->table('LF'));
11598 $begin->add_comment('For use in \X; matches: Hangul_Syllable | ! Control');
11600 $extend += $gcb->table('Extend') + $gcb->table('SpacingMark');
11601 $extend->add_comment('For use in \X; matches: Extend | SpacingMark');
11603 else { # Old definition, used on early releases.
11604 $extend += $gc->table('Mark')
11607 $begin += ~ $extend;
11609 # Here we may have a release that has the regular grapheme cluster
11610 # defined, or a release that doesn't have anything defined.
11611 # We set things up so the Perl core degrades gracefully, possibly with
11612 # placeholders that match nothing.
11614 if (! defined $gcb) {
11615 $gcb = Property->new('GCB', Status => $PLACEHOLDER);
11617 my $hst = property_ref('HST');
11618 if (!defined $hst) {
11619 $hst = Property->new('HST', Status => $PLACEHOLDER);
11620 $hst->add_match_table('Not_Applicable',
11621 Initialize => $Any,
11625 # On some releases, here we may not have the needed tables for the
11626 # perl core, in some releases we may.
11627 foreach my $name (qw{ L LV LVT T V prepend }) {
11628 my $table = $gcb->table($name);
11629 if (! defined $table) {
11630 $table = $gcb->add_match_table($name);
11631 push @tables_that_may_be_empty, $table->complete_name;
11634 # The HST property predates the GCB one, and has identical tables
11635 # for some of them, so use it if we can.
11636 if ($table->is_empty
11638 && defined $hst->table($name))
11640 $table += $hst->table($name);
11645 # More GCB. If we found some hangul syllables, populate a combined
11647 my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V');
11648 my $LV = $gcb->table('LV');
11649 if ($LV->is_empty) {
11650 push @tables_that_may_be_empty, $lv_lvt_v->complete_name;
11652 $lv_lvt_v += $LV + $gcb->table('LVT') + $gcb->table('V');
11653 $lv_lvt_v->add_comment('For use in \X; matches: HST=LV | HST=LVT | HST=V');
11656 # Was previously constructed to contain both Name and Unicode_1_Name
11657 my @composition = ('Name', 'Unicode_1_Name');
11659 if (@named_sequences) {
11660 push @composition, 'Named_Sequence';
11661 foreach my $sequence (@named_sequences) {
11662 $perl_charname->add_anomalous_entry($sequence);
11666 my $alias_sentence = "";
11667 my $alias = property_ref('Name_Alias');
11668 if (defined $alias) {
11669 push @composition, 'Name_Alias';
11670 $alias->reset_each_range;
11671 while (my ($range) = $alias->each_range) {
11672 next if $range->value eq "";
11673 if ($range->start != $range->end) {
11674 Carp::my_carp("Expecting only one code point in the range $range. Just to keep going, using just the first code point;");
11676 $perl_charname->add_duplicate($range->start, $range->value);
11678 $alias_sentence = <<END;
11679 The Name_Alias property adds duplicate code point entries with a corrected
11680 name. The original (less correct, but still valid) name will be physically
11685 if (@composition <= 2) { # Always at least 2
11686 $comment = join " and ", @composition;
11689 $comment = join ", ", @composition[0 .. scalar @composition - 2];
11690 $comment .= ", and $composition[-1]";
11693 $perl_charname->add_comment(join_lines( <<END
11694 This file is for charnames.pm. It is the union of the $comment properties.
11695 Unicode_1_Name entries are used only for otherwise nameless code
11701 # The combining class property used by Perl's normalize.pm is not located
11702 # in the normal mapping directory; create a copy for it.
11703 my $ccc = property_ref('Canonical_Combining_Class');
11704 my $perl_ccc = Property->new('Perl_ccc',
11705 Default_Map => $ccc->default_map,
11706 Full_Name => 'Perl_Canonical_Combining_Class',
11707 Internal_Only_Warning => 1,
11708 Perl_Extension => 1,
11711 Initialize => $ccc,
11712 File => 'CombiningClass',
11713 Directory => File::Spec->curdir(),
11715 $perl_ccc->set_to_output_map(1);
11716 $perl_ccc->add_comment(join_lines(<<END
11717 This mapping is for normalize.pm. It is currently identical to the Unicode
11718 Canonical_Combining_Class property.
11722 # This one match table for it is needed for calculations on output
11723 my $default = $perl_ccc->add_match_table($ccc->default_map,
11724 Initialize => $ccc->table($ccc->default_map),
11725 Status => $SUPPRESSED);
11727 # Construct the Present_In property from the Age property.
11728 if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
11729 my $default_map = $age->default_map;
11730 my $in = Property->new('In',
11731 Default_Map => $default_map,
11732 Full_Name => "Present_In",
11733 Internal_Only_Warning => 1,
11734 Perl_Extension => 1,
11736 Initialize => $age,
11738 $in->add_comment(join_lines(<<END
11739 This file should not be used for any purpose. The values in this file are the
11740 same as for $age, and not for what $in really means. This is because anything
11741 defined in a given release should have multiple values: that release and all
11742 higher ones. But only one value per code point can be represented in a table
11747 # The Age tables are named like 1.5, 2.0, 2.1, .... Sort so that the
11748 # lowest numbered (earliest) come first, with the non-numeric one
11750 my ($first_age, @rest_ages) = sort { ($a->name !~ /^[\d.]*$/)
11752 : ($b->name !~ /^[\d.]*$/)
11754 : $a->name <=> $b->name
11757 # The Present_In property is the cumulative age properties. The first
11758 # one hence is identical to the first age one.
11759 my $previous_in = $in->add_match_table($first_age->name);
11760 $previous_in->set_equivalent_to($first_age, Related => 1);
11762 my $description_start = "Code point's usage introduced in version ";
11763 $first_age->add_description($description_start . $first_age->name);
11765 # To construct the accumulated values, for each of the age tables
11766 # starting with the 2nd earliest, merge the earliest with it, to get
11767 # all those code points existing in the 2nd earliest. Repeat merging
11768 # the new 2nd earliest with the 3rd earliest to get all those existing
11769 # in the 3rd earliest, and so on.
11770 foreach my $current_age (@rest_ages) {
11771 next if $current_age->name !~ /^[\d.]*$/; # Skip the non-numeric
11773 my $current_in = $in->add_match_table(
11774 $current_age->name,
11775 Initialize => $current_age + $previous_in,
11776 Description => $description_start
11777 . $current_age->name
11780 $previous_in = $current_in;
11782 # Add clarifying material for the corresponding age file. This is
11783 # in part because of the confusing and contradictory information
11784 # given in the Standard's documentation itself, as of 5.2.
11785 $current_age->add_description(
11786 "Code point's usage was introduced in version "
11787 . $current_age->name);
11788 $current_age->add_note("See also $in");
11792 # And finally the code points whose usages have yet to be decided are
11793 # the same in both properties. Note that permanently unassigned code
11794 # points actually have their usage assigned (as being permanently
11795 # unassigned), so that these tables are not the same as gc=cn.
11796 my $unassigned = $in->add_match_table($default_map);
11797 my $age_default = $age->table($default_map);
11798 $age_default->add_description(<<END
11799 Code point's usage has not been assigned in any Unicode release thus far.
11802 $unassigned->set_equivalent_to($age_default, Related => 1);
11806 # Finished creating all the perl properties. All non-internal non-string
11807 # ones have a synonym of 'Is_' prefixed. (Internal properties begin with
11808 # an underscore.) These do not get a separate entry in the pod file
11809 foreach my $table ($perl->tables) {
11810 foreach my $alias ($table->aliases) {
11811 next if $alias->name =~ /^_/;
11812 $table->add_alias('Is_' . $alias->name,
11814 Status => $alias->status,
11815 Externally_Ok => 0);
11819 # Here done with all the basic stuff. Ready to populate the information
11820 # about each character if annotating them.
11823 # See comments at its declaration
11824 $annotate_ranges = Range_Map->new;
11826 # This separates out the non-characters from the other unassigneds, so
11827 # can give different annotations for each.
11828 $unassigned_sans_noncharacters = Range_List->new(
11829 Initialize => $gc->table('Unassigned')
11830 & property_ref('Noncharacter_Code_Point')->table('N'));
11832 for (my $i = 0; $i <= $LAST_UNICODE_CODEPOINT; $i++ ) {
11833 $i = populate_char_info($i); # Note sets $i so may cause skips
11840 sub add_perl_synonyms() {
11841 # A number of Unicode tables have Perl synonyms that are expressed in
11842 # the single-form, \p{name}. These are:
11843 # All the binary property Y tables, so that \p{Name=Y} gets \p{Name} and
11844 # \p{Is_Name} as synonyms
11845 # \p{Script=Value} gets \p{Value}, \p{Is_Value} as synonyms
11846 # \p{General_Category=Value} gets \p{Value}, \p{Is_Value} as synonyms
11847 # \p{Block=Value} gets \p{In_Value} as a synonym, and, if there is no
11848 # conflict, \p{Value} and \p{Is_Value} as well
11850 # This routine generates these synonyms, warning of any unexpected
11853 # Construct the list of tables to get synonyms for. Start with all the
11854 # binary and the General_Category ones.
11855 my @tables = grep { $_->type == $BINARY } property_ref('*');
11856 push @tables, $gc->tables;
11858 # If the version of Unicode includes the Script property, add its tables
11859 if (defined property_ref('Script')) {
11860 push @tables, property_ref('Script')->tables;
11863 # The Block tables are kept separate because they are treated differently.
11864 # And the earliest versions of Unicode didn't include them, so add only if
11867 push @blocks, $block->tables if defined $block;
11869 # Here, have the lists of tables constructed. Process blocks last so that
11870 # if there are name collisions with them, blocks have lowest priority.
11871 # Should there ever be other collisions, manual intervention would be
11872 # required. See the comments at the beginning of the program for a
11873 # possible way to handle those semi-automatically.
11874 foreach my $table (@tables, @blocks) {
11876 # For non-binary properties, the synonym is just the name of the
11877 # table, like Greek, but for binary properties the synonym is the name
11878 # of the property, and means the code points in its 'Y' table.
11879 my $nominal = $table;
11880 my $nominal_property = $nominal->property;
11882 if (! $nominal->isa('Property')) {
11887 # Here is a binary property. Use the 'Y' table. Verify that is
11889 my $yes = $nominal->table('Y');
11890 unless (defined $yes) { # Must be defined, but is permissible to
11892 Carp::my_carp_bug("Undefined $nominal, 'Y'. Skipping.");
11898 foreach my $alias ($nominal->aliases) {
11900 # Attempt to create a table in the perl directory for the
11901 # candidate table, using whatever aliases in it that don't
11902 # conflict. Also add non-conflicting aliases for all these
11903 # prefixed by 'Is_' (and/or 'In_' for Block property tables)
11905 foreach my $prefix ("", 'Is_', 'In_') {
11907 # Only Block properties can have added 'In_' aliases.
11908 next if $prefix eq 'In_' and $nominal_property != $block;
11910 my $proposed_name = $prefix . $alias->name;
11912 # No Is_Is, In_In, nor combinations thereof
11913 trace "$proposed_name is a no-no" if main::DEBUG && $to_trace && $proposed_name =~ /^ I [ns] _I [ns] _/x;
11914 next if $proposed_name =~ /^ I [ns] _I [ns] _/x;
11916 trace "Seeing if can add alias or table: 'perl=$proposed_name' based on $nominal" if main::DEBUG && $to_trace;
11918 # Get a reference to any existing table in the perl
11919 # directory with the desired name.
11920 my $pre_existing = $perl->table($proposed_name);
11922 if (! defined $pre_existing) {
11924 # No name collision, so ok to add the perl synonym.
11926 my $make_pod_entry;
11928 my $status = $actual->status;
11929 if ($nominal_property == $block) {
11931 # For block properties, the 'In' form is preferred for
11932 # external use; the pod file contains wild cards for
11933 # this and the 'Is' form so no entries for those; and
11934 # we don't want people using the name without the
11935 # 'In', so discourage that.
11936 if ($prefix eq "") {
11937 $make_pod_entry = 1;
11938 $status = $status || $DISCOURAGED;
11939 $externally_ok = 0;
11941 elsif ($prefix eq 'In_') {
11942 $make_pod_entry = 0;
11943 $status = $status || $NORMAL;
11944 $externally_ok = 1;
11947 $make_pod_entry = 0;
11948 $status = $status || $DISCOURAGED;
11949 $externally_ok = 0;
11952 elsif ($prefix ne "") {
11954 # The 'Is' prefix is handled in the pod by a wild
11955 # card, and we won't use it for an external name
11956 $make_pod_entry = 0;
11957 $status = $status || $NORMAL;
11958 $externally_ok = 0;
11962 # Here, is an empty prefix, non block. This gets its
11963 # own pod entry and can be used for an external name.
11964 $make_pod_entry = 1;
11965 $status = $status || $NORMAL;
11966 $externally_ok = 1;
11969 # Here, there isn't a perl pre-existing table with the
11970 # name. Look through the list of equivalents of this
11971 # table to see if one is a perl table.
11972 foreach my $equivalent ($actual->leader->equivalents) {
11973 next if $equivalent->property != $perl;
11975 # Here, have found a table for $perl. Add this alias
11976 # to it, and are done with this prefix.
11977 $equivalent->add_alias($proposed_name,
11978 Pod_Entry => $make_pod_entry,
11980 Externally_Ok => $externally_ok);
11981 trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace;
11985 # Here, $perl doesn't already have a table that is a
11986 # synonym for this property, add one.
11987 my $added_table = $perl->add_match_table($proposed_name,
11988 Pod_Entry => $make_pod_entry,
11990 Externally_Ok => $externally_ok);
11991 # And it will be related to the actual table, since it is
11993 $added_table->set_equivalent_to($actual, Related => 1);
11994 trace "added ", $perl->table($proposed_name) if main::DEBUG && $to_trace;
11996 } # End of no pre-existing.
11998 # Here, there is a pre-existing table that has the proposed
11999 # name. We could be in trouble, but not if this is just a
12000 # synonym for another table that we have already made a child
12001 # of the pre-existing one.
12002 if ($pre_existing->is_set_equivalent_to($actual)) {
12003 trace "$pre_existing is already equivalent to $actual; adding alias perl=$proposed_name to it" if main::DEBUG && $to_trace;
12004 $pre_existing->add_alias($proposed_name);
12008 # Here, there is a name collision, but it still could be ok if
12009 # the tables match the identical set of code points, in which
12010 # case, we can combine the names. Compare each table's code
12011 # point list to see if they are identical.
12012 trace "Potential name conflict with $pre_existing having ", $pre_existing->count, " code points" if main::DEBUG && $to_trace;
12013 if ($pre_existing->matches_identically_to($actual)) {
12015 # Here, they do match identically. Not a real conflict.
12016 # Make the perl version a child of the Unicode one, except
12017 # in the non-obvious case of where the perl name is
12018 # already a synonym of another Unicode property. (This is
12019 # excluded by the test for it being its own parent.) The
12020 # reason for this exclusion is that then the two Unicode
12021 # properties become related; and we don't really know if
12022 # they are or not. We generate documentation based on
12023 # relatedness, and this would be misleading. Code
12024 # later executed in the process will cause the tables to
12025 # be represented by a single file anyway, without making
12026 # it look in the pod like they are necessarily related.
12027 if ($pre_existing->parent == $pre_existing
12028 && ($pre_existing->property == $perl
12029 || $actual->property == $perl))
12031 trace "Setting $pre_existing equivalent to $actual since one is \$perl, and match identical sets" if main::DEBUG && $to_trace;
12032 $pre_existing->set_equivalent_to($actual, Related => 1);
12034 elsif (main::DEBUG && $to_trace) {
12035 trace "$pre_existing is equivalent to $actual since match identical sets, but not setting them equivalent, to preserve the separateness of the perl aliases";
12036 trace $pre_existing->parent;
12041 # Here they didn't match identically, there is a real conflict
12042 # between our new name and a pre-existing property.
12043 $actual->add_conflicting($proposed_name, 'p', $pre_existing);
12044 $pre_existing->add_conflicting($nominal->full_name,
12048 # Don't output a warning for aliases for the block
12049 # properties (unless they start with 'In_') as it is
12050 # expected that there will be conflicts and the block
12052 if ($verbosity >= $NORMAL_VERBOSITY
12053 && ($actual->property != $block || $prefix eq 'In_'))
12055 print simple_fold(join_lines(<<END
12056 There is already an alias named $proposed_name (from " . $pre_existing . "),
12057 so not creating this alias for " . $actual
12062 # Keep track for documentation purposes.
12063 $has_In_conflicts++ if $prefix eq 'In_';
12064 $has_Is_conflicts++ if $prefix eq 'Is_';
12069 # There are some properties which have No and Yes (and N and Y) as
12070 # property values, but aren't binary, and could possibly be confused with
12071 # binary ones. So create caveats for them. There are tables that are
12072 # named 'No', and tables that are named 'N', but confusion is not likely
12073 # unless they are the same table. For example, N meaning Number or
12074 # Neutral is not likely to cause confusion, so don't add caveats to things
12076 foreach my $property (grep { $_->type != $BINARY } property_ref('*')) {
12077 my $yes = $property->table('Yes');
12078 if (defined $yes) {
12079 my $y = $property->table('Y');
12080 if (defined $y && $yes == $y) {
12081 foreach my $alias ($property->aliases) {
12082 $yes->add_conflicting($alias->name);
12086 my $no = $property->table('No');
12088 my $n = $property->table('N');
12089 if (defined $n && $no == $n) {
12090 foreach my $alias ($property->aliases) {
12091 $no->add_conflicting($alias->name, 'P');
12100 sub register_file_for_name($$$) {
12101 # Given info about a table and a datafile that it should be associated
12102 # with, register that association
12105 my $directory_ref = shift; # Array of the directory path for the file
12106 my $file = shift; # The file name in the final directory, [-1].
12107 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12109 trace "table=$table, file=$file, directory=@$directory_ref" if main::DEBUG && $to_trace;
12111 if ($table->isa('Property')) {
12112 $table->set_file_path(@$directory_ref, $file);
12113 push @map_properties, $table
12114 if $directory_ref->[0] eq $map_directory;
12118 # Do all of the work for all equivalent tables when called with the leader
12119 # table, so skip if isn't the leader.
12120 return if $table->leader != $table;
12122 # Join all the file path components together, using slashes.
12123 my $full_filename = join('/', @$directory_ref, $file);
12125 # All go in the same subdirectory of unicore
12126 if ($directory_ref->[0] ne $matches_directory) {
12127 Carp::my_carp("Unexpected directory in "
12128 . join('/', @{$directory_ref}, $file));
12131 # For this table and all its equivalents ...
12132 foreach my $table ($table, $table->equivalents) {
12134 # Associate it with its file internally. Don't include the
12135 # $matches_directory first component
12136 $table->set_file_path(@$directory_ref, $file);
12137 my $sub_filename = join('/', $directory_ref->[1, -1], $file);
12139 my $property = $table->property;
12140 $property = ($property == $perl)
12141 ? "" # 'perl' is never explicitly stated
12142 : standardize($property->name) . '=';
12144 my $deprecated = ($table->status eq $DEPRECATED)
12145 ? $table->status_info
12147 my $caseless_equivalent = $table->caseless_equivalent;
12149 # And for each of the table's aliases... This inner loop eventually
12150 # goes through all aliases in the UCD that we generate regex match
12152 foreach my $alias ($table->aliases) {
12153 my $standard = utf8_heavy_name($table, $alias);
12155 # Generate an entry in either the loose or strict hashes, which
12156 # will translate the property and alias names combination into the
12157 # file where the table for them is stored.
12158 if ($alias->loose_match) {
12159 if (exists $loose_to_file_of{$standard}) {
12160 Carp::my_carp("Can't change file registered to $loose_to_file_of{$standard} to '$sub_filename'.");
12163 $loose_to_file_of{$standard} = $sub_filename;
12167 if (exists $stricter_to_file_of{$standard}) {
12168 Carp::my_carp("Can't change file registered to $stricter_to_file_of{$standard} to '$sub_filename'.");
12171 $stricter_to_file_of{$standard} = $sub_filename;
12173 # Tightly coupled with how utf8_heavy.pl works, for a
12174 # floating point number that is a whole number, get rid of
12175 # the trailing decimal point and 0's, so that utf8_heavy
12176 # will work. Also note that this assumes that such a
12177 # number is matched strictly; so if that were to change,
12178 # this would be wrong.
12179 if ((my $integer_name = $alias->name)
12180 =~ s/^ ( -? \d+ ) \.0+ $ /$1/x)
12182 $stricter_to_file_of{$property . $integer_name}
12188 # Keep a list of the deprecated properties and their filenames
12190 $utf8::why_deprecated{$sub_filename} = $deprecated;
12193 # And a substitute table, if any, for case-insensitive matching
12194 if ($caseless_equivalent != 0) {
12195 $caseless_equivalent_to{$standard} = $caseless_equivalent;
12204 my %base_names; # Names already used for avoiding DOS 8.3 filesystem
12206 my %full_dir_name_of; # Full length names of directories used.
12208 sub construct_filename($$$) {
12209 # Return a file name for a table, based on the table name, but perhaps
12210 # changed to get rid of non-portable characters in it, and to make
12211 # sure that it is unique on a file system that allows the names before
12212 # any period to be at most 8 characters (DOS). While we're at it
12213 # check and complain if there are any directory conflicts.
12215 my $name = shift; # The name to start with
12216 my $mutable = shift; # Boolean: can it be changed? If no, but
12217 # yet it must be to work properly, a warning
12219 my $directories_ref = shift; # A reference to an array containing the
12220 # path to the file, with each element one path
12221 # component. This is used because the same
12222 # name can be used in different directories.
12223 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12225 my $warn = ! defined wantarray; # If true, then if the name is
12226 # changed, a warning is issued as well.
12228 if (! defined $name) {
12229 Carp::my_carp("Undefined name in directory "
12230 . File::Spec->join(@$directories_ref)
12235 # Make sure that no directory names conflict with each other. Look at
12236 # each directory in the input file's path. If it is already in use,
12237 # assume it is correct, and is merely being re-used, but if we
12238 # truncate it to 8 characters, and find that there are two directories
12239 # that are the same for the first 8 characters, but differ after that,
12240 # then that is a problem.
12241 foreach my $directory (@$directories_ref) {
12242 my $short_dir = substr($directory, 0, 8);
12243 if (defined $full_dir_name_of{$short_dir}) {
12244 next if $full_dir_name_of{$short_dir} eq $directory;
12245 Carp::my_carp("$directory conflicts with $full_dir_name_of{$short_dir}. Bad News. Continuing anyway");
12248 $full_dir_name_of{$short_dir} = $directory;
12252 my $path = join '/', @$directories_ref;
12253 $path .= '/' if $path;
12255 # Remove interior underscores.
12256 (my $filename = $name) =~ s/ (?<=.) _ (?=.) //xg;
12258 # Change any non-word character into an underscore, and truncate to 8.
12259 $filename =~ s/\W+/_/g; # eg., "L&" -> "L_"
12260 substr($filename, 8) = "" if length($filename) > 8;
12262 # Make sure the basename doesn't conflict with something we
12263 # might have already written. If we have, say,
12270 while (my $num = $base_names{$path}{lc $filename}++) {
12271 $num++; # so basenames with numbers start with '2', which
12272 # just looks more natural.
12274 # Want to append $num, but if it'll make the basename longer
12275 # than 8 characters, pre-truncate $filename so that the result
12277 my $delta = length($filename) + length($num) - 8;
12279 substr($filename, -$delta) = $num;
12284 if ($warn && ! $warned) {
12286 Carp::my_carp("'$path$name' conflicts with another name on a filesystem with 8 significant characters (like DOS). Proceeding anyway.");
12290 return $filename if $mutable;
12292 # If not changeable, must return the input name, but warn if needed to
12293 # change it beyond shortening it.
12294 if ($name ne $filename
12295 && substr($name, 0, length($filename)) ne $filename) {
12296 Carp::my_carp("'$path$name' had to be changed into '$filename'. Bad News. Proceeding anyway.");
12302 # The pod file contains a very large table. Many of the lines in that table
12303 # would exceed a typical output window's size, and so need to be wrapped with
12304 # a hanging indent to make them look good. The pod language is really
12305 # insufficient here. There is no general construct to do that in pod, so it
12306 # is done here by beginning each such line with a space to cause the result to
12307 # be output without formatting, and doing all the formatting here. This leads
12308 # to the result that if the eventual display window is too narrow it won't
12309 # look good, and if the window is too wide, no advantage is taken of that
12310 # extra width. A further complication is that the output may be indented by
12311 # the formatter so that there is less space than expected. What I (khw) have
12312 # done is to assume that that indent is a particular number of spaces based on
12313 # what it is in my Linux system; people can always resize their windows if
12314 # necessary, but this is obviously less than desirable, but the best that can
12316 my $automatic_pod_indent = 8;
12318 # Try to format so that uses fewest lines, but few long left column entries
12319 # slide into the right column. An experiment on 5.1 data yielded the
12320 # following percentages that didn't cut into the other side along with the
12321 # associated first-column widths
12323 # 80% not too bad except for a few blocks
12324 # 90% = 33; # , cuts 353/3053 lines from 37 = 12%
12326 my $indent_info_column = 27; # 75% of lines didn't have overlap
12328 my $FILLER = 3; # Length of initial boiler-plate columns in a pod line
12329 # The 3 is because of:
12330 # 1 for the leading space to tell the pod formatter to
12333 # 1 for the space between the flag and the main data
12335 sub format_pod_line ($$$;$$) {
12336 # Take a pod line and return it, formatted properly
12338 my $first_column_width = shift;
12339 my $entry = shift; # Contents of left column
12340 my $info = shift; # Contents of right column
12342 my $status = shift || ""; # Any flag
12344 my $loose_match = shift; # Boolean.
12345 $loose_match = 1 unless defined $loose_match;
12347 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12350 $flags .= $STRICTER if ! $loose_match;
12352 $flags .= $status if $status;
12354 # There is a blank in the left column to cause the pod formatter to
12355 # output the line as-is.
12356 return sprintf " %-*s%-*s %s\n",
12357 # The first * in the format is replaced by this, the -1 is
12358 # to account for the leading blank. There isn't a
12359 # hard-coded blank after this to separate the flags from
12360 # the rest of the line, so that in the unlikely event that
12361 # multiple flags are shown on the same line, they both
12362 # will get displayed at the expense of that separation,
12363 # but since they are left justified, a blank will be
12364 # inserted in the normal case.
12368 # The other * in the format is replaced by this number to
12369 # cause the first main column to right fill with blanks.
12370 # The -1 is for the guaranteed blank following it.
12371 $first_column_width - $FILLER - 1,
12376 my @zero_match_tables; # List of tables that have no matches in this release
12378 sub make_table_pod_entries($) {
12379 # This generates the entries for the pod file for a given table.
12380 # Also done at this time are any children tables. The output looks like:
12381 # \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178)
12383 my $input_table = shift; # Table the entry is for
12384 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12386 # Generate parent and all its children at the same time.
12387 return if $input_table->parent != $input_table;
12389 my $property = $input_table->property;
12390 my $type = $property->type;
12391 my $full_name = $property->full_name;
12393 my $count = $input_table->count;
12394 my $string_count = clarify_number($count);
12395 my $status = $input_table->status;
12396 my $status_info = $input_table->status_info;
12398 my $entry_for_first_table; # The entry for the first table output.
12399 # Almost certainly, it is the parent.
12401 # For each related table (including itself), we will generate a pod entry
12402 # for each name each table goes by
12403 foreach my $table ($input_table, $input_table->children) {
12405 # utf8_heavy.pl cannot deal with null string property values, so don't
12407 next if $table->name eq "";
12409 # First, gather all the info that applies to this table as a whole.
12411 push @zero_match_tables, $table if $count == 0;
12413 my $table_property = $table->property;
12415 # The short name has all the underscores removed, while the full name
12416 # retains them. Later, we decide whether to output a short synonym
12417 # for the full one, we need to compare apples to apples, so we use the
12418 # short name's length including underscores.
12419 my $table_property_short_name_length;
12420 my $table_property_short_name
12421 = $table_property->short_name(\$table_property_short_name_length);
12422 my $table_property_full_name = $table_property->full_name;
12424 # Get how much savings there is in the short name over the full one
12425 # (delta will always be <= 0)
12426 my $table_property_short_delta = $table_property_short_name_length
12427 - length($table_property_full_name);
12428 my @table_description = $table->description;
12429 my @table_note = $table->note;
12431 # Generate an entry for each alias in this table.
12432 my $entry_for_first_alias; # saves the first one encountered.
12433 foreach my $alias ($table->aliases) {
12435 # Skip if not to go in pod.
12436 next unless $alias->make_pod_entry;
12438 # Start gathering all the components for the entry
12439 my $name = $alias->name;
12441 my $entry; # Holds the left column, may include extras
12442 my $entry_ref; # To refer to the left column's contents from
12443 # another entry; has no extras
12445 # First the left column of the pod entry. Tables for the $perl
12446 # property always use the single form.
12447 if ($table_property == $perl) {
12448 $entry = "\\p{$name}";
12449 $entry_ref = "\\p{$name}";
12451 else { # Compound form.
12453 # Only generate one entry for all the aliases that mean true
12454 # or false in binary properties. Append a '*' to indicate
12455 # some are missing. (The heading comment notes this.)
12456 my $wild_card_mark;
12457 if ($type == $BINARY) {
12458 next if $name ne 'N' && $name ne 'Y';
12459 $wild_card_mark = '*';
12462 $wild_card_mark = "";
12465 # Colon-space is used to give a little more space to be easier
12468 . $table_property_full_name
12469 . ": $name$wild_card_mark}";
12471 # But for the reference to this entry, which will go in the
12472 # right column, where space is at a premium, use equals
12474 $entry_ref = "\\p{" . $table_property_full_name . "=$name}";
12477 # Then the right (info) column. This is stored as components of
12478 # an array for the moment, then joined into a string later. For
12479 # non-internal only properties, begin the info with the entry for
12480 # the first table we encountered (if any), as things are ordered
12481 # so that that one is the most descriptive. This leads to the
12482 # info column of an entry being a more descriptive version of the
12485 if ($name =~ /^_/) {
12487 '(For internal use by Perl, not necessarily stable)';
12489 elsif ($entry_for_first_alias) {
12490 push @info, $entry_for_first_alias;
12493 # If this entry is equivalent to another, add that to the info,
12494 # using the first such table we encountered
12495 if ($entry_for_first_table) {
12497 push @info, "(= $entry_for_first_table)";
12500 push @info, $entry_for_first_table;
12504 # If the name is a large integer, add an equivalent with an
12505 # exponent for better readability
12506 if ($name =~ /^[+-]?[\d]+$/ && $name >= 10_000) {
12507 push @info, sprintf "(= %.1e)", $name
12510 my $parenthesized = "";
12511 if (! $entry_for_first_alias) {
12513 # This is the first alias for the current table. The alias
12514 # array is ordered so that this is the fullest, most
12515 # descriptive alias, so it gets the fullest info. The other
12516 # aliases are mostly merely pointers to this one, using the
12517 # information already added above.
12519 # Display any status message, but only on the parent table
12520 if ($status && ! $entry_for_first_table) {
12521 push @info, $status_info;
12524 # Put out any descriptive info
12525 if (@table_description || @table_note) {
12526 push @info, join "; ", @table_description, @table_note;
12529 # Look to see if there is a shorter name we can point people
12531 my $standard_name = standardize($name);
12533 my $proposed_short = $table->short_name;
12534 if (defined $proposed_short) {
12535 my $standard_short = standardize($proposed_short);
12537 # If the short name is shorter than the standard one, or
12538 # even it it's not, but the combination of it and its
12539 # short property name (as in \p{prop=short} ($perl doesn't
12540 # have this form)) saves at least two characters, then,
12541 # cause it to be listed as a shorter synonym.
12542 if (length $standard_short < length $standard_name
12543 || ($table_property != $perl
12544 && (length($standard_short)
12545 - length($standard_name)
12546 + $table_property_short_delta) # (<= 0)
12549 $short_name = $proposed_short;
12550 if ($table_property != $perl) {
12551 $short_name = $table_property_short_name
12554 $short_name = "\\p{$short_name}";
12558 # And if this is a compound form name, see if there is a
12559 # single form equivalent
12561 if ($table_property != $perl) {
12563 # Special case the binary N tables, so that will print
12564 # \P{single}, but use the Y table values to populate
12565 # 'single', as we haven't populated the N table.
12568 if ($type == $BINARY
12569 && $input_table == $property->table('No'))
12571 $test_table = $property->table('Yes');
12575 $test_table = $input_table;
12579 # Look for a single form amongst all the children.
12580 foreach my $table ($test_table->children) {
12581 next if $table->property != $perl;
12582 my $proposed_name = $table->short_name;
12583 next if ! defined $proposed_name;
12585 # Don't mention internal-only properties as a possible
12586 # single form synonym
12587 next if substr($proposed_name, 0, 1) eq '_';
12589 $proposed_name = "\\$p\{$proposed_name}";
12590 if (! defined $single_form
12591 || length($proposed_name) < length $single_form)
12593 $single_form = $proposed_name;
12595 # The goal here is to find a single form; not the
12596 # shortest possible one. We've already found a
12597 # short name. So, stop at the first single form
12598 # found, which is likely to be closer to the
12605 # Ouput both short and single in the same parenthesized
12606 # expression, but with only one of 'Single', 'Short' if there
12608 if ($short_name || $single_form || $table->conflicting) {
12609 $parenthesized .= "Short: $short_name" if $short_name;
12610 if ($short_name && $single_form) {
12611 $parenthesized .= ', ';
12613 elsif ($single_form) {
12614 $parenthesized .= 'Single: ';
12616 $parenthesized .= $single_form if $single_form;
12621 # Warn if this property isn't the same as one that a
12622 # semi-casual user might expect. The other components of this
12623 # parenthesized structure are calculated only for the first entry
12624 # for this table, but the conflicting is deemed important enough
12625 # to go on every entry.
12626 my $conflicting = join " NOR ", $table->conflicting;
12627 if ($conflicting) {
12628 $parenthesized .= '; ' if $parenthesized ne "";
12629 $parenthesized .= "NOT $conflicting";
12632 push @info, "($parenthesized)" if $parenthesized;
12634 if ($table_property != $perl && $table->perl_extension) {
12635 push @info, '(Perl extension)';
12637 push @info, "($string_count)";
12639 # Now, we have both the entry and info so add them to the
12640 # list of all the properties.
12641 push @match_properties,
12642 format_pod_line($indent_info_column,
12646 $alias->loose_match);
12648 $entry_for_first_alias = $entry_ref unless $entry_for_first_alias;
12649 } # End of looping through the aliases for this table.
12651 if (! $entry_for_first_table) {
12652 $entry_for_first_table = $entry_for_first_alias;
12654 } # End of looping through all the related tables
12658 sub pod_alphanumeric_sort {
12659 # Sort pod entries alphanumerically.
12661 # The first few character columns are filler, plus the '\p{'; and get rid
12662 # of all the trailing stuff, starting with the trailing '}', so as to sort
12663 # on just 'Name=Value'
12664 (my $a = lc $a) =~ s/^ .*? { //x;
12666 (my $b = lc $b) =~ s/^ .*? { //x;
12669 # Determine if the two operands are both internal only or both not.
12670 # Character 0 should be a '\'; 1 should be a p; 2 should be '{', so 3
12671 # should be the underscore that begins internal only
12672 my $a_is_internal = (substr($a, 0, 1) eq '_');
12673 my $b_is_internal = (substr($b, 0, 1) eq '_');
12675 # Sort so the internals come last in the table instead of first (which the
12676 # leading underscore would otherwise indicate).
12677 if ($a_is_internal != $b_is_internal) {
12678 return 1 if $a_is_internal;
12682 # Determine if the two operands are numeric property values or not.
12683 # A numeric property will look like xyz: 3. But the number
12684 # can begin with an optional minus sign, and may have a
12685 # fraction or rational component, like xyz: 3/2. If either
12686 # isn't numeric, use alphabetic sort.
12687 my ($a_initial, $a_number) =
12688 ($a =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
12689 return $a cmp $b unless defined $a_number;
12690 my ($b_initial, $b_number) =
12691 ($b =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
12692 return $a cmp $b unless defined $b_number;
12694 # Here they are both numeric, but use alphabetic sort if the
12695 # initial parts don't match
12696 return $a cmp $b if $a_initial ne $b_initial;
12698 # Convert rationals to floating for the comparison.
12699 $a_number = eval $a_number if $a_number =~ qr{/};
12700 $b_number = eval $b_number if $b_number =~ qr{/};
12702 return $a_number <=> $b_number;
12706 # Create the .pod file. This generates the various subsections and then
12707 # combines them in one big HERE document.
12709 return unless defined $pod_directory;
12710 print "Making pod file\n" if $verbosity >= $PROGRESS;
12712 my $exception_message =
12713 '(Any exceptions are individually noted beginning with the word NOT.)';
12715 if (-e 'Blocks.txt') {
12717 # Add the line: '\p{In_*} \p{Block: *}', with the warning message
12718 # if the global $has_In_conflicts indicates we have them.
12719 push @match_properties, format_pod_line($indent_info_column,
12722 . (($has_In_conflicts)
12723 ? " $exception_message"
12725 @block_warning = << "END";
12727 Matches in the Block property have shortcuts that begin with 'In_'. For
12728 example, \\p{Block=Latin1} can be written as \\p{In_Latin1}. For backward
12729 compatibility, if there is no conflict with another shortcut, these may also
12730 be written as \\p{Latin1} or \\p{Is_Latin1}. But, N.B., there are numerous
12731 such conflicting shortcuts. Use of these forms for Block is discouraged, and
12732 are flagged as such, not only because of the potential confusion as to what is
12733 meant, but also because a later release of Unicode may preempt the shortcut,
12734 and your program would no longer be correct. Use the 'In_' form instead to
12735 avoid this, or even more clearly, use the compound form, e.g.,
12736 \\p{blk:latin1}. See L<perlunicode/"Blocks"> for more information about this.
12739 my $text = "If an entry has flag(s) at its beginning, like '$DEPRECATED', the 'Is_' form has the same flag(s)";
12740 $text = "$exception_message $text" if $has_Is_conflicts;
12742 # And the 'Is_ line';
12743 push @match_properties, format_pod_line($indent_info_column,
12747 # Sort the properties array for output. It is sorted alphabetically
12748 # except numerically for numeric properties, and only output unique lines.
12749 @match_properties = sort pod_alphanumeric_sort uniques @match_properties;
12751 my $formatted_properties = simple_fold(\@match_properties,
12753 # indent succeeding lines by two extra
12754 # which looks better
12755 $indent_info_column + 2,
12757 # shorten the line length by how much
12758 # the formatter indents, so the folded
12759 # line will fit in the space
12760 # presumably available
12761 $automatic_pod_indent);
12762 # Add column headings, indented to be a little more centered, but not
12764 $formatted_properties = format_pod_line($indent_info_column,
12768 . $formatted_properties;
12770 # Generate pod documentation lines for the tables that match nothing
12772 if (@zero_match_tables) {
12773 @zero_match_tables = uniques(@zero_match_tables);
12774 $zero_matches = join "\n\n",
12775 map { $_ = '=item \p{' . $_->complete_name . "}" }
12776 sort { $a->complete_name cmp $b->complete_name }
12777 uniques(@zero_match_tables);
12779 $zero_matches = <<END;
12781 =head2 Legal \\p{} and \\P{} constructs that match no characters
12783 Unicode has some property-value pairs that currently don't match anything.
12784 This happens generally either because they are obsolete, or for symmetry with
12785 other forms, but no language has yet been encoded that uses them. In this
12786 version of Unicode, the following match zero code points:
12797 # Generate list of properties that we don't accept, grouped by the reasons
12798 # why. This is so only put out the 'why' once, and then list all the
12799 # properties that have that reason under it.
12801 my %why_list; # The keys are the reasons; the values are lists of
12802 # properties that have the key as their reason
12804 # For each property, add it to the list that are suppressed for its reason
12805 # The sort will cause the alphabetically first properties to be added to
12806 # each list first, so each list will be sorted.
12807 foreach my $property (sort keys %why_suppressed) {
12808 push @{$why_list{$why_suppressed{$property}}}, $property;
12811 # For each reason (sorted by the first property that has that reason)...
12812 my @bad_re_properties;
12813 foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] }
12816 # Add to the output, all the properties that have that reason. Start
12817 # with an empty line.
12818 push @bad_re_properties, "\n\n";
12820 my $has_item = 0; # Flag if actually output anything.
12821 foreach my $name (@{$why_list{$why}}) {
12823 # Split compound names into $property and $table components
12824 my $property = $name;
12826 if ($property =~ / (.*) = (.*) /x) {
12831 # This release of Unicode may not have a property that is
12832 # suppressed, so don't reference a non-existent one.
12833 $property = property_ref($property);
12834 next if ! defined $property;
12836 # And since this list is only for match tables, don't list the
12837 # ones that don't have match tables.
12838 next if ! $property->to_create_match_tables;
12840 # Find any abbreviation, and turn it into a compound name if this
12841 # is a property=value pair.
12842 my $short_name = $property->name;
12843 $short_name .= '=' . $property->table($table)->name if $table;
12845 # And add the property as an item for the reason.
12846 push @bad_re_properties, "\n=item I<$name> ($short_name)\n";
12850 # And add the reason under the list of properties, if such a list
12851 # actually got generated. Note that the header got added
12852 # unconditionally before. But pod ignores extra blank lines, so no
12854 push @bad_re_properties, "\n$why\n" if $has_item;
12856 } # End of looping through each reason.
12858 # Generate a list of the properties whose map table we output, from the
12859 # global @map_properties.
12860 my @map_tables_actually_output;
12861 my $info_indent = 20; # Left column is narrower than \p{} table.
12862 foreach my $property (@map_properties) {
12864 # Get the path to the file; don't output any not in the standard
12866 my @path = $property->file_path;
12867 next if $path[0] ne $map_directory;
12868 shift @path; # Remove the standard name
12870 my $file = join '/', @path; # In case is in sub directory
12871 my $info = $property->full_name;
12872 my $short_name = $property->name;
12873 if ($info ne $short_name) {
12874 $info .= " ($short_name)";
12876 foreach my $more_info ($property->description,
12878 $property->status_info)
12880 next unless $more_info;
12882 $info .= ". $more_info";
12884 push @map_tables_actually_output, format_pod_line($info_indent,
12887 $property->status);
12890 # Sort alphabetically, and fold for output
12891 @map_tables_actually_output = sort
12892 pod_alphanumeric_sort @map_tables_actually_output;
12893 @map_tables_actually_output
12894 = simple_fold(\@map_tables_actually_output,
12897 $automatic_pod_indent);
12899 # Generate a list of the formats that can appear in the map tables.
12900 my @map_table_formats;
12901 foreach my $format (sort keys %map_table_formats) {
12902 push @map_table_formats, " $format $map_table_formats{$format}\n";
12905 # Everything is ready to assemble.
12906 my @OUT = << "END";
12911 To change this file, edit $0 instead.
12917 $pod_file - Index of Unicode Version $string_version properties in Perl
12921 There are many properties in Unicode, and Perl provides access to almost all of
12922 them, as well as some additional extensions and short-cut synonyms.
12924 And just about all of the few that aren't accessible through the Perl
12925 core are accessible through the modules: Unicode::Normalize and
12926 Unicode::UCD, and for Unihan properties, via the CPAN module Unicode::Unihan.
12928 This document merely lists all available properties and does not attempt to
12929 explain what each property really means. There is a brief description of each
12930 Perl extension. There is some detail about Blocks, Scripts, General_Category,
12931 and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the
12932 Unicode properties, refer to the Unicode standard. A good starting place is
12933 L<$unicode_reference_url>. More information on the Perl extensions is in
12934 L<perlrecharclass>.
12936 Note that you can define your own properties; see
12937 L<perlunicode/"User-Defined Character Properties">.
12939 =head1 Properties accessible through \\p{} and \\P{}
12941 The Perl regular expression \\p{} and \\P{} constructs give access to most of
12942 the Unicode character properties. The table below shows all these constructs,
12943 both single and compound forms.
12945 B<Compound forms> consist of two components, separated by an equals sign or a
12946 colon. The first component is the property name, and the second component is
12947 the particular value of the property to match against, for example,
12948 '\\p{Script: Greek}' and '\\p{Script=Greek}' both mean to match characters
12949 whose Script property is Greek.
12951 B<Single forms>, like '\\p{Greek}', are mostly Perl-defined shortcuts for
12952 their equivalent compound forms. The table shows these equivalences. (In our
12953 example, '\\p{Greek}' is a just a shortcut for '\\p{Script=Greek}'.)
12954 There are also a few Perl-defined single forms that are not shortcuts for a
12955 compound form. One such is \\p{Word}. These are also listed in the table.
12957 In parsing these constructs, Perl always ignores Upper/lower case differences
12958 everywhere within the {braces}. Thus '\\p{Greek}' means the same thing as
12959 '\\p{greek}'. But note that changing the case of the 'p' or 'P' before the
12960 left brace completely changes the meaning of the construct, from "match" (for
12961 '\\p{}') to "doesn't match" (for '\\P{}'). Casing in this document is for
12962 improved legibility.
12964 Also, white space, hyphens, and underscores are also normally ignored
12965 everywhere between the {braces}, and hence can be freely added or removed
12966 even if the C</x> modifier hasn't been specified on the regular expression.
12967 But $a_bold_stricter at the beginning of an entry in the table below
12968 means that tighter (stricter) rules are used for that entry:
12972 =item Single form (\\p{name}) tighter rules:
12974 White space, hyphens, and underscores ARE significant
12979 =item * white space adjacent to a non-word character
12981 =item * underscores separating digits in numbers
12985 That means, for example, that you can freely add or remove white space
12986 adjacent to (but within) the braces without affecting the meaning.
12988 =item Compound form (\\p{name=value} or \\p{name:value}) tighter rules:
12990 The tighter rules given above for the single form apply to everything to the
12991 right of the colon or equals; the looser rules still apply to everything to
12994 That means, for example, that you can freely add or remove white space
12995 adjacent to (but within) the braces and the colon or equal sign.
12999 Some properties are considered obsolete, but still available. There are
13000 several varieties of obsolescence:
13006 Properties marked with $a_bold_obsolete in the table are considered
13011 Obsolete properties may be stabilized. Such a determination does not indicate
13012 that the property should or should not be used; instead it is a declaration
13013 that the property will not be maintained nor extended for newly encoded
13014 characters. Such properties are marked with $a_bold_stabilized in the
13019 An obsolete property may be deprecated, perhaps because its original intent
13020 has been replaced by another property or because its specification was somehow
13021 defective. This means that its use is strongly
13022 discouraged, so much so that a warning will be issued if used, unless the
13023 regular expression is in the scope of a C<S<no warnings 'deprecated'>>
13024 statement. $A_bold_deprecated flags each such entry in the table, and
13025 the entry there for the longest, most descriptive version of the property will
13026 give the reason it is deprecated, and perhaps advice. Perl may issue such a
13027 warning, even for properties that aren't officially deprecated by Unicode,
13028 when there used to be characters or code points that were matched by them, but
13029 no longer. This is to warn you that your program may not work like it did on
13030 earlier Unicode releases.
13032 A deprecated property may be made unavailable in a future Perl version, so it
13033 is best to move away from them.
13037 Some Perl extensions are present for backwards compatibility and are
13038 discouraged from being used, but not obsolete. $A_bold_discouraged
13039 flags each such entry in the table.
13043 The table below has two columns. The left column contains the \\p{}
13044 constructs to look up, possibly preceded by the flags mentioned above; and
13045 the right column contains information about them, like a description, or
13046 synonyms. It shows both the single and compound forms for each property that
13047 has them. If the left column is a short name for a property, the right column
13048 will give its longer, more descriptive name; and if the left column is the
13049 longest name, the right column will show any equivalent shortest name, in both
13050 single and compound forms if applicable.
13052 The right column will also caution you if a property means something different
13053 than what might normally be expected.
13055 All single forms are Perl extensions; a few compound forms are as well, and
13058 Numbers in (parentheses) indicate the total number of code points matched by
13059 the property. For emphasis, those properties that match no code points at all
13060 are listed as well in a separate section following the table.
13062 There is no description given for most non-Perl defined properties (See
13063 $unicode_reference_url for that).
13065 For compactness, 'B<*>' is used as a wildcard instead of showing all possible
13066 combinations. For example, entries like:
13068 \\p{Gc: *} \\p{General_Category: *}
13070 mean that 'Gc' is a synonym for 'General_Category', and anything that is valid
13071 for the latter is also valid for the former. Similarly,
13075 means that if and only if, for example, \\p{Foo} exists, then \\p{Is_Foo} and
13076 \\p{IsFoo} are also valid and all mean the same thing. And similarly,
13077 \\p{Foo=Bar} means the same as \\p{Is_Foo=Bar} and \\p{IsFoo=Bar}. '*' here
13078 is restricted to something not beginning with an underscore.
13080 Also, in binary properties, 'Yes', 'T', and 'True' are all synonyms for 'Y'.
13081 And 'No', 'F', and 'False' are all synonyms for 'N'. The table shows 'Y*' and
13082 'N*' to indicate this, and doesn't have separate entries for the other
13083 possibilities. Note that not all properties which have values 'Yes' and 'No'
13084 are binary, and they have all their values spelled out without using this wild
13085 card, and a C<NOT> clause in their description that highlights their not being
13086 binary. These also require the compound form to match them, whereas true
13087 binary properties have both single and compound forms available.
13089 Note that all non-essential underscores are removed in the display of the
13096 =item B<*> is a wild-card
13098 =item B<(\\d+)> in the info column gives the number of code points matched by
13101 =item B<$DEPRECATED> means this is deprecated.
13103 =item B<$OBSOLETE> means this is obsolete.
13105 =item B<$STABILIZED> means this is stabilized.
13107 =item B<$STRICTER> means tighter (stricter) name matching applies.
13109 =item B<$DISCOURAGED> means use of this form is discouraged.
13113 $formatted_properties
13117 =head1 Properties not accessible through \\p{} and \\P{}
13119 A few properties are accessible in Perl via various function calls only.
13121 Lowercase_Mapping lc() and lcfirst()
13122 Titlecase_Mapping ucfirst()
13123 Uppercase_Mapping uc()
13125 Case_Folding is accessible through the /i modifier in regular expressions.
13127 The Name property is accessible through the \\N{} interpolation in
13128 double-quoted strings and regular expressions, but both usages require a C<use
13129 charnames;> to be specified, which also contains related functions viacode(),
13130 vianame(), and string_vianame().
13132 =head1 Unicode regular expression properties that are NOT accepted by Perl
13134 Perl will generate an error for a few character properties in Unicode when
13135 used in a regular expression. The non-Unihan ones are listed below, with the
13136 reasons they are not accepted, perhaps with work-arounds. The short names for
13137 the properties are listed enclosed in (parentheses).
13145 An installation can choose to allow any of these to be matched by changing the
13146 controlling lists contained in the program
13147 C<\$Config{privlib}>/F<unicore/mktables> and then re-running F<mktables>.
13148 (C<\%Config> is available from the Config module).
13150 =head1 Files in the I<To> directory (for serious hackers only)
13152 All Unicode properties are really mappings (in the mathematical sense) from
13153 code points to their respective values. As part of its build process,
13154 Perl constructs tables containing these mappings for all properties that it
13155 deals with. But only a few of these are written out into files.
13156 Those written out are in the directory C<\$Config{privlib}>/F<unicore/To/>
13157 (%Config is available from the Config module).
13159 Those ones written are ones needed by Perl internally during execution, or for
13160 which there is some demand, and those for which there is no access through the
13161 Perl core. Generally, properties that can be used in regular expression
13162 matching do not have their map tables written, like Script. Nor are the
13163 simplistic properties that have a better, more complete version, such as
13164 Simple_Uppercase_Mapping (Uppercase_Mapping is written instead).
13166 None of the properties in the I<To> directory are currently directly
13167 accessible through the Perl core, although some may be accessed indirectly.
13168 For example, the uc() function implements the Uppercase_Mapping property and
13169 uses the F<Upper.pl> file found in this directory.
13171 The available files in the current installation, with their properties (short
13172 names in parentheses), and any flags or comments about them, are:
13174 @map_tables_actually_output
13176 An installation can choose to change which files are generated by changing the
13177 controlling lists contained in the program
13178 C<\$Config{privlib}>/F<unicore/mktables> and then re-running F<mktables>.
13180 Each of these files defines two hash entries to help reading programs decipher
13181 it. One of them looks like this:
13183 \$utf8::SwashInfo{'ToNAME'}{'format'} = 's';
13185 where 'NAME' is a name to indicate the property. For backwards compatibility,
13186 this is not necessarily the property's official Unicode name. (The 'To' is
13187 also for backwards compatibility.) The hash entry gives the format of the
13188 mapping fields of the table, currently one of the following:
13192 This format applies only to the entries in the main body of the table.
13193 Entries defined in hashes or ones that are missing from the list can have a
13196 The value that the missing entries have is given by the other SwashInfo hash
13197 entry line; it looks like this:
13199 \$utf8::SwashInfo{'ToNAME'}{'missing'} = 'NaN';
13201 This example line says that any Unicode code points not explicitly listed in
13202 the file have the value 'NaN' under the property indicated by NAME. If the
13203 value is the special string C<< <code point> >>, it means that the value for
13204 any missing code point is the code point itself. This happens, for example,
13205 in the file for Uppercase_Mapping (To/Upper.pl), in which code points like the
13206 character 'A', are missing because the uppercase of 'A' is itself.
13210 L<$unicode_reference_url>
13218 # And write it. The 0 means no utf8.
13219 main::write([ $pod_directory, "$pod_file.pod" ], 0, \@OUT);
13223 sub make_Heavy () {
13224 # Create and write Heavy.pl, which passes info about the tables to
13231 # This file is for the use of utf8_heavy.pl
13233 # Maps property names in loose standard form to its standard name
13234 \%utf8::loose_property_name_of = (
13237 push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4);
13238 push @heavy, <<END;
13241 # Maps property, table to file for those using stricter matching
13242 \%utf8::stricter_to_file_of = (
13244 push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4);
13245 push @heavy, <<END;
13248 # Maps property, table to file for those using loose matching
13249 \%utf8::loose_to_file_of = (
13251 push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4);
13252 push @heavy, <<END;
13255 # Maps floating point to fractional form
13256 \%utf8::nv_floating_to_rational = (
13258 push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4);
13259 push @heavy, <<END;
13262 # If a floating point number doesn't have enough digits in it to get this
13263 # close to a fraction, it isn't considered to be that fraction even if all the
13264 # digits it does have match.
13265 \$utf8::max_floating_slop = $MAX_FLOATING_SLOP;
13267 # Deprecated tables to generate a warning for. The key is the file containing
13268 # the table, so as to avoid duplication, as many property names can map to the
13269 # file, but we only need one entry for all of them.
13270 \%utf8::why_deprecated = (
13273 push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4);
13274 push @heavy, <<END;
13277 # A few properties have different behavior under /i matching. This maps the
13278 # those to substitute files to use under /i.
13279 \%utf8::caseless_equivalent = (
13283 # We set the key to the file when we associated files with tables, but we
13284 # couldn't do the same for the value then, as we might not have the file
13285 # for the alternate table figured out at that time.
13286 foreach my $cased (keys %caseless_equivalent_to) {
13287 my @path = $caseless_equivalent_to{$cased}->file_path;
13288 my $path = join '/', @path[1, -1];
13290 $utf8::caseless_equivalent_to{$cased} = $path;
13292 push @heavy, simple_dumper (\%utf8::caseless_equivalent_to, ' ' x 4);
13293 push @heavy, <<END;
13299 main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
13303 sub write_all_tables() {
13304 # Write out all the tables generated by this program to files, as well as
13305 # the supporting data structures, pod file, and .t file.
13307 my @writables; # List of tables that actually get written
13308 my %match_tables_to_write; # Used to collapse identical match tables
13309 # into one file. Each key is a hash function
13310 # result to partition tables into buckets.
13311 # Each value is an array of the tables that
13312 # fit in the bucket.
13314 # For each property ...
13315 # (sort so that if there is an immutable file name, it has precedence, so
13316 # some other property can't come in and take over its file name. If b's
13317 # file name is defined, will return 1, meaning to take it first; don't
13318 # care if both defined, as they had better be different anyway)
13320 foreach my $property (sort { defined $b->file } property_ref('*')) {
13321 my $type = $property->type;
13323 # And for each table for that property, starting with the mapping
13326 foreach my $table($property,
13328 # and all the match tables for it (if any), sorted so
13329 # the ones with the shortest associated file name come
13330 # first. The length sorting prevents problems of a
13331 # longer file taking a name that might have to be used
13332 # by a shorter one. The alphabetic sorting prevents
13333 # differences between releases
13334 sort { my $ext_a = $a->external_name;
13335 return 1 if ! defined $ext_a;
13336 my $ext_b = $b->external_name;
13337 return -1 if ! defined $ext_b;
13338 my $cmp = length $ext_a <=> length $ext_b;
13340 # Return result if lengths not equal
13341 return $cmp if $cmp;
13343 # Alphabetic if lengths equal
13344 return $ext_a cmp $ext_b
13345 } $property->tables
13349 # Here we have a table associated with a property. It could be
13350 # the map table (done first for each property), or one of the
13351 # other tables. Determine which type.
13352 my $is_property = $table->isa('Property');
13354 my $name = $table->name;
13355 my $complete_name = $table->complete_name;
13357 # See if should suppress the table if is empty, but warn if it
13358 # contains something.
13359 my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ }
13360 keys %why_suppress_if_empty_warn_if_not;
13362 # Calculate if this table should have any code points associated
13364 my $expected_empty =
13366 # $perl should be empty, as well as properties that we just
13367 # don't do anything with
13369 && ($table == $perl
13370 || grep { $complete_name eq $_ }
13371 @unimplemented_properties
13375 # Match tables in properties we skipped populating should be
13377 || (! $is_property && ! $property->to_create_match_tables)
13379 # Tables and properties that are expected to have no code
13380 # points should be empty
13381 || $suppress_if_empty_warn_if_not
13384 # Set a boolean if this table is the complement of an empty binary
13386 my $is_complement_of_empty_binary =
13387 $type == $BINARY &&
13388 (($table == $property->table('Y')
13389 && $property->table('N')->is_empty)
13390 || ($table == $property->table('N')
13391 && $property->table('Y')->is_empty));
13394 # Some tables should match everything
13395 my $expected_full =
13397 ? # All these types of map tables will be full because
13398 # they will have been populated with defaults
13399 ($type == $ENUM || $type == $BINARY)
13401 : # A match table should match everything if its method
13403 ($table->matches_all
13405 # The complement of an empty binary table will match
13407 || $is_complement_of_empty_binary
13411 if ($table->is_empty) {
13414 if ($suppress_if_empty_warn_if_not) {
13415 $table->set_status($SUPPRESSED,
13416 $why_suppress_if_empty_warn_if_not{$complete_name});
13419 # Suppress expected empty tables.
13420 next TABLE if $expected_empty;
13422 # And setup to later output a warning for those that aren't
13423 # known to be allowed to be empty. Don't do the warning if
13424 # this table is a child of another one to avoid duplicating
13425 # the warning that should come from the parent one.
13426 if (($table == $property || $table->parent == $table)
13427 && $table->status ne $SUPPRESSED
13428 && ! grep { $complete_name =~ /^$_$/ }
13429 @tables_that_may_be_empty)
13431 push @unhandled_properties, "$table";
13434 elsif ($expected_empty) {
13436 if ($suppress_if_empty_warn_if_not) {
13437 $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}";
13440 Carp::my_carp("Not expecting property $table$because. Generating file for it anyway.");
13443 my $count = $table->count;
13444 if ($expected_full) {
13445 if ($count != $MAX_UNICODE_CODEPOINTS) {
13446 Carp::my_carp("$table matches only "
13447 . clarify_number($count)
13448 . " Unicode code points but should match "
13449 . clarify_number($MAX_UNICODE_CODEPOINTS)
13451 . clarify_number(abs($MAX_UNICODE_CODEPOINTS - $count))
13452 . "). Proceeding anyway.");
13455 # Here is expected to be full. If it is because it is the
13456 # complement of an (empty) binary table that is to be
13457 # suppressed, then suppress this one as well.
13458 if ($is_complement_of_empty_binary) {
13459 my $opposing_name = ($name eq 'Y') ? 'N' : 'Y';
13460 my $opposing = $property->table($opposing_name);
13461 my $opposing_status = $opposing->status;
13462 if ($opposing_status) {
13463 $table->set_status($opposing_status,
13464 $opposing->status_info);
13468 elsif ($count == $MAX_UNICODE_CODEPOINTS) {
13469 if ($table == $property || $table->leader == $table) {
13470 Carp::my_carp("$table unexpectedly matches all Unicode code points. Proceeding anyway.");
13474 if ($table->status eq $SUPPRESSED) {
13475 if (! $is_property) {
13476 my @children = $table->children;
13477 foreach my $child (@children) {
13478 if ($child->status ne $SUPPRESSED) {
13479 Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't");
13486 if (! $is_property) {
13488 # Several things need to be done just once for each related
13489 # group of match tables. Do them on the parent.
13490 if ($table->parent == $table) {
13492 # Add an entry in the pod file for the table; it also does
13494 make_table_pod_entries($table) if defined $pod_directory;
13496 # See if the the table matches identical code points with
13497 # something that has already been output. In that case,
13498 # no need to have two files with the same code points in
13499 # them. We use the table's hash() method to store these
13500 # in buckets, so that it is quite likely that if two
13501 # tables are in the same bucket they will be identical, so
13502 # don't have to compare tables frequently. The tables
13503 # have to have the same status to share a file, so add
13504 # this to the bucket hash. (The reason for this latter is
13505 # that Heavy.pl associates a status with a file.)
13506 my $hash = $table->hash . ';' . $table->status;
13508 # Look at each table that is in the same bucket as this
13510 foreach my $comparison (@{$match_tables_to_write{$hash}})
13512 if ($table->matches_identically_to($comparison)) {
13513 $table->set_equivalent_to($comparison,
13519 # Here, not equivalent, add this table to the bucket.
13520 push @{$match_tables_to_write{$hash}}, $table;
13525 # Here is the property itself.
13526 # Don't write out or make references to the $perl property
13527 next if $table == $perl;
13529 if ($type != $STRING) {
13531 # There is a mapping stored of the various synonyms to the
13532 # standardized name of the property for utf8_heavy.pl.
13533 # Also, the pod file contains entries of the form:
13534 # \p{alias: *} \p{full: *}
13535 # rather than show every possible combination of things.
13537 my @property_aliases = $property->aliases;
13539 # The full name of this property is stored by convention
13540 # first in the alias array
13541 my $full_property_name =
13542 '\p{' . $property_aliases[0]->name . ': *}';
13543 my $standard_property_name = standardize($table->name);
13545 # For each synonym ...
13546 for my $i (0 .. @property_aliases - 1) {
13547 my $alias = $property_aliases[$i];
13548 my $alias_name = $alias->name;
13549 my $alias_standard = standardize($alias_name);
13551 # Set the mapping for utf8_heavy of the alias to the
13553 if (exists ($loose_property_name_of{$alias_standard}))
13555 Carp::my_carp("There already is a property with the same standard name as $alias_name: $loose_property_name_of{$alias_standard}. Old name is retained");
13558 $loose_property_name_of{$alias_standard}
13559 = $standard_property_name;
13562 # Now for the pod entry for this alias. Skip if not
13563 # outputting a pod; skip the first one, which is the
13564 # full name so won't have an entry like: '\p{full: *}
13565 # \p{full: *}', and skip if don't want an entry for
13568 || ! defined $pod_directory
13569 || ! $alias->make_pod_entry;
13571 my $rhs = $full_property_name;
13572 if ($property != $perl && $table->perl_extension) {
13573 $rhs .= ' (Perl extension)';
13575 push @match_properties,
13576 format_pod_line($indent_info_column,
13577 '\p{' . $alias->name . ': *}',
13581 } # End of non-string-like property code
13584 # Don't output a mapping file if not desired.
13585 next if ! $property->to_output_map;
13588 # Here, we know we want to write out the table, but don't do it
13589 # yet because there may be other tables that come along and will
13590 # want to share the file, and the file's comments will change to
13591 # mention them. So save for later.
13592 push @writables, $table;
13594 } # End of looping through the property and all its tables.
13595 } # End of looping through all properties.
13597 # Now have all the tables that will have files written for them. Do it.
13598 foreach my $table (@writables) {
13601 my $property = $table->property;
13602 my $is_property = ($table == $property);
13603 if (! $is_property) {
13605 # Match tables for the property go in lib/$subdirectory, which is
13606 # the property's name. Don't use the standard file name for this,
13607 # as may get an unfamiliar alias
13608 @directory = ($matches_directory, $property->external_name);
13612 @directory = $table->directory;
13613 $filename = $table->file;
13616 # Use specified filename if available, or default to property's
13617 # shortest name. We need an 8.3 safe filename (which means "an 8
13618 # safe" filename, since after the dot is only 'pl', which is < 3)
13619 # The 2nd parameter is if the filename shouldn't be changed, and
13620 # it shouldn't iff there is a hard-coded name for this table.
13621 $filename = construct_filename(
13622 $filename || $table->external_name,
13623 ! $filename, # mutable if no filename
13626 register_file_for_name($table, \@directory, $filename);
13628 # Only need to write one file when shared by more than one
13630 next if ! $is_property && $table->leader != $table;
13632 # Construct a nice comment to add to the file
13633 $table->set_final_comment;
13639 # Write out the pod file
13645 make_property_test_script() if $make_test_script;
13649 my @white_space_separators = ( # This used only for making the test script.
13656 sub generate_separator($) {
13657 # This used only for making the test script. It generates the colon or
13658 # equal separator between the property and property value, with random
13659 # white space surrounding the separator
13663 return "" if $lhs eq ""; # No separator if there's only one (the r) side
13665 # Choose space before and after randomly
13666 my $spaces_before =$white_space_separators[rand(@white_space_separators)];
13667 my $spaces_after = $white_space_separators[rand(@white_space_separators)];
13669 # And return the whole complex, half the time using a colon, half the
13671 return $spaces_before
13672 . (rand() < 0.5) ? '=' : ':'
13676 sub generate_tests($$$$$) {
13677 # This used only for making the test script. It generates test cases that
13678 # are expected to compile successfully in perl. Note that the lhs and
13679 # rhs are assumed to already be as randomized as the caller wants.
13681 my $lhs = shift; # The property: what's to the left of the colon
13682 # or equals separator
13683 my $rhs = shift; # The property value; what's to the right
13684 my $valid_code = shift; # A code point that's known to be in the
13685 # table given by lhs=rhs; undef if table is
13687 my $invalid_code = shift; # A code point known to not be in the table;
13688 # undef if the table is all code points
13689 my $warning = shift;
13691 # Get the colon or equal
13692 my $separator = generate_separator($lhs);
13694 # The whole 'property=value'
13695 my $name = "$lhs$separator$rhs";
13698 # Create a complete set of tests, with complements.
13699 if (defined $valid_code) {
13700 push @output, <<"EOC"
13701 Expect(1, $valid_code, '\\p{$name}', $warning);
13702 Expect(0, $valid_code, '\\p{^$name}', $warning);
13703 Expect(0, $valid_code, '\\P{$name}', $warning);
13704 Expect(1, $valid_code, '\\P{^$name}', $warning);
13707 if (defined $invalid_code) {
13708 push @output, <<"EOC"
13709 Expect(0, $invalid_code, '\\p{$name}', $warning);
13710 Expect(1, $invalid_code, '\\p{^$name}', $warning);
13711 Expect(1, $invalid_code, '\\P{$name}', $warning);
13712 Expect(0, $invalid_code, '\\P{^$name}', $warning);
13718 sub generate_error($$$) {
13719 # This used only for making the test script. It generates test cases that
13720 # are expected to not only not match, but to be syntax or similar errors
13722 my $lhs = shift; # The property: what's to the left of the
13723 # colon or equals separator
13724 my $rhs = shift; # The property value; what's to the right
13725 my $already_in_error = shift; # Boolean; if true it's known that the
13726 # unmodified lhs and rhs will cause an error.
13727 # This routine should not force another one
13728 # Get the colon or equal
13729 my $separator = generate_separator($lhs);
13731 # Since this is an error only, don't bother to randomly decide whether to
13732 # put the error on the left or right side; and assume that the rhs is
13733 # loosely matched, again for convenience rather than rigor.
13734 $rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error;
13736 my $property = $lhs . $separator . $rhs;
13739 Error('\\p{$property}');
13740 Error('\\P{$property}');
13744 # These are used only for making the test script
13745 # XXX Maybe should also have a bad strict seps, which includes underscore.
13747 my @good_loose_seps = (
13754 my @bad_loose_seps = (
13759 sub randomize_stricter_name {
13760 # This used only for making the test script. Take the input name and
13761 # return a randomized, but valid version of it under the stricter matching
13765 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
13767 # If the name looks like a number (integer, floating, or rational), do
13769 if ($name =~ qr{ ^ ( -? ) (\d+ ( ( [./] ) \d+ )? ) $ }x) {
13772 my $separator = $3;
13774 # If there isn't a sign, part of the time add a plus
13775 # Note: Not testing having any denominator having a minus sign
13777 $sign = '+' if rand() <= .3;
13780 # And add 0 or more leading zeros.
13781 $name = $sign . ('0' x int rand(10)) . $number;
13783 if (defined $separator) {
13784 my $extra_zeros = '0' x int rand(10);
13786 if ($separator eq '.') {
13788 # Similarly, add 0 or more trailing zeros after a decimal
13790 $name .= $extra_zeros;
13794 # Or, leading zeros before the denominator
13795 $name =~ s,/,/$extra_zeros,;
13800 # For legibility of the test, only change the case of whole sections at a
13801 # time. To do this, first split into sections. The split returns the
13804 for my $section (split / ( [ - + \s _ . ]+ ) /x, $name) {
13805 trace $section if main::DEBUG && $to_trace;
13807 if (length $section > 1 && $section !~ /\D/) {
13809 # If the section is a sequence of digits, about half the time
13810 # randomly add underscores between some of them.
13813 # Figure out how many underscores to add. max is 1 less than
13814 # the number of digits. (But add 1 at the end to make sure
13815 # result isn't 0, and compensate earlier by subtracting 2
13817 my $num_underscores = int rand(length($section) - 2) + 1;
13819 # And add them evenly throughout, for convenience, not rigor
13821 my $spacing = (length($section) - 1)/ $num_underscores;
13822 my $temp = $section;
13824 for my $i (1 .. $num_underscores) {
13825 $section .= substr($temp, 0, $spacing, "") . '_';
13829 push @sections, $section;
13833 # Here not a sequence of digits. Change the case of the section
13835 my $switch = int rand(4);
13836 if ($switch == 0) {
13837 push @sections, uc $section;
13839 elsif ($switch == 1) {
13840 push @sections, lc $section;
13842 elsif ($switch == 2) {
13843 push @sections, ucfirst $section;
13846 push @sections, $section;
13850 trace "returning", join "", @sections if main::DEBUG && $to_trace;
13851 return join "", @sections;
13854 sub randomize_loose_name($;$) {
13855 # This used only for making the test script
13858 my $want_error = shift; # if true, make an error
13859 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
13861 $name = randomize_stricter_name($name);
13864 push @parts, $good_loose_seps[rand(@good_loose_seps)];
13865 for my $part (split /[-\s_]+/, $name) {
13867 if ($want_error and rand() < 0.3) {
13868 push @parts, $bad_loose_seps[rand(@bad_loose_seps)];
13872 push @parts, $good_loose_seps[rand(@good_loose_seps)];
13875 push @parts, $part;
13877 my $new = join("", @parts);
13878 trace "$name => $new" if main::DEBUG && $to_trace;
13881 if (rand() >= 0.5) {
13882 $new .= $bad_loose_seps[rand(@bad_loose_seps)];
13885 $new = $bad_loose_seps[rand(@bad_loose_seps)] . $new;
13891 # Used to make sure don't generate duplicate test cases.
13892 my %test_generated;
13894 sub make_property_test_script() {
13895 # This used only for making the test script
13896 # this written directly -- it's huge.
13898 print "Making test script\n" if $verbosity >= $PROGRESS;
13900 # This uses randomness to test different possibilities without testing all
13901 # possibilities. To ensure repeatability, set the seed to 0. But if
13902 # tests are added, it will perturb all later ones in the .t file
13905 $t_path = 'TestProp.pl' unless defined $t_path; # the traditional name
13907 # Keep going down an order of magnitude
13908 # until find that adding this quantity to
13909 # 1 remains 1; but put an upper limit on
13910 # this so in case this algorithm doesn't
13911 # work properly on some platform, that we
13912 # won't loop forever.
13914 my $min_floating_slop = 1;
13915 while (1+ $min_floating_slop != 1
13918 my $next = $min_floating_slop / 10;
13919 last if $next == 0; # If underflows,
13921 $min_floating_slop = $next;
13924 # It doesn't matter whether the elements of this array contain single lines
13925 # or multiple lines. main::write doesn't count the lines.
13928 foreach my $property (property_ref('*')) {
13929 foreach my $table ($property->tables) {
13931 # Find code points that match, and don't match this table.
13932 my $valid = $table->get_valid_code_point;
13933 my $invalid = $table->get_invalid_code_point;
13934 my $warning = ($table->status eq $DEPRECATED)
13938 # Test each possible combination of the property's aliases with
13939 # the table's. If this gets to be too many, could do what is done
13940 # in the set_final_comment() for Tables
13941 my @table_aliases = $table->aliases;
13942 my @property_aliases = $table->property->aliases;
13943 my $max = max(scalar @table_aliases, scalar @property_aliases);
13944 for my $j (0 .. $max - 1) {
13946 # The current alias for property is the next one on the list,
13947 # or if beyond the end, start over. Similarly for table
13949 = $property_aliases[$j % @property_aliases]->name;
13951 $property_name = "" if $table->property == $perl;
13952 my $table_alias = $table_aliases[$j % @table_aliases];
13953 my $table_name = $table_alias->name;
13954 my $loose_match = $table_alias->loose_match;
13956 # If the table doesn't have a file, any test for it is
13957 # already guaranteed to be in error
13958 my $already_error = ! $table->file_path;
13960 # Generate error cases for this alias.
13961 push @output, generate_error($property_name,
13965 # If the table is guaranteed to always generate an error,
13966 # quit now without generating success cases.
13967 next if $already_error;
13969 # Now for the success cases.
13971 if ($loose_match) {
13973 # For loose matching, create an extra test case for the
13975 my $standard = standardize($table_name);
13977 # $test_name should be a unique combination for each test
13978 # case; used just to avoid duplicate tests
13979 my $test_name = "$property_name=$standard";
13981 # Don't output duplicate test cases.
13982 if (! exists $test_generated{$test_name}) {
13983 $test_generated{$test_name} = 1;
13984 push @output, generate_tests($property_name,
13991 $random = randomize_loose_name($table_name)
13993 else { # Stricter match
13994 $random = randomize_stricter_name($table_name);
13997 # Now for the main test case for this alias.
13998 my $test_name = "$property_name=$random";
13999 if (! exists $test_generated{$test_name}) {
14000 $test_generated{$test_name} = 1;
14001 push @output, generate_tests($property_name,
14008 # If the name is a rational number, add tests for the
14009 # floating point equivalent.
14010 if ($table_name =~ qr{/}) {
14012 # Calculate the float, and find just the fraction.
14013 my $float = eval $table_name;
14014 my ($whole, $fraction)
14015 = $float =~ / (.*) \. (.*) /x;
14017 # Starting with one digit after the decimal point,
14018 # create a test for each possible precision (number of
14019 # digits past the decimal point) until well beyond the
14020 # native number found on this machine. (If we started
14021 # with 0 digits, it would be an integer, which could
14022 # well match an unrelated table)
14024 for my $i (1 .. $min_floating_slop + 3) {
14025 my $table_name = sprintf("%.*f", $i, $float);
14026 if ($i < $MIN_FRACTION_LENGTH) {
14028 # If the test case has fewer digits than the
14029 # minimum acceptable precision, it shouldn't
14030 # succeed, so we expect an error for it.
14031 # E.g., 2/3 = .7 at one decimal point, and we
14032 # shouldn't say it matches .7. We should make
14033 # it be .667 at least before agreeing that the
14034 # intent was to match 2/3. But at the
14035 # less-than- acceptable level of precision, it
14036 # might actually match an unrelated number.
14037 # So don't generate a test case if this
14038 # conflating is possible. In our example, we
14039 # don't want 2/3 matching 7/10, if there is
14040 # a 7/10 code point.
14042 (keys %nv_floating_to_rational)
14045 if abs($table_name - $existing)
14046 < $MAX_FLOATING_SLOP;
14048 push @output, generate_error($property_name,
14050 1 # 1 => already an error
14055 # Here the number of digits exceeds the
14056 # minimum we think is needed. So generate a
14057 # success test case for it.
14058 push @output, generate_tests($property_name,
14076 (map {"Test_X('$_');\n"} @backslash_X_tests),
14081 # This is a list of the input files and how to handle them. The files are
14082 # processed in their order in this list. Some reordering is possible if
14083 # desired, but the v0 files should be first, and the extracted before the
14084 # others except DAge.txt (as data in an extracted file can be over-ridden by
14085 # the non-extracted. Some other files depend on data derived from an earlier
14086 # file, like UnicodeData requires data from Jamo, and the case changing and
14087 # folding requires data from Unicode. Mostly, it safest to order by first
14088 # version releases in (except the Jamo). DAge.txt is read before the
14089 # extracted ones because of the rarely used feature $compare_versions. In the
14090 # unlikely event that there were ever an extracted file that contained the Age
14091 # property information, it would have to go in front of DAge.
14093 # The version strings allow the program to know whether to expect a file or
14094 # not, but if a file exists in the directory, it will be processed, even if it
14095 # is in a version earlier than expected, so you can copy files from a later
14096 # release into an earlier release's directory.
14097 my @input_file_objects = (
14098 Input_file->new('PropertyAliases.txt', v0,
14099 Handler => \&process_PropertyAliases,
14101 Input_file->new(undef, v0, # No file associated with this
14102 Progress_Message => 'Finishing property setup',
14103 Handler => \&finish_property_setup,
14105 Input_file->new('PropValueAliases.txt', v0,
14106 Handler => \&process_PropValueAliases,
14107 Has_Missings_Defaults => $NOT_IGNORED,
14109 Input_file->new('DAge.txt', v3.2.0,
14110 Has_Missings_Defaults => $NOT_IGNORED,
14113 Input_file->new("${EXTRACTED}DGeneralCategory.txt", v3.1.0,
14114 Property => 'General_Category',
14116 Input_file->new("${EXTRACTED}DCombiningClass.txt", v3.1.0,
14117 Property => 'Canonical_Combining_Class',
14118 Has_Missings_Defaults => $NOT_IGNORED,
14120 Input_file->new("${EXTRACTED}DNumType.txt", v3.1.0,
14121 Property => 'Numeric_Type',
14122 Has_Missings_Defaults => $NOT_IGNORED,
14124 Input_file->new("${EXTRACTED}DEastAsianWidth.txt", v3.1.0,
14125 Property => 'East_Asian_Width',
14126 Has_Missings_Defaults => $NOT_IGNORED,
14128 Input_file->new("${EXTRACTED}DLineBreak.txt", v3.1.0,
14129 Property => 'Line_Break',
14130 Has_Missings_Defaults => $NOT_IGNORED,
14132 Input_file->new("${EXTRACTED}DBidiClass.txt", v3.1.1,
14133 Property => 'Bidi_Class',
14134 Has_Missings_Defaults => $NOT_IGNORED,
14136 Input_file->new("${EXTRACTED}DDecompositionType.txt", v3.1.0,
14137 Property => 'Decomposition_Type',
14138 Has_Missings_Defaults => $NOT_IGNORED,
14140 Input_file->new("${EXTRACTED}DBinaryProperties.txt", v3.1.0),
14141 Input_file->new("${EXTRACTED}DNumValues.txt", v3.1.0,
14142 Property => 'Numeric_Value',
14143 Each_Line_Handler => \&filter_numeric_value_line,
14144 Has_Missings_Defaults => $NOT_IGNORED,
14146 Input_file->new("${EXTRACTED}DJoinGroup.txt", v3.1.0,
14147 Property => 'Joining_Group',
14148 Has_Missings_Defaults => $NOT_IGNORED,
14151 Input_file->new("${EXTRACTED}DJoinType.txt", v3.1.0,
14152 Property => 'Joining_Type',
14153 Has_Missings_Defaults => $NOT_IGNORED,
14155 Input_file->new('Jamo.txt', v2.0.0,
14156 Property => 'Jamo_Short_Name',
14157 Each_Line_Handler => \&filter_jamo_line,
14159 Input_file->new('UnicodeData.txt', v1.1.5,
14160 Pre_Handler => \&setup_UnicodeData,
14162 # We clean up this file for some early versions.
14163 Each_Line_Handler => [ (($v_version lt v2.0.0 )
14165 : ($v_version eq v2.1.5)
14166 ? \&filter_v2_1_5_ucd
14168 # And for 5.14 Perls with 6.0,
14169 # have to also make changes
14170 : ($v_version ge v6.0.0)
14174 # And the main filter
14175 \&filter_UnicodeData_line,
14177 EOF_Handler => \&EOF_UnicodeData,
14179 Input_file->new('ArabicShaping.txt', v2.0.0,
14180 Each_Line_Handler =>
14181 [ ($v_version lt 4.1.0)
14182 ? \&filter_old_style_arabic_shaping
14184 \&filter_arabic_shaping_line,
14186 Has_Missings_Defaults => $NOT_IGNORED,
14188 Input_file->new('Blocks.txt', v2.0.0,
14189 Property => 'Block',
14190 Has_Missings_Defaults => $NOT_IGNORED,
14191 Each_Line_Handler => \&filter_blocks_lines
14193 Input_file->new('PropList.txt', v2.0.0,
14194 Each_Line_Handler => (($v_version lt v3.1.0)
14195 ? \&filter_old_style_proplist
14198 Input_file->new('Unihan.txt', v2.0.0,
14199 Pre_Handler => \&setup_unihan,
14201 Each_Line_Handler => \&filter_unihan_line,
14203 Input_file->new('SpecialCasing.txt', v2.1.8,
14204 Each_Line_Handler => \&filter_special_casing_line,
14205 Pre_Handler => \&setup_special_casing,
14208 'LineBreak.txt', v3.0.0,
14209 Has_Missings_Defaults => $NOT_IGNORED,
14210 Property => 'Line_Break',
14211 # Early versions had problematic syntax
14212 Each_Line_Handler => (($v_version lt v3.1.0)
14213 ? \&filter_early_ea_lb
14216 Input_file->new('EastAsianWidth.txt', v3.0.0,
14217 Property => 'East_Asian_Width',
14218 Has_Missings_Defaults => $NOT_IGNORED,
14219 # Early versions had problematic syntax
14220 Each_Line_Handler => (($v_version lt v3.1.0)
14221 ? \&filter_early_ea_lb
14224 Input_file->new('CompositionExclusions.txt', v3.0.0,
14225 Property => 'Composition_Exclusion',
14227 Input_file->new('BidiMirroring.txt', v3.0.1,
14228 Property => 'Bidi_Mirroring_Glyph',
14230 Input_file->new("NormalizationTest.txt", v3.0.1,
14233 Input_file->new('CaseFolding.txt', v3.0.1,
14234 Pre_Handler => \&setup_case_folding,
14235 Each_Line_Handler =>
14236 [ ($v_version lt v3.1.0)
14237 ? \&filter_old_style_case_folding
14239 \&filter_case_folding_line
14242 Input_file->new('DCoreProperties.txt', v3.1.0,
14243 # 5.2 changed this file
14244 Has_Missings_Defaults => (($v_version ge v5.2.0)
14248 Input_file->new('Scripts.txt', v3.1.0,
14249 Property => 'Script',
14250 Has_Missings_Defaults => $NOT_IGNORED,
14252 Input_file->new('DNormalizationProps.txt', v3.1.0,
14253 Has_Missings_Defaults => $NOT_IGNORED,
14254 Each_Line_Handler => (($v_version lt v4.0.1)
14255 ? \&filter_old_style_normalization_lines
14258 Input_file->new('HangulSyllableType.txt', v4.0.0,
14259 Has_Missings_Defaults => $NOT_IGNORED,
14260 Property => 'Hangul_Syllable_Type'),
14261 Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0,
14262 Property => 'Word_Break',
14263 Has_Missings_Defaults => $NOT_IGNORED,
14265 Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1.0,
14266 Property => 'Grapheme_Cluster_Break',
14267 Has_Missings_Defaults => $NOT_IGNORED,
14269 Input_file->new("$AUXILIARY/GCBTest.txt", v4.1.0,
14270 Handler => \&process_GCB_test,
14272 Input_file->new("$AUXILIARY/LBTest.txt", v4.1.0,
14275 Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
14278 Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
14281 Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
14282 Property => 'Sentence_Break',
14283 Has_Missings_Defaults => $NOT_IGNORED,
14285 Input_file->new('NamedSequences.txt', v4.1.0,
14286 Handler => \&process_NamedSequences
14288 Input_file->new('NameAliases.txt', v5.0.0,
14289 Property => 'Name_Alias',
14291 Input_file->new("BidiTest.txt", v5.2.0,
14294 Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
14296 Each_Line_Handler => \&filter_unihan_line,
14298 Input_file->new('UnihanDataDictionaryLike.txt', v5.2.0,
14300 Each_Line_Handler => \&filter_unihan_line,
14302 Input_file->new('UnihanIRGSources.txt', v5.2.0,
14304 Pre_Handler => \&setup_unihan,
14305 Each_Line_Handler => \&filter_unihan_line,
14307 Input_file->new('UnihanNumericValues.txt', v5.2.0,
14309 Each_Line_Handler => \&filter_unihan_line,
14311 Input_file->new('UnihanOtherMappings.txt', v5.2.0,
14313 Each_Line_Handler => \&filter_unihan_line,
14315 Input_file->new('UnihanRadicalStrokeCounts.txt', v5.2.0,
14317 Each_Line_Handler => \&filter_unihan_line,
14319 Input_file->new('UnihanReadings.txt', v5.2.0,
14321 Each_Line_Handler => \&filter_unihan_line,
14323 Input_file->new('UnihanVariants.txt', v5.2.0,
14325 Each_Line_Handler => \&filter_unihan_line,
14329 # End of all the preliminaries.
14332 if ($compare_versions) {
14333 Carp::my_carp(<<END
14334 Warning. \$compare_versions is set. Output is not suitable for production
14339 # Put into %potential_files a list of all the files in the directory structure
14340 # that could be inputs to this program, excluding those that we should ignore.
14341 # Use absolute file names because it makes it easier across machine types.
14342 my @ignored_files_full_names = map { File::Spec->rel2abs(
14343 internal_file_to_platform($_))
14344 } keys %ignored_files;
14347 return unless /\.txt$/i; # Some platforms change the name's case
14348 my $full = lc(File::Spec->rel2abs($_));
14349 $potential_files{$full} = 1
14350 if ! grep { $full eq lc($_) } @ignored_files_full_names;
14353 }, File::Spec->curdir());
14355 my @mktables_list_output_files;
14356 my $old_start_time = 0;
14358 if (! -e $file_list) {
14359 print "'$file_list' doesn't exist, so forcing rebuild.\n" if $verbosity >= $VERBOSE;
14360 $write_unchanged_files = 1;
14361 } elsif ($write_unchanged_files) {
14362 print "Not checking file list '$file_list'.\n" if $verbosity >= $VERBOSE;
14365 print "Reading file list '$file_list'\n" if $verbosity >= $VERBOSE;
14367 if (! open $file_handle, "<", $file_list) {
14368 Carp::my_carp("Failed to open '$file_list'; turning on -globlist option instead: $!");
14374 # Read and parse mktables.lst, placing the results from the first part
14375 # into @input, and the second part into @mktables_list_output_files
14376 for my $list ( \@input, \@mktables_list_output_files ) {
14377 while (<$file_handle>) {
14378 s/^ \s+ | \s+ $//xg;
14379 if (/^ \s* \# .* Autogenerated\ starting\ on\ (\d+)/x) {
14380 $old_start_time = $1;
14382 next if /^ \s* (?: \# .* )? $/x;
14384 my ( $file ) = split /\t/;
14385 push @$list, $file;
14387 @$list = uniques(@$list);
14391 # Look through all the input files
14392 foreach my $input (@input) {
14393 next if $input eq 'version'; # Already have checked this.
14395 # Ignore if doesn't exist. The checking about whether we care or
14396 # not is done via the Input_file object.
14397 next if ! file_exists($input);
14399 # The paths are stored with relative names, and with '/' as the
14400 # delimiter; convert to absolute on this machine
14401 my $full = lc(File::Spec->rel2abs(internal_file_to_platform($input)));
14402 $potential_files{$full} = 1
14403 if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
14407 close $file_handle;
14412 # Here wants to process all .txt files in the directory structure.
14413 # Convert them to full path names. They are stored in the platform's
14416 foreach my $object (@input_file_objects) {
14417 my $file = $object->file;
14418 next unless defined $file;
14419 push @known_files, File::Spec->rel2abs($file);
14422 my @unknown_input_files;
14423 foreach my $file (keys %potential_files) {
14424 next if grep { lc($file) eq lc($_) } @known_files;
14426 # Here, the file is unknown to us. Get relative path name
14427 $file = File::Spec->abs2rel($file);
14428 push @unknown_input_files, $file;
14430 # What will happen is we create a data structure for it, and add it to
14431 # the list of input files to process. First get the subdirectories
14433 my (undef, $directories, undef) = File::Spec->splitpath($file);
14434 $directories =~ s;/$;;; # Can have extraneous trailing '/'
14435 my @directories = File::Spec->splitdir($directories);
14437 # If the file isn't extracted (meaning none of the directories is the
14438 # extracted one), just add it to the end of the list of inputs.
14439 if (! grep { $EXTRACTED_DIR eq $_ } @directories) {
14440 push @input_file_objects, Input_file->new($file, v0);
14444 # Here, the file is extracted. It needs to go ahead of most other
14445 # processing. Search for the first input file that isn't a
14446 # special required property (that is, find one whose first_release
14447 # is non-0), and isn't extracted. Also, the Age property file is
14448 # processed before the extracted ones, just in case
14449 # $compare_versions is set.
14450 for (my $i = 0; $i < @input_file_objects; $i++) {
14451 if ($input_file_objects[$i]->first_released ne v0
14452 && lc($input_file_objects[$i]->file) ne 'dage.txt'
14453 && $input_file_objects[$i]->file !~ /$EXTRACTED_DIR/i)
14455 splice @input_file_objects, $i, 0,
14456 Input_file->new($file, v0);
14463 if (@unknown_input_files) {
14464 print STDERR simple_fold(join_lines(<<END
14466 The following files are unknown as to how to handle. Assuming they are
14467 typical property files. You'll know by later error messages if it worked or
14470 ) . " " . join(", ", @unknown_input_files) . "\n\n");
14472 } # End of looking through directory structure for more .txt files.
14474 # Create the list of input files from the objects we have defined, plus
14476 my @input_files = 'version';
14477 foreach my $object (@input_file_objects) {
14478 my $file = $object->file;
14479 next if ! defined $file; # Not all objects have files
14480 next if $object->optional && ! -e $file;
14481 push @input_files, $file;
14484 if ( $verbosity >= $VERBOSE ) {
14485 print "Expecting ".scalar( @input_files )." input files. ",
14486 "Checking ".scalar( @mktables_list_output_files )." output files.\n";
14489 # We set $most_recent to be the most recently changed input file, including
14490 # this program itself (done much earlier in this file)
14491 foreach my $in (@input_files) {
14492 next unless -e $in; # Keep going even if missing a file
14493 my $mod_time = (stat $in)[9];
14494 $most_recent = $mod_time if $mod_time > $most_recent;
14496 # See that the input files have distinct names, to warn someone if they
14497 # are adding a new one
14499 my ($volume, $directories, $file ) = File::Spec->splitpath($in);
14500 $directories =~ s;/$;;; # Can have extraneous trailing '/'
14501 my @directories = File::Spec->splitdir($directories);
14502 my $base = $file =~ s/\.txt$//;
14503 construct_filename($file, 'mutable', \@directories);
14507 my $rebuild = $write_unchanged_files # Rebuild: if unconditional rebuild
14508 || ! scalar @mktables_list_output_files # or if no outputs known
14509 || $old_start_time < $most_recent; # or out-of-date
14511 # Now we check to see if any output files are older than youngest, if
14512 # they are, we need to continue on, otherwise we can presumably bail.
14514 foreach my $out (@mktables_list_output_files) {
14515 if ( ! file_exists($out)) {
14516 print "'$out' is missing.\n" if $verbosity >= $VERBOSE;
14520 #local $to_trace = 1 if main::DEBUG;
14521 trace $most_recent, (stat $out)[9] if main::DEBUG && $to_trace;
14522 if ( (stat $out)[9] <= $most_recent ) {
14523 #trace "$out: most recent mod time: ", (stat $out)[9], ", youngest: $most_recent\n" if main::DEBUG && $to_trace;
14524 print "'$out' is too old.\n" if $verbosity >= $VERBOSE;
14531 print "Files seem to be ok, not bothering to rebuild. Add '-w' option to force build\n";
14534 print "Must rebuild tables.\n" if $verbosity >= $VERBOSE;
14536 # Ready to do the major processing. First create the perl pseudo-property.
14537 $perl = Property->new('perl', Type => $NON_STRING, Perl_Extension => 1);
14539 # Process each input file
14540 foreach my $file (@input_file_objects) {
14544 # Finish the table generation.
14546 print "Finishing processing Unicode properties\n" if $verbosity >= $PROGRESS;
14549 print "Compiling Perl properties\n" if $verbosity >= $PROGRESS;
14552 print "Creating Perl synonyms\n" if $verbosity >= $PROGRESS;
14553 add_perl_synonyms();
14555 print "Writing tables\n" if $verbosity >= $PROGRESS;
14556 write_all_tables();
14558 # Write mktables.lst
14559 if ( $file_list and $make_list ) {
14561 print "Updating '$file_list'\n" if $verbosity >= $PROGRESS;
14562 foreach my $file (@input_files, @files_actually_output) {
14563 my (undef, $directories, $file) = File::Spec->splitpath($file);
14564 my @directories = File::Spec->splitdir($directories);
14565 $file = join '/', @directories, $file;
14569 if (! open $ofh,">",$file_list) {
14570 Carp::my_carp("Can't write to '$file_list'. Skipping: $!");
14574 my $localtime = localtime $start_time;
14575 print $ofh <<"END";
14577 # $file_list -- File list for $0.
14579 # Autogenerated starting on $start_time ($localtime)
14581 # - First section is input files
14582 # ($0 itself is not listed but is automatically considered an input)
14583 # - Section separator is /^=+\$/
14584 # - Second section is a list of output files.
14585 # - Lines matching /^\\s*#/ are treated as comments
14586 # which along with blank lines are ignored.
14592 print $ofh "$_\n" for sort(@input_files);
14593 print $ofh "\n=================================\n# Output files:\n\n";
14594 print $ofh "$_\n" for sort @files_actually_output;
14595 print $ofh "\n# ",scalar(@input_files)," input files\n",
14596 "# ",scalar(@files_actually_output)+1," output files\n\n",
14599 or Carp::my_carp("Failed to close $ofh: $!");
14601 print "Filelist has ",scalar(@input_files)," input files and ",
14602 scalar(@files_actually_output)+1," output files\n"
14603 if $verbosity >= $VERBOSE;
14607 # Output these warnings unless -q explicitly specified.
14608 if ($verbosity >= $NORMAL_VERBOSITY) {
14609 if (@unhandled_properties) {
14610 print "\nProperties and tables that unexpectedly have no code points\n";
14611 foreach my $property (sort @unhandled_properties) {
14612 print $property, "\n";
14616 if (%potential_files) {
14617 print "\nInput files that are not considered:\n";
14618 foreach my $file (sort keys %potential_files) {
14619 print File::Spec->abs2rel($file), "\n";
14622 print "\nAll done\n" if $verbosity >= $VERBOSE;
14626 # TRAILING CODE IS USED BY make_property_test_script()
14632 # If run outside the normal test suite on an ASCII platform, you can
14633 # just create a latin1_to_native() function that just returns its
14634 # inputs, because that's the only function used from test.pl
14637 # Test qr/\X/ and the \p{} regular expression constructs. This file is
14638 # constructed by mktables from the tables it generates, so if mktables is
14639 # buggy, this won't necessarily catch those bugs. Tests are generated for all
14640 # feasible properties; a few aren't currently feasible; see
14641 # is_code_point_usable() in mktables for details.
14643 # Standard test packages are not used because this manipulates SIG_WARN. It
14644 # exits 0 if every non-skipped test succeeded; -1 if any failed.
14650 my $expected = shift;
14653 my $warning_type = shift; # Type of warning message, like 'deprecated'
14655 my $line = (caller)[2];
14656 $ord = ord(latin1_to_native(chr($ord)));
14658 # Convert the code point to hex form
14659 my $string = sprintf "\"\\x{%04X}\"", $ord;
14663 # The first time through, use all warnings. If the input should generate
14664 # a warning, add another time through with them turned off
14665 push @tests, "no warnings '$warning_type';" if $warning_type;
14667 foreach my $no_warnings (@tests) {
14669 # Store any warning messages instead of outputting them
14670 local $SIG{__WARN__} = $SIG{__WARN__};
14671 my $warning_message;
14672 $SIG{__WARN__} = sub { $warning_message = $_[0] };
14676 # A string eval is needed because of the 'no warnings'.
14677 # Assumes no parens in the regular expression
14678 my $result = eval "$no_warnings
14679 my \$RegObj = qr($regex);
14680 $string =~ \$RegObj ? 1 : 0";
14681 if (not defined $result) {
14682 print "not ok $Tests - couldn't compile /$regex/; line $line: $@\n";
14685 elsif ($result ^ $expected) {
14686 print "not ok $Tests - expected $expected but got $result for $string =~ qr/$regex/; line $line\n";
14689 elsif ($warning_message) {
14690 if (! $warning_type || ($warning_type && $no_warnings)) {
14691 print "not ok $Tests - for qr/$regex/ did not expect warning message '$warning_message'; line $line\n";
14695 print "ok $Tests - expected and got a warning message for qr/$regex/; line $line\n";
14698 elsif ($warning_type && ! $no_warnings) {
14699 print "not ok $Tests - for qr/$regex/ expected a $warning_type warning message, but got none; line $line\n";
14703 print "ok $Tests - got $result for $string =~ qr/$regex/; line $line\n";
14712 if (eval { 'x' =~ qr/$regex/; 1 }) {
14714 my $line = (caller)[2];
14715 print "not ok $Tests - re compiled ok, but expected error for qr/$regex/; line $line: $@\n";
14718 my $line = (caller)[2];
14719 print "ok $Tests - got and expected error for qr/$regex/; line $line\n";
14724 # GCBTest.txt character that separates grapheme clusters
14725 my $breakable_utf8 = my $breakable = chr(0xF7);
14726 utf8::upgrade($breakable_utf8);
14728 # GCBTest.txt character that indicates that the adjoining code points are part
14729 # of the same grapheme cluster
14730 my $nobreak_utf8 = my $nobreak = chr(0xD7);
14731 utf8::upgrade($nobreak_utf8);
14734 # Test qr/\X/ matches. The input is a line from auxiliary/GCBTest.txt
14735 # Each such line is a sequence of code points given by their hex numbers,
14736 # separated by the two characters defined just before this subroutine that
14737 # indicate that either there can or cannot be a break between the adjacent
14738 # code points. If there isn't a break, that means the sequence forms an
14739 # extended grapheme cluster, which means that \X should match the whole
14740 # thing. If there is a break, \X should stop there. This is all
14741 # converted by this routine into a match:
14742 # $string =~ /(\X)/,
14743 # Each \X should match the next cluster; and that is what is checked.
14745 my $template = shift;
14747 my $line = (caller)[2];
14749 # The line contains characters above the ASCII range, but in Latin1. It
14750 # may or may not be in utf8, and if it is, it may or may not know it. So,
14751 # convert these characters to 8 bits. If knows is in utf8, simply
14753 if (utf8::is_utf8($template)) {
14754 utf8::downgrade($template);
14757 # Otherwise, if it is in utf8, but doesn't know it, the next lines
14758 # convert the two problematic characters to their 8-bit equivalents.
14759 # If it isn't in utf8, they don't harm anything.
14761 $template =~ s/$nobreak_utf8/$nobreak/g;
14762 $template =~ s/$breakable_utf8/$breakable/g;
14765 # Get rid of the leading and trailing breakables
14766 $template =~ s/^ \s* $breakable \s* //x;
14767 $template =~ s/ \s* $breakable \s* $ //x;
14769 # And no-breaks become just a space.
14770 $template =~ s/ \s* $nobreak \s* / /xg;
14772 # Split the input into segments that are breakable between them.
14773 my @segments = split /\s*$breakable\s*/, $template;
14776 my $display_string = "";
14778 my @should_display;
14780 # Convert the code point sequence in each segment into a Perl string of
14782 foreach my $segment (@segments) {
14783 my @code_points = split /\s+/, $segment;
14784 my $this_string = "";
14785 my $this_display = "";
14786 foreach my $code_point (@code_points) {
14787 $this_string .= latin1_to_native(chr(hex $code_point));
14788 $this_display .= "\\x{$code_point}";
14791 # The next cluster should match the string in this segment.
14792 push @should_match, $this_string;
14793 push @should_display, $this_display;
14794 $string .= $this_string;
14795 $display_string .= $this_display;
14798 # If a string can be represented in both non-ut8 and utf8, test both cases
14800 for my $to_upgrade (0 .. 1) {
14804 # If already in utf8, would just be a repeat
14805 next UPGRADE if utf8::is_utf8($string);
14807 utf8::upgrade($string);
14810 # Finally, do the \X match.
14811 my @matches = $string =~ /(\X)/g;
14813 # Look through each matched cluster to verify that it matches what we
14815 my $min = (@matches < @should_match) ? @matches : @should_match;
14816 for my $i (0 .. $min - 1) {
14818 if ($matches[$i] eq $should_match[$i]) {
14819 print "ok $Tests - ";
14821 print "In \"$display_string\" =~ /(\\X)/g, \\X #1";
14823 print "And \\X #", $i + 1,
14825 print " correctly matched $should_display[$i]; line $line\n";
14827 $matches[$i] = join("", map { sprintf "\\x{%04X}", $_ }
14828 unpack("U*", $matches[$i]));
14829 print "not ok $Tests - In \"$display_string\" =~ /(\\X)/g, \\X #",
14831 " should have matched $should_display[$i]",
14832 " but instead matched $matches[$i]",
14833 ". Abandoning rest of line $line\n";
14838 # And the number of matches should equal the number of expected matches.
14840 if (@matches == @should_match) {
14841 print "ok $Tests - Nothing was left over; line $line\n";
14843 print "not ok $Tests - There were ", scalar @should_match, " \\X matches expected, but got ", scalar @matches, " instead; line $line\n";
14851 print "1..$Tests\n";
14852 exit($Fails ? -1 : 0);
14855 Error('\p{Script=InGreek}'); # Bug #69018
14856 Test_X("1100 $nobreak 1161"); # Bug #70940
14857 Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
14858 Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
14859 Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726