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
35 sub DEBUG () { 0 } # Set to 0 for production; 1 for development
36 my $debugging_build = $Config{"ccflags"} =~ /-DDEBUGGING/;
38 ##########################################################################
40 # mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl),
41 # from the Unicode database files (lib/unicore/.../*.txt), It also generates
42 # a pod file and a .t file
44 # The structure of this file is:
45 # First these introductory comments; then
46 # code needed for everywhere, such as debugging stuff; then
47 # code to handle input parameters; then
48 # data structures likely to be of external interest (some of which depend on
49 # the input parameters, so follows them; then
50 # more data structures and subroutine and package (class) definitions; then
51 # the small actual loop to process the input files and finish up; then
52 # a __DATA__ section, for the .t tests
54 # This program works on all releases of Unicode through at least 6.0. The
55 # outputs have been scrutinized most intently for release 5.1. The others
56 # have been checked for somewhat more than just sanity. It can handle all
57 # existing Unicode character properties in those releases.
59 # This program is mostly about Unicode character (or code point) properties.
60 # A property describes some attribute or quality of a code point, like if it
61 # is lowercase or not, its name, what version of Unicode it was first defined
62 # in, or what its uppercase equivalent is. Unicode deals with these disparate
63 # possibilities by making all properties into mappings from each code point
64 # into some corresponding value. In the case of it being lowercase or not,
65 # the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each
66 # property maps each Unicode code point to a single value, called a "property
67 # value". (Hence each Unicode property is a true mathematical function with
68 # exactly one value per code point.)
70 # When using a property in a regular expression, what is desired isn't the
71 # mapping of the code point to its property's value, but the reverse (or the
72 # mathematical "inverse relation"): starting with the property value, "Does a
73 # code point map to it?" These are written in a "compound" form:
74 # \p{property=value}, e.g., \p{category=punctuation}. This program generates
75 # files containing the lists of code points that map to each such regular
76 # expression property value, one file per list
78 # There is also a single form shortcut that Perl adds for many of the commonly
79 # used properties. This happens for all binary properties, plus script,
80 # general_category, and block properties.
82 # Thus the outputs of this program are files. There are map files, mostly in
83 # the 'To' directory; and there are list files for use in regular expression
84 # matching, all in subdirectories of the 'lib' directory, with each
85 # subdirectory being named for the property that the lists in it are for.
86 # Bookkeeping, test, and documentation files are also generated.
88 my $matches_directory = 'lib'; # Where match (\p{}) files go.
89 my $map_directory = 'To'; # Where map files go.
93 # The major data structures of this program are Property, of course, but also
94 # Table. There are two kinds of tables, very similar to each other.
95 # "Match_Table" is the data structure giving the list of code points that have
96 # a particular property value, mentioned above. There is also a "Map_Table"
97 # data structure which gives the property's mapping from code point to value.
98 # There are two structures because the match tables need to be combined in
99 # various ways, such as constructing unions, intersections, complements, etc.,
100 # and the map ones don't. And there would be problems, perhaps subtle, if
101 # a map table were inadvertently operated on in some of those ways.
102 # The use of separate classes with operations defined on one but not the other
103 # prevents accidentally confusing the two.
105 # At the heart of each table's data structure is a "Range_List", which is just
106 # an ordered list of "Ranges", plus ancillary information, and methods to
107 # operate on them. A Range is a compact way to store property information.
108 # Each range has a starting code point, an ending code point, and a value that
109 # is meant to apply to all the code points between the two end points,
110 # inclusive. For a map table, this value is the property value for those
111 # code points. Two such ranges could be written like this:
112 # 0x41 .. 0x5A, 'Upper',
113 # 0x61 .. 0x7A, 'Lower'
115 # Each range also has a type used as a convenience to classify the values.
116 # Most ranges in this program will be Type 0, or normal, but there are some
117 # ranges that have a non-zero type. These are used only in map tables, and
118 # are for mappings that don't fit into the normal scheme of things. Mappings
119 # that require a hash entry to communicate with utf8.c are one example;
120 # another example is mappings for charnames.pm to use which indicate a name
121 # that is algorithmically determinable from its code point (and vice-versa).
122 # These are used to significantly compact these tables, instead of listing
123 # each one of the tens of thousands individually.
125 # In a match table, the value of a range is irrelevant (and hence the type as
126 # well, which will always be 0), and arbitrarily set to the null string.
127 # Using the example above, there would be two match tables for those two
128 # entries, one named Upper would contain the 0x41..0x5A range, and the other
129 # named Lower would contain 0x61..0x7A.
131 # Actually, there are two types of range lists, "Range_Map" is the one
132 # associated with map tables, and "Range_List" with match tables.
133 # Again, this is so that methods can be defined on one and not the other so as
134 # to prevent operating on them in incorrect ways.
136 # Eventually, most tables are written out to files to be read by utf8_heavy.pl
137 # in the perl core. All tables could in theory be written, but some are
138 # suppressed because there is no current practical use for them. It is easy
139 # to change which get written by changing various lists that are near the top
140 # of the actual code in this file. The table data structures contain enough
141 # ancillary information to allow them to be treated as separate entities for
142 # writing, such as the path to each one's file. There is a heading in each
143 # map table that gives the format of its entries, and what the map is for all
144 # the code points missing from it. (This allows tables to be more compact.)
146 # The Property data structure contains one or more tables. All properties
147 # contain a map table (except the $perl property which is a
148 # pseudo-property containing only match tables), and any properties that
149 # are usable in regular expression matches also contain various matching
150 # tables, one for each value the property can have. A binary property can
151 # have two values, True and False (or Y and N, which are preferred by Unicode
152 # terminology). Thus each of these properties will have a map table that
153 # takes every code point and maps it to Y or N (but having ranges cuts the
154 # number of entries in that table way down), and two match tables, one
155 # which has a list of all the code points that map to Y, and one for all the
156 # code points that map to N. (For each of these, a third table is also
157 # generated for the pseudo Perl property. It contains the identical code
158 # points as the Y table, but can be written, not in the compound form, but in
159 # a "single" form like \p{IsUppercase}.) Many properties are binary, but some
160 # properties have several possible values, some have many, and properties like
161 # Name have a different value for every named code point. Those will not,
162 # unless the controlling lists are changed, have their match tables written
163 # out. But all the ones which can be used in regular expression \p{} and \P{}
164 # constructs will. Prior to 5.14, generally a property would have either its
165 # map table or its match tables written but not both. Again, what gets
166 # written is controlled by lists which can easily be changed. Starting in
167 # 5.14, advantage was taken of this, and all the map tables needed to
168 # reconstruct the Unicode db are now written out, while suppressing the
169 # Unicode .txt files that contain the data. Our tables are much more compact
170 # than the .txt files, so a significant space savings was achieved.
172 # Properties have a 'Type', like binary, or string, or enum depending on how
173 # many match tables there are and the content of the maps. This 'Type' is
174 # different than a range 'Type', so don't get confused by the two concepts
175 # having the same name.
177 # For information about the Unicode properties, see Unicode's UAX44 document:
179 my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/';
181 # As stated earlier, this program will work on any release of Unicode so far.
182 # Most obvious problems in earlier data have NOT been corrected except when
183 # necessary to make Perl or this program work reasonably. For example, no
184 # folding information was given in early releases, so this program substitutes
185 # lower case instead, just so that a regular expression with the /i option
186 # will do something that actually gives the right results in many cases.
187 # There are also a couple other corrections for version 1.1.5, commented at
188 # the point they are made. As an example of corrections that weren't made
189 # (but could be) is this statement from DerivedAge.txt: "The supplementary
190 # private use code points and the non-character code points were assigned in
191 # version 2.0, but not specifically listed in the UCD until versions 3.0 and
192 # 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0) More information
193 # on Unicode version glitches is further down in these introductory comments.
195 # This program works on all non-provisional properties as of 6.0, though the
196 # files for some are suppressed from apparent lack of demand for them. You
197 # can change which are output by changing lists in this program.
199 # The old version of mktables emphasized the term "Fuzzy" to mean Unicode's
200 # loose matchings rules (from Unicode TR18):
202 # The recommended names for UCD properties and property values are in
203 # PropertyAliases.txt [Prop] and PropertyValueAliases.txt
204 # [PropValue]. There are both abbreviated names and longer, more
205 # descriptive names. It is strongly recommended that both names be
206 # recognized, and that loose matching of property names be used,
207 # whereby the case distinctions, whitespace, hyphens, and underbar
209 # The program still allows Fuzzy to override its determination of if loose
210 # matching should be used, but it isn't currently used, as it is no longer
211 # needed; the calculations it makes are good enough.
213 # SUMMARY OF HOW IT WORKS:
217 # A list is constructed containing each input file that is to be processed
219 # Each file on the list is processed in a loop, using the associated handler
221 # The PropertyAliases.txt and PropValueAliases.txt files are processed
222 # first. These files name the properties and property values.
223 # Objects are created of all the property and property value names
224 # that the rest of the input should expect, including all synonyms.
225 # The other input files give mappings from properties to property
226 # values. That is, they list code points and say what the mapping
227 # is under the given property. Some files give the mappings for
228 # just one property; and some for many. This program goes through
229 # each file and populates the properties from them. Some properties
230 # are listed in more than one file, and Unicode has set up a
231 # precedence as to which has priority if there is a conflict. Thus
232 # the order of processing matters, and this program handles the
233 # conflict possibility by processing the overriding input files
234 # last, so that if necessary they replace earlier values.
235 # After this is all done, the program creates the property mappings not
236 # furnished by Unicode, but derivable from what it does give.
237 # The tables of code points that match each property value in each
238 # property that is accessible by regular expressions are created.
239 # The Perl-defined properties are created and populated. Many of these
240 # require data determined from the earlier steps
241 # Any Perl-defined synonyms are created, and name clashes between Perl
242 # and Unicode are reconciled and warned about.
243 # All the properties are written to files
244 # Any other files are written, and final warnings issued.
246 # For clarity, a number of operators have been overloaded to work on tables:
247 # ~ means invert (take all characters not in the set). The more
248 # conventional '!' is not used because of the possibility of confusing
249 # it with the actual boolean operation.
251 # - means subtraction
252 # & means intersection
253 # The precedence of these is the order listed. Parentheses should be
254 # copiously used. These are not a general scheme. The operations aren't
255 # defined for a number of things, deliberately, to avoid getting into trouble.
256 # Operations are done on references and affect the underlying structures, so
257 # that the copy constructors for them have been overloaded to not return a new
258 # clone, but the input object itself.
260 # The bool operator is deliberately not overloaded to avoid confusion with
261 # "should it mean if the object merely exists, or also is non-empty?".
263 # WHY CERTAIN DESIGN DECISIONS WERE MADE
265 # This program needs to be able to run under miniperl. Therefore, it uses a
266 # minimum of other modules, and hence implements some things itself that could
267 # be gotten from CPAN
269 # This program uses inputs published by the Unicode Consortium. These can
270 # change incompatibly between releases without the Perl maintainers realizing
271 # it. Therefore this program is now designed to try to flag these. It looks
272 # at the directories where the inputs are, and flags any unrecognized files.
273 # It keeps track of all the properties in the files it handles, and flags any
274 # that it doesn't know how to handle. It also flags any input lines that
275 # don't match the expected syntax, among other checks.
277 # It is also designed so if a new input file matches one of the known
278 # templates, one hopefully just needs to add it to a list to have it
281 # As mentioned earlier, some properties are given in more than one file. In
282 # particular, the files in the extracted directory are supposedly just
283 # reformattings of the others. But they contain information not easily
284 # derivable from the other files, including results for Unihan, which this
285 # program doesn't ordinarily look at, and for unassigned code points. They
286 # also have historically had errors or been incomplete. In an attempt to
287 # create the best possible data, this program thus processes them first to
288 # glean information missing from the other files; then processes those other
289 # files to override any errors in the extracted ones. Much of the design was
290 # driven by this need to store things and then possibly override them.
292 # It tries to keep fatal errors to a minimum, to generate something usable for
293 # testing purposes. It always looks for files that could be inputs, and will
294 # warn about any that it doesn't know how to handle (the -q option suppresses
297 # Why is there more than one type of range?
298 # This simplified things. There are some very specialized code points that
299 # have to be handled specially for output, such as Hangul syllable names.
300 # By creating a range type (done late in the development process), it
301 # allowed this to be stored with the range, and overridden by other input.
302 # Originally these were stored in another data structure, and it became a
303 # mess trying to decide if a second file that was for the same property was
304 # overriding the earlier one or not.
306 # Why are there two kinds of tables, match and map?
307 # (And there is a base class shared by the two as well.) As stated above,
308 # they actually are for different things. Development proceeded much more
309 # smoothly when I (khw) realized the distinction. Map tables are used to
310 # give the property value for every code point (actually every code point
311 # that doesn't map to a default value). Match tables are used for regular
312 # expression matches, and are essentially the inverse mapping. Separating
313 # the two allows more specialized methods, and error checks so that one
314 # can't just take the intersection of two map tables, for example, as that
319 # This program is written so it will run under miniperl. Occasionally changes
320 # will cause an error where the backtrace doesn't work well under miniperl.
321 # To diagnose the problem, you can instead run it under regular perl, if you
324 # There is a good trace facility. To enable it, first sub DEBUG must be set
325 # to return true. Then a line like
327 # local $to_trace = 1 if main::DEBUG;
329 # can be added to enable tracing in its lexical scope or until you insert
332 # local $to_trace = 0 if main::DEBUG;
334 # then use a line like "trace $a, @b, %c, ...;
336 # Some of the more complex subroutines already have trace statements in them.
337 # Permanent trace statements should be like:
339 # trace ... if main::DEBUG && $to_trace;
341 # If there is just one or a few files that you're debugging, you can easily
342 # cause most everything else to be skipped. Change the line
344 # my $debug_skip = 0;
346 # to 1, and every file whose object is in @input_file_objects and doesn't have
347 # a, 'non_skip => 1,' in its constructor will be skipped.
349 # To compare the output tables, it may be useful to specify the -annotate
350 # flag. This causes the tables to expand so there is one entry for each
351 # non-algorithmically named code point giving, currently its name, and its
352 # graphic representation if printable (and you have a font that knows about
353 # it). This makes it easier to see what the particular code points are in
354 # each output table. The tables are usable, but because they don't have
355 # ranges (for the most part), a Perl using them will run slower. Non-named
356 # code points are annotated with a description of their status, and contiguous
357 # ones with the same description will be output as a range rather than
358 # individually. Algorithmically named characters are also output as ranges,
359 # except when there are just a few contiguous ones.
363 # The program would break if Unicode were to change its names so that
364 # interior white space, underscores, or dashes differences were significant
365 # within property and property value names.
367 # It might be easier to use the xml versions of the UCD if this program ever
368 # would need heavy revision, and the ability to handle old versions was not
371 # There is the potential for name collisions, in that Perl has chosen names
372 # that Unicode could decide it also likes. There have been such collisions in
373 # the past, with mostly Perl deciding to adopt the Unicode definition of the
374 # name. However in the 5.2 Unicode beta testing, there were a number of such
375 # collisions, which were withdrawn before the final release, because of Perl's
376 # and other's protests. These all involved new properties which began with
377 # 'Is'. Based on the protests, Unicode is unlikely to try that again. Also,
378 # many of the Perl-defined synonyms, like Any, Word, etc, are listed in a
379 # Unicode document, so they are unlikely to be used by Unicode for another
380 # purpose. However, they might try something beginning with 'In', or use any
381 # of the other Perl-defined properties. This program will warn you of name
382 # collisions, and refuse to generate tables with them, but manual intervention
383 # will be required in this event. One scheme that could be implemented, if
384 # necessary, would be to have this program generate another file, or add a
385 # field to mktables.lst that gives the date of first definition of a property.
386 # Each new release of Unicode would use that file as a basis for the next
387 # iteration. And the Perl synonym addition code could sort based on the age
388 # of the property, so older properties get priority, and newer ones that clash
389 # would be refused; hence existing code would not be impacted, and some other
390 # synonym would have to be used for the new property. This is ugly, and
391 # manual intervention would certainly be easier to do in the short run; lets
392 # hope it never comes to this.
396 # This program can generate tables from the Unihan database. But it doesn't
397 # by default, letting the CPAN module Unicode::Unihan handle them. Prior to
398 # version 5.2, this database was in a single file, Unihan.txt. In 5.2 the
399 # database was split into 8 different files, all beginning with the letters
400 # 'Unihan'. This program will read those file(s) if present, but it needs to
401 # know which of the many properties in the file(s) should have tables created
402 # for them. It will create tables for any properties listed in
403 # PropertyAliases.txt and PropValueAliases.txt, plus any listed in the
404 # @cjk_properties array and the @cjk_property_values array. Thus, if a
405 # property you want is not in those files of the release you are building
406 # against, you must add it to those two arrays. Starting in 4.0, the
407 # Unicode_Radical_Stroke was listed in those files, so if the Unihan database
408 # is present in the directory, a table will be generated for that property.
409 # In 5.2, several more properties were added. For your convenience, the two
410 # arrays are initialized with all the 6.0 listed properties that are also in
411 # earlier releases. But these are commented out. You can just uncomment the
412 # ones you want, or use them as a template for adding entries for other
415 # You may need to adjust the entries to suit your purposes. setup_unihan(),
416 # and filter_unihan_line() are the functions where this is done. This program
417 # already does some adjusting to make the lines look more like the rest of the
418 # Unicode DB; You can see what that is in filter_unihan_line()
420 # There is a bug in the 3.2 data file in which some values for the
421 # kPrimaryNumeric property have commas and an unexpected comment. A filter
422 # could be added for these; or for a particular installation, the Unihan.txt
423 # file could be edited to fix them.
425 # HOW TO ADD A FILE TO BE PROCESSED
427 # A new file from Unicode needs to have an object constructed for it in
428 # @input_file_objects, probably at the end or at the end of the extracted
429 # ones. The program should warn you if its name will clash with others on
430 # restrictive file systems, like DOS. If so, figure out a better name, and
431 # add lines to the README.perl file giving that. If the file is a character
432 # property, it should be in the format that Unicode has by default
433 # standardized for such files for the more recently introduced ones.
434 # If so, the Input_file constructor for @input_file_objects can just be the
435 # file name and release it first appeared in. If not, then it should be
436 # possible to construct an each_line_handler() to massage the line into the
439 # For non-character properties, more code will be needed. You can look at
440 # the existing entries for clues.
442 # UNICODE VERSIONS NOTES
444 # The Unicode UCD has had a number of errors in it over the versions. And
445 # these remain, by policy, in the standard for that version. Therefore it is
446 # risky to correct them, because code may be expecting the error. So this
447 # program doesn't generally make changes, unless the error breaks the Perl
448 # core. As an example, some versions of 2.1.x Jamo.txt have the wrong value
449 # for U+1105, which causes real problems for the algorithms for Jamo
450 # calculations, so it is changed here.
452 # But it isn't so clear cut as to what to do about concepts that are
453 # introduced in a later release; should they extend back to earlier releases
454 # where the concept just didn't exist? It was easier to do this than to not,
455 # so that's what was done. For example, the default value for code points not
456 # in the files for various properties was probably undefined until changed by
457 # some version. No_Block for blocks is such an example. This program will
458 # assign No_Block even in Unicode versions that didn't have it. This has the
459 # benefit that code being written doesn't have to special case earlier
460 # versions; and the detriment that it doesn't match the Standard precisely for
461 # the affected versions.
463 # Here are some observations about some of the issues in early versions:
465 # The number of code points in \p{alpha} halved in 2.1.9. It turns out that
466 # the reason is that the CJK block starting at 4E00 was removed from PropList,
467 # and was not put back in until 3.1.0
469 # Unicode introduced the synonym Space for White_Space in 4.1. Perl has
470 # always had a \p{Space}. In release 3.2 only, they are not synonymous. The
471 # reason is that 3.2 introduced U+205F=medium math space, which was not
472 # classed as white space, but Perl figured out that it should have been. 4.0
473 # reclassified it correctly.
475 # Another change between 3.2 and 4.0 is the CCC property value ATBL. In 3.2
476 # this was erroneously a synonym for 202. In 4.0, ATB became 202, and ATBL
477 # was left with no code points, as all the ones that mapped to 202 stayed
478 # mapped to 202. Thus if your program used the numeric name for the class,
479 # it would not have been affected, but if it used the mnemonic, it would have
482 # \p{Script=Hrkt} (Katakana_Or_Hiragana) came in 4.0.1. Before that code
483 # points which eventually came to have this script property value, instead
484 # mapped to "Unknown". But in the next release all these code points were
485 # moved to \p{sc=common} instead.
487 # The default for missing code points for BidiClass is complicated. Starting
488 # in 3.1.1, the derived file DBidiClass.txt handles this, but this program
489 # tries to do the best it can for earlier releases. It is done in
490 # process_PropertyAliases()
492 ##############################################################################
494 my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing
496 my $MAX_LINE_WIDTH = 78;
498 # Debugging aid to skip most files so as to not be distracted by them when
499 # concentrating on the ones being debugged. Add
501 # to the constructor for those files you want processed when you set this.
502 # Files with a first version number of 0 are special: they are always
503 # processed regardless of the state of this flag. Generally, Jamo.txt and
504 # UnicodeData.txt must not be skipped if you want this program to not die
505 # before normal completion.
508 # Set to 1 to enable tracing.
511 { # Closure for trace: debugging aid
512 my $print_caller = 1; # ? Include calling subroutine name
513 my $main_with_colon = 'main::';
514 my $main_colon_length = length($main_with_colon);
517 return unless $to_trace; # Do nothing if global flag not set
521 local $DB::trace = 0;
522 $DB::trace = 0; # Quiet 'used only once' message
526 # Loop looking up the stack to get the first non-trace caller
531 $line_number = $caller_line;
532 (my $pkg, my $file, $caller_line, my $caller) = caller $i++;
533 $caller = $main_with_colon unless defined $caller;
535 $caller_name = $caller;
538 $caller_name =~ s/.*:://;
539 if (substr($caller_name, 0, $main_colon_length)
542 $caller_name = substr($caller_name, $main_colon_length);
545 } until ($caller_name ne 'trace');
547 # If the stack was empty, we were called from the top level
548 $caller_name = 'main' if ($caller_name eq ""
549 || $caller_name eq 'trace');
552 foreach my $string (@input) {
553 #print STDERR __LINE__, ": ", join ", ", @input, "\n";
554 if (ref $string eq 'ARRAY' || ref $string eq 'HASH') {
555 $output .= simple_dumper($string);
558 $string = "$string" if ref $string;
559 $string = $UNDEF unless defined $string;
561 $string = '""' if $string eq "";
562 $output .= " " if $output ne ""
564 && substr($output, -1, 1) ne " "
565 && substr($string, 0, 1) ne " ";
570 print STDERR sprintf "%4d: ", $line_number if defined $line_number;
571 print STDERR "$caller_name: " if $print_caller;
572 print STDERR $output, "\n";
577 # This is for a rarely used development feature that allows you to compare two
578 # versions of the Unicode standard without having to deal with changes caused
579 # by the code points introduced in the later version. Change the 0 to a
580 # string containing a SINGLE dotted Unicode release number (e.g. "2.1"). Only
581 # code points introduced in that release and earlier will be used; later ones
582 # are thrown away. You use the version number of the earliest one you want to
583 # compare; then run this program on directory structures containing each
584 # release, and compare the outputs. These outputs will therefore include only
585 # the code points common to both releases, and you can see the changes caused
586 # just by the underlying release semantic changes. For versions earlier than
587 # 3.2, you must copy a version of DAge.txt into the directory.
588 my $string_compare_versions = DEBUG && 0; # e.g., "2.1";
589 my $compare_versions = DEBUG
590 && $string_compare_versions
591 && pack "C*", split /\./, $string_compare_versions;
594 # Returns non-duplicated input values. From "Perl Best Practices:
595 # Encapsulated Cleverness". p. 455 in first edition.
598 # Arguably this breaks encapsulation, if the goal is to permit multiple
599 # distinct objects to stringify to the same value, and be interchangeable.
600 # However, for this program, no two objects stringify identically, and all
601 # lists passed to this function are either objects or strings. So this
602 # doesn't affect correctness, but it does give a couple of percent speedup.
604 return grep { ! $seen{$_}++ } @_;
607 $0 = File::Spec->canonpath($0);
609 my $make_test_script = 0; # ? Should we output a test script
610 my $write_unchanged_files = 0; # ? Should we update the output files even if
611 # we don't think they have changed
612 my $use_directory = ""; # ? Should we chdir somewhere.
613 my $pod_directory; # input directory to store the pod file.
614 my $pod_file = 'perluniprops';
615 my $t_path; # Path to the .t test file
616 my $file_list = 'mktables.lst'; # File to store input and output file names.
617 # This is used to speed up the build, by not
618 # executing the main body of the program if
619 # nothing on the list has changed since the
621 my $make_list = 1; # ? Should we write $file_list. Set to always
622 # make a list so that when the pumpking is
623 # preparing a release, s/he won't have to do
625 my $glob_list = 0; # ? Should we try to include unknown .txt files
627 my $output_range_counts = $debugging_build; # ? Should we include the number
628 # of code points in ranges in
630 my $annotate = 0; # ? Should character names be in the output
632 # Verbosity levels; 0 is quiet
633 my $NORMAL_VERBOSITY = 1;
637 my $verbosity = $NORMAL_VERBOSITY;
641 my $arg = shift @ARGV;
643 $verbosity = $VERBOSE;
645 elsif ($arg eq '-p') {
646 $verbosity = $PROGRESS;
647 $| = 1; # Flush buffers as we go.
649 elsif ($arg eq '-q') {
652 elsif ($arg eq '-w') {
653 $write_unchanged_files = 1; # update the files even if havent changed
655 elsif ($arg eq '-check') {
656 my $this = shift @ARGV;
657 my $ok = shift @ARGV;
659 print "Skipping as check params are not the same.\n";
663 elsif ($arg eq '-P' && defined ($pod_directory = shift)) {
664 -d $pod_directory or croak "Directory '$pod_directory' doesn't exist";
666 elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift)))
668 $make_test_script = 1;
670 elsif ($arg eq '-makelist') {
673 elsif ($arg eq '-C' && defined ($use_directory = shift)) {
674 -d $use_directory or croak "Unknown directory '$use_directory'";
676 elsif ($arg eq '-L') {
678 # Existence not tested until have chdir'd
681 elsif ($arg eq '-globlist') {
684 elsif ($arg eq '-c') {
685 $output_range_counts = ! $output_range_counts
687 elsif ($arg eq '-annotate') {
689 $debugging_build = 1;
690 $output_range_counts = 1;
694 $with_c .= 'out' if $output_range_counts; # Complements the state
696 usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ]
697 [ -T test_file_path ] [-globlist] [-makelist] [-maketest]
699 -c : Output comments $with_c number of code points in ranges
700 -q : Quiet Mode: Only output serious warnings.
701 -p : Set verbosity level to normal plus show progress.
702 -v : Set Verbosity level high: Show progress and non-serious
704 -w : Write files regardless
705 -C dir : Change to this directory before proceeding. All relative paths
706 except those specified by the -P and -T options will be done
707 with respect to this directory.
708 -P dir : Output $pod_file file to directory 'dir'.
709 -T path : Create a test script as 'path'; overrides -maketest
710 -L filelist : Use alternate 'filelist' instead of standard one
711 -globlist : Take as input all non-Test *.txt files in current and sub
713 -maketest : Make test script 'TestProp.pl' in current (or -C directory),
715 -makelist : Rewrite the file list $file_list based on current setup
716 -annotate : Output an annotation for each character in the table files;
717 useful for debugging mktables, looking at diffs; but is slow,
718 memory intensive; resulting tables are usable but slow and
720 -check A B : Executes $0 only if A and B are the same
725 # Stores the most-recently changed file. If none have changed, can skip the
727 my $most_recent = (stat $0)[9]; # Do this before the chdir!
729 # Change directories now, because need to read 'version' early.
730 if ($use_directory) {
731 if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) {
732 $pod_directory = File::Spec->rel2abs($pod_directory);
734 if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) {
735 $t_path = File::Spec->rel2abs($t_path);
737 chdir $use_directory or croak "Failed to chdir to '$use_directory':$!";
738 if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) {
739 $pod_directory = File::Spec->abs2rel($pod_directory);
741 if ($t_path && File::Spec->file_name_is_absolute($t_path)) {
742 $t_path = File::Spec->abs2rel($t_path);
746 # Get Unicode version into regular and v-string. This is done now because
747 # various tables below get populated based on it. These tables are populated
748 # here to be near the top of the file, and so easily seeable by those needing
750 open my $VERSION, "<", "version"
751 or croak "$0: can't open required file 'version': $!\n";
752 my $string_version = <$VERSION>;
754 chomp $string_version;
755 my $v_version = pack "C*", split /\./, $string_version; # v string
757 # The following are the complete names of properties with property values that
758 # are known to not match any code points in some versions of Unicode, but that
759 # may change in the future so they should be matchable, hence an empty file is
760 # generated for them.
761 my @tables_that_may_be_empty = (
762 'Joining_Type=Left_Joining',
764 push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1;
765 push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0;
766 push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana'
767 if $v_version ge v4.1.0;
768 push @tables_that_may_be_empty, 'Script_Extensions=Katakana_Or_Hiragana'
769 if $v_version ge v6.0.0;
771 # The lists below are hashes, so the key is the item in the list, and the
772 # value is the reason why it is in the list. This makes generation of
773 # documentation easier.
775 my %why_suppressed; # No file generated for these.
777 # Files aren't generated for empty extraneous properties. This is arguable.
778 # Extraneous properties generally come about because a property is no longer
779 # used in a newer version of Unicode. If we generated a file without code
780 # points, programs that used to work on that property will still execute
781 # without errors. It just won't ever match (or will always match, with \P{}).
782 # This means that the logic is now likely wrong. I (khw) think its better to
783 # find this out by getting an error message. Just move them to the table
784 # above to change this behavior
785 my %why_suppress_if_empty_warn_if_not = (
787 # It is the only property that has ever officially been removed from the
788 # Standard. The database never contained any code points for it.
789 'Special_Case_Condition' => 'Obsolete',
791 # Apparently never official, but there were code points in some versions of
792 # old-style PropList.txt
793 'Non_Break' => 'Obsolete',
796 # These would normally go in the warn table just above, but they were changed
797 # a long time before this program was written, so warnings about them are
799 if ($v_version gt v3.2.0) {
800 push @tables_that_may_be_empty,
801 'Canonical_Combining_Class=Attached_Below_Left'
804 # These are listed in the Property aliases file in 6.0, but Unihan is ignored
805 # unless explicitly added.
806 if ($v_version ge v5.2.0) {
807 my $unihan = 'Unihan; remove from list if using Unihan';
808 foreach my $table (qw (
812 kCompatibilityVariant
826 $why_suppress_if_empty_warn_if_not{$table} = $unihan;
830 # Enum values for to_output_map() method in the Map_Table package.
831 my $EXTERNAL_MAP = 1;
832 my $INTERNAL_MAP = 2;
834 # To override computed values for writing the map tables for these properties.
835 # The default for enum map tables is to write them out, so that the Unicode
836 # .txt files can be removed, but all the data to compute any property value
837 # for any code point is available in a more compact form.
838 my %global_to_output_map = (
839 # Needed by UCD.pm, but don't want to publicize that it exists, so won't
840 # get stuck supporting it if things change. Since it is a STRING
841 # property, it normally would be listed in the pod, but INTERNAL_MAP
843 Unicode_1_Name => $INTERNAL_MAP,
845 Present_In => 0, # Suppress, as easily computed from Age
846 Block => 0, # Suppress, as Blocks.txt is retained.
848 # Suppress, as mapping can be found instead from the
849 # Perl_Decomposition_Mapping file
850 Decomposition_Type => 0,
853 # Properties that this program ignores.
854 my @unimplemented_properties = (
855 'Unicode_Radical_Stroke' # Remove if changing to handle this one.
858 # There are several types of obsolete properties defined by Unicode. These
859 # must be hand-edited for every new Unicode release.
860 my %why_deprecated; # Generates a deprecated warning message if used.
861 my %why_stabilized; # Documentation only
862 my %why_obsolete; # Documentation only
865 my $simple = 'Perl uses the more complete version of this property';
866 my $unihan = 'Unihan properties are by default not enabled in the Perl core. Instead use CPAN: Unicode::Unihan';
868 my $other_properties = 'other properties';
869 my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone";
870 my $why_no_expand = "Deprecated by Unicode. These are characters that expand to more than one character in the specified normalization form, but whether they actually take up more bytes or not depends on the encoding being used. For example, a UTF-8 encoded character may expand to a different number of bytes than a UTF-32 encoded character.";
873 'Grapheme_Link' => 'Deprecated by Unicode: Duplicates ccc=vr (Canonical_Combining_Class=Virama)',
874 'Jamo_Short_Name' => $contributory,
875 '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',
876 'Other_Alphabetic' => $contributory,
877 'Other_Default_Ignorable_Code_Point' => $contributory,
878 'Other_Grapheme_Extend' => $contributory,
879 'Other_ID_Continue' => $contributory,
880 'Other_ID_Start' => $contributory,
881 'Other_Lowercase' => $contributory,
882 'Other_Math' => $contributory,
883 'Other_Uppercase' => $contributory,
884 'Expands_On_NFC' => $why_no_expand,
885 'Expands_On_NFD' => $why_no_expand,
886 'Expands_On_NFKC' => $why_no_expand,
887 'Expands_On_NFKD' => $why_no_expand,
891 # There is a lib/unicore/Decomposition.pl (used by Normalize.pm) which
892 # contains the same information, but without the algorithmically
893 # determinable Hangul syllables'. This file is not published, so it's
894 # existence is not noted in the comment.
895 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize',
897 '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',
899 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold",
900 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
901 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
902 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo",
904 'Name' => "Accessible via 'use charnames;'",
905 'Name_Alias' => "Accessible via 'use charnames;'",
907 FC_NFKC_Closure => 'Supplanted in usage by NFKC_Casefold; otherwise not useful',
910 # The following are suppressed because they were made contributory or
911 # deprecated by Unicode before Perl ever thought about supporting them.
912 foreach my $property ('Jamo_Short_Name',
919 $why_suppressed{$property} = $why_deprecated{$property};
922 # Customize the message for all the 'Other_' properties
923 foreach my $property (keys %why_deprecated) {
924 next if (my $main_property = $property) !~ s/^Other_//;
925 $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/;
929 if ($v_version ge 4.0.0) {
930 $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14';
931 if ($v_version ge 6.0.0) {
932 $why_deprecated{'Hyphen'} = 'Supplanted by Line_Break property values; see www.unicode.org/reports/tr14';
935 if ($v_version ge 5.2.0 && $v_version lt 6.0.0) {
936 $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed';
937 if ($v_version ge 6.0.0) {
938 $why_deprecated{'ISO_Comment'} = 'No longer needed for Unicode\'s internal chart generation; otherwise not useful, and code points for it have been removed';
942 # Probably obsolete forever
943 if ($v_version ge v4.1.0) {
944 $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common".';
946 if ($v_version ge v6.0.0) {
947 $why_suppressed{'Script=Katakana_Or_Hiragana'} .= ' Consider instead using "Script_Extensions=Katakana" or "Script_Extensions=Hiragana (or both)"';
948 $why_suppressed{'Script_Extensions=Katakana_Or_Hiragana'} = 'All code points that would be matched by this are matched by either "Script_Extensions=Katakana" or "Script_Extensions=Hiragana"';
951 # This program can create files for enumerated-like properties, such as
952 # 'Numeric_Type'. This file would be the same format as for a string
953 # property, with a mapping from code point to its value, so you could look up,
954 # for example, the script a code point is in. But no one so far wants this
955 # mapping, or they have found another way to get it since this is a new
956 # feature. So no file is generated except if it is in this list.
957 my @output_mapped_properties = split "\n", <<END;
960 # If you are using the Unihan database in a Unicode version before 5.2, you
961 # need to add the properties that you want to extract from it to this table.
962 # For your convenience, the properties in the 6.0 PropertyAliases.txt file are
963 # listed, commented out
964 my @cjk_properties = split "\n", <<'END';
965 #cjkAccountingNumeric; kAccountingNumeric
966 #cjkOtherNumeric; kOtherNumeric
967 #cjkPrimaryNumeric; kPrimaryNumeric
968 #cjkCompatibilityVariant; kCompatibilityVariant
970 #cjkIRG_GSource; kIRG_GSource
971 #cjkIRG_HSource; kIRG_HSource
972 #cjkIRG_JSource; kIRG_JSource
973 #cjkIRG_KPSource; kIRG_KPSource
974 #cjkIRG_KSource; kIRG_KSource
975 #cjkIRG_TSource; kIRG_TSource
976 #cjkIRG_USource; kIRG_USource
977 #cjkIRG_VSource; kIRG_VSource
978 #cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS
981 # Similarly for the property values. For your convenience, the lines in the
982 # 6.0 PropertyAliases.txt file are listed. Just remove the first BUT NOT both
983 # '#' marks (for Unicode versions before 5.2)
984 my @cjk_property_values = split "\n", <<'END';
985 ## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN
986 ## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point>
987 ## @missing: 0000..10FFFF; cjkIICore; <none>
988 ## @missing: 0000..10FFFF; cjkIRG_GSource; <none>
989 ## @missing: 0000..10FFFF; cjkIRG_HSource; <none>
990 ## @missing: 0000..10FFFF; cjkIRG_JSource; <none>
991 ## @missing: 0000..10FFFF; cjkIRG_KPSource; <none>
992 ## @missing: 0000..10FFFF; cjkIRG_KSource; <none>
993 ## @missing: 0000..10FFFF; cjkIRG_TSource; <none>
994 ## @missing: 0000..10FFFF; cjkIRG_USource; <none>
995 ## @missing: 0000..10FFFF; cjkIRG_VSource; <none>
996 ## @missing: 0000..10FFFF; cjkOtherNumeric; NaN
997 ## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN
998 ## @missing: 0000..10FFFF; cjkRSUnicode; <none>
1001 # The input files don't list every code point. Those not listed are to be
1002 # defaulted to some value. Below are hard-coded what those values are for
1003 # non-binary properties as of 5.1. Starting in 5.0, there are
1004 # machine-parsable comment lines in the files the give the defaults; so this
1005 # list shouldn't have to be extended. The claim is that all missing entries
1006 # for binary properties will default to 'N'. Unicode tried to change that in
1007 # 5.2, but the beta period produced enough protest that they backed off.
1009 # The defaults for the fields that appear in UnicodeData.txt in this hash must
1010 # be in the form that it expects. The others may be synonyms.
1011 my $CODE_POINT = '<code point>';
1012 my %default_mapping = (
1013 Age => "Unassigned",
1014 # Bidi_Class => Complicated; set in code
1015 Bidi_Mirroring_Glyph => "",
1016 Block => 'No_Block',
1017 Canonical_Combining_Class => 0,
1018 Case_Folding => $CODE_POINT,
1019 Decomposition_Mapping => $CODE_POINT,
1020 Decomposition_Type => 'None',
1021 East_Asian_Width => "Neutral",
1022 FC_NFKC_Closure => $CODE_POINT,
1023 General_Category => 'Cn',
1024 Grapheme_Cluster_Break => 'Other',
1025 Hangul_Syllable_Type => 'NA',
1027 Jamo_Short_Name => "",
1028 Joining_Group => "No_Joining_Group",
1029 # Joining_Type => Complicated; set in code
1030 kIICore => 'N', # Is converted to binary
1031 #Line_Break => Complicated; set in code
1032 Lowercase_Mapping => $CODE_POINT,
1039 Numeric_Type => 'None',
1040 Numeric_Value => 'NaN',
1041 Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown',
1042 Sentence_Break => 'Other',
1043 Simple_Case_Folding => $CODE_POINT,
1044 Simple_Lowercase_Mapping => $CODE_POINT,
1045 Simple_Titlecase_Mapping => $CODE_POINT,
1046 Simple_Uppercase_Mapping => $CODE_POINT,
1047 Titlecase_Mapping => $CODE_POINT,
1048 Unicode_1_Name => "",
1049 Unicode_Radical_Stroke => "",
1050 Uppercase_Mapping => $CODE_POINT,
1051 Word_Break => 'Other',
1054 # Below are files that Unicode furnishes, but this program ignores, and why
1055 my %ignored_files = (
1056 'CJKRadicals.txt' => 'Unihan data',
1057 'Index.txt' => 'An index, not actual data',
1058 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.',
1059 'NamesList.txt' => 'Just adds commentary',
1060 'NormalizationCorrections.txt' => 'Data is already in other files.',
1061 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases',
1062 'ReadMe.txt' => 'Just comments',
1063 'README.TXT' => 'Just comments',
1064 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped',
1065 'EmojiSources.txt' => 'Not of general utility: for Japanese legacy cell-phone applications',
1066 'IndicMatraCategory.txt' => 'Provisional',
1067 'IndicSyllabicCategory.txt' => 'Provisional',
1070 ### End of externally interesting definitions, except for @input_file_objects
1073 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
1074 # This file is machine-generated by $0 from the Unicode
1075 # database, Version $string_version. Any changes made here will be lost!
1078 my $INTERNAL_ONLY=<<"EOF";
1080 # !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
1081 # This file is for internal use by core Perl only. The format and even the
1082 # name or existence of this file are subject to change without notice. Don't
1086 my $DEVELOPMENT_ONLY=<<"EOF";
1087 # !!!!!!! DEVELOPMENT USE ONLY !!!!!!!
1088 # This file contains information artificially constrained to code points
1089 # present in Unicode release $string_compare_versions.
1090 # IT CANNOT BE RELIED ON. It is for use during development only and should
1091 # not be used for production.
1095 my $MAX_UNICODE_CODEPOINT_STRING = "10FFFF";
1096 my $MAX_UNICODE_CODEPOINT = hex $MAX_UNICODE_CODEPOINT_STRING;
1097 my $MAX_UNICODE_CODEPOINTS = $MAX_UNICODE_CODEPOINT + 1;
1099 # Matches legal code point. 4-6 hex numbers, If there are 6, the first
1100 # two must be 10; if there are 5, the first must not be a 0. Written this way
1101 # to decrease backtracking. The first one allows the code point to be at the
1102 # end of a word, but to work properly, the word shouldn't end with a valid hex
1103 # character. The second one won't match a code point at the end of a word,
1104 # and doesn't have the run-on issue
1105 my $run_on_code_point_re =
1106 qr/ (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
1107 my $code_point_re = qr/\b$run_on_code_point_re/;
1109 # This matches the beginning of the line in the Unicode db files that give the
1110 # defaults for code points not listed (i.e., missing) in the file. The code
1111 # depends on this ending with a semi-colon, so it can assume it is a valid
1112 # field when the line is split() by semi-colons
1113 my $missing_defaults_prefix =
1114 qr/^#\s+\@missing:\s+0000\.\.$MAX_UNICODE_CODEPOINT_STRING\s*;/;
1116 # Property types. Unicode has more types, but these are sufficient for our
1118 my $UNKNOWN = -1; # initialized to illegal value
1119 my $NON_STRING = 1; # Either binary or enum
1121 my $FORCED_BINARY = 3; # Not a binary property, but, besides its normal
1122 # tables, additional true and false tables are
1123 # generated so that false is anything matching the
1124 # default value, and true is everything else.
1125 my $ENUM = 4; # Include catalog
1126 my $STRING = 5; # Anything else: string or misc
1128 # Some input files have lines that give default values for code points not
1129 # contained in the file. Sometimes these should be ignored.
1130 my $NO_DEFAULTS = 0; # Must evaluate to false
1131 my $NOT_IGNORED = 1;
1134 # Range types. Each range has a type. Most ranges are type 0, for normal,
1135 # and will appear in the main body of the tables in the output files, but
1136 # there are other types of ranges as well, listed below, that are specially
1137 # handled. There are pseudo-types as well that will never be stored as a
1138 # type, but will affect the calculation of the type.
1140 # 0 is for normal, non-specials
1141 my $MULTI_CP = 1; # Sequence of more than code point
1142 my $HANGUL_SYLLABLE = 2;
1143 my $CP_IN_NAME = 3; # The NAME contains the code point appended to it.
1144 my $NULL = 4; # The map is to the null string; utf8.c can't
1145 # handle these, nor is there an accepted syntax
1146 # for them in \p{} constructs
1147 my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would
1148 # otherwise be $MULTI_CP type are instead type 0
1150 # process_generic_property_file() can accept certain overrides in its input.
1151 # Each of these must begin AND end with $CMD_DELIM.
1152 my $CMD_DELIM = "\a";
1153 my $REPLACE_CMD = 'replace'; # Override the Replace
1154 my $MAP_TYPE_CMD = 'map_type'; # Override the Type
1159 # Values for the Replace argument to add_range.
1160 # $NO # Don't replace; add only the code points not
1162 my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in
1163 # the comments at the subroutine definition.
1164 my $UNCONDITIONALLY = 2; # Replace without conditions.
1165 my $MULTIPLE = 4; # Don't replace, but add a duplicate record if
1167 my $CROAK = 5; # Die with an error if is already there
1169 # Flags to give property statuses. The phrases are to remind maintainers that
1170 # if the flag is changed, the indefinite article referring to it in the
1171 # documentation may need to be as well.
1173 my $SUPPRESSED = 'z'; # The character should never actually be seen, since
1175 my $PLACEHOLDER = 'P'; # A property that is defined as a placeholder in a
1176 # Unicode version that doesn't have it, but we need it
1177 # to be defined, if empty, to have things work.
1178 # Implies no pod entry generated
1179 my $DEPRECATED = 'D';
1180 my $a_bold_deprecated = "a 'B<$DEPRECATED>'";
1181 my $A_bold_deprecated = "A 'B<$DEPRECATED>'";
1182 my $DISCOURAGED = 'X';
1183 my $a_bold_discouraged = "an 'B<$DISCOURAGED>'";
1184 my $A_bold_discouraged = "An 'B<$DISCOURAGED>'";
1186 my $a_bold_stricter = "a 'B<$STRICTER>'";
1187 my $A_bold_stricter = "A 'B<$STRICTER>'";
1188 my $STABILIZED = 'S';
1189 my $a_bold_stabilized = "an 'B<$STABILIZED>'";
1190 my $A_bold_stabilized = "An 'B<$STABILIZED>'";
1192 my $a_bold_obsolete = "an 'B<$OBSOLETE>'";
1193 my $A_bold_obsolete = "An 'B<$OBSOLETE>'";
1195 my %status_past_participles = (
1196 $DISCOURAGED => 'discouraged',
1197 $SUPPRESSED => 'should never be generated',
1198 $STABILIZED => 'stabilized',
1199 $OBSOLETE => 'obsolete',
1200 $DEPRECATED => 'deprecated',
1203 # The format of the values of the tables:
1204 my $EMPTY_FORMAT = "";
1205 my $BINARY_FORMAT = 'b';
1206 my $DECIMAL_FORMAT = 'd';
1207 my $FLOAT_FORMAT = 'f';
1208 my $INTEGER_FORMAT = 'i';
1209 my $HEX_FORMAT = 'x';
1210 my $RATIONAL_FORMAT = 'r';
1211 my $STRING_FORMAT = 's';
1212 my $DECOMP_STRING_FORMAT = 'c';
1213 my $STRING_WHITE_SPACE_LIST = 'sw';
1215 my %map_table_formats = (
1216 $BINARY_FORMAT => 'binary',
1217 $DECIMAL_FORMAT => 'single decimal digit',
1218 $FLOAT_FORMAT => 'floating point number',
1219 $INTEGER_FORMAT => 'integer',
1220 $HEX_FORMAT => 'non-negative hex whole number; a code point',
1221 $RATIONAL_FORMAT => 'rational: an integer or a fraction',
1222 $STRING_FORMAT => 'string',
1223 $DECOMP_STRING_FORMAT => 'Perl\'s internal (Normalize.pm) decomposition mapping',
1224 $STRING_WHITE_SPACE_LIST => 'string, but some elements are interpreted as a list; white space occurs only as list item separators'
1227 # Unicode didn't put such derived files in a separate directory at first.
1228 my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : "";
1229 my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : "";
1230 my $AUXILIARY = 'auxiliary';
1232 # Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl
1233 my %loose_to_file_of; # loosely maps table names to their respective
1235 my %stricter_to_file_of; # same; but for stricter mapping.
1236 my %nv_floating_to_rational; # maps numeric values floating point numbers to
1237 # their rational equivalent
1238 my %loose_property_name_of; # Loosely maps (non_string) property names to
1241 # Most properties are immune to caseless matching, otherwise you would get
1242 # nonsensical results, as properties are a function of a code point, not
1243 # everything that is caselessly equivalent to that code point. For example,
1244 # Changes_When_Case_Folded('s') should be false, whereas caselessly it would
1245 # be true because 's' and 'S' are equivalent caselessly. However,
1246 # traditionally, [:upper:] and [:lower:] are equivalent caselessly, so we
1247 # extend that concept to those very few properties that are like this. Each
1248 # such property will match the full range caselessly. They are hard-coded in
1249 # the program; it's not worth trying to make it general as it's extremely
1250 # unlikely that they will ever change.
1251 my %caseless_equivalent_to;
1253 # These constants names and values were taken from the Unicode standard,
1254 # version 5.1, section 3.12. They are used in conjunction with Hangul
1255 # syllables. The '_string' versions are so generated tables can retain the
1256 # hex format, which is the more familiar value
1257 my $SBase_string = "0xAC00";
1258 my $SBase = CORE::hex $SBase_string;
1259 my $LBase_string = "0x1100";
1260 my $LBase = CORE::hex $LBase_string;
1261 my $VBase_string = "0x1161";
1262 my $VBase = CORE::hex $VBase_string;
1263 my $TBase_string = "0x11A7";
1264 my $TBase = CORE::hex $TBase_string;
1269 my $NCount = $VCount * $TCount;
1271 # For Hangul syllables; These store the numbers from Jamo.txt in conjunction
1272 # with the above published constants.
1274 my %Jamo_L; # Leading consonants
1275 my %Jamo_V; # Vowels
1276 my %Jamo_T; # Trailing consonants
1278 # For code points whose name contains its ordinal as a '-ABCD' suffix.
1279 # The key is the base name of the code point, and the value is an
1280 # array giving all the ranges that use this base name. Each range
1281 # is actually a hash giving the 'low' and 'high' values of it.
1282 my %names_ending_in_code_point;
1283 my %loose_names_ending_in_code_point; # Same as above, but has blanks, dashes
1284 # removed from the names
1285 # Inverse mapping. The list of ranges that have these kinds of
1286 # names. Each element contains the low, high, and base names in an
1288 my @code_points_ending_in_code_point;
1290 # Boolean: does this Unicode version have the hangul syllables, and are we
1291 # writing out a table for them?
1292 my $has_hangul_syllables = 0;
1294 # Does this Unicode version have code points whose names end in their
1295 # respective code points, and are we writing out a table for them? 0 for no;
1296 # otherwise points to first property that a table is needed for them, so that
1297 # if multiple tables are needed, we don't create duplicates
1298 my $needing_code_points_ending_in_code_point = 0;
1300 my @backslash_X_tests; # List of tests read in for testing \X
1301 my @unhandled_properties; # Will contain a list of properties found in
1302 # the input that we didn't process.
1303 my @match_properties; # Properties that have match tables, to be
1305 my @map_properties; # Properties that get map files written
1306 my @named_sequences; # NamedSequences.txt contents.
1307 my %potential_files; # Generated list of all .txt files in the directory
1308 # structure so we can warn if something is being
1310 my @files_actually_output; # List of files we generated.
1311 my @more_Names; # Some code point names are compound; this is used
1312 # to store the extra components of them.
1313 my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at
1314 # the minimum before we consider it equivalent to a
1315 # candidate rational
1316 my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms
1318 # These store references to certain commonly used property objects
1327 # Are there conflicting names because of beginning with 'In_', or 'Is_'
1328 my $has_In_conflicts = 0;
1329 my $has_Is_conflicts = 0;
1331 sub internal_file_to_platform ($) {
1332 # Convert our file paths which have '/' separators to those of the
1336 return undef unless defined $file;
1338 return File::Spec->join(split '/', $file);
1341 sub file_exists ($) { # platform independent '-e'. This program internally
1342 # uses slash as a path separator.
1344 return 0 if ! defined $file;
1345 return -e internal_file_to_platform($file);
1349 # Returns the address of the blessed input object.
1350 # It doesn't check for blessedness because that would do a string eval
1351 # every call, and the program is structured so that this is never called
1352 # for a non-blessed object.
1354 no overloading; # If overloaded, numifying below won't work.
1356 # Numifying a ref gives its address.
1357 return pack 'J', $_[0];
1360 # These are used only if $annotate is true.
1361 # The entire range of Unicode characters is examined to populate these
1362 # after all the input has been processed. But most can be skipped, as they
1363 # have the same descriptive phrases, such as being unassigned
1364 my @viacode; # Contains the 1 million character names
1365 my @printable; # boolean: And are those characters printable?
1366 my @annotate_char_type; # Contains a type of those characters, specifically
1367 # for the purposes of annotation.
1368 my $annotate_ranges; # A map of ranges of code points that have the same
1369 # name for the purposes of annotation. They map to the
1370 # upper edge of the range, so that the end point can
1371 # be immediately found. This is used to skip ahead to
1372 # the end of a range, and avoid processing each
1373 # individual code point in it.
1374 my $unassigned_sans_noncharacters; # A Range_List of the unassigned
1375 # characters, but excluding those which are
1376 # also noncharacter code points
1378 # The annotation types are an extension of the regular range types, though
1379 # some of the latter are folded into one. Make the new types negative to
1380 # avoid conflicting with the regular types
1381 my $SURROGATE_TYPE = -1;
1382 my $UNASSIGNED_TYPE = -2;
1383 my $PRIVATE_USE_TYPE = -3;
1384 my $NONCHARACTER_TYPE = -4;
1385 my $CONTROL_TYPE = -5;
1386 my $UNKNOWN_TYPE = -6; # Used only if there is a bug in this program
1388 sub populate_char_info ($) {
1389 # Used only with the $annotate option. Populates the arrays with the
1390 # input code point's info that are needed for outputting more detailed
1391 # comments. If calling context wants a return, it is the end point of
1392 # any contiguous range of characters that share essentially the same info
1395 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1397 $viacode[$i] = $perl_charname->value_of($i) || "";
1399 # A character is generally printable if Unicode says it is,
1400 # but below we make sure that most Unicode general category 'C' types
1402 $printable[$i] = $print->contains($i);
1404 $annotate_char_type[$i] = $perl_charname->type_of($i) || 0;
1406 # Only these two regular types are treated specially for annotations
1408 $annotate_char_type[$i] = 0 if $annotate_char_type[$i] != $CP_IN_NAME
1409 && $annotate_char_type[$i] != $HANGUL_SYLLABLE;
1411 # Give a generic name to all code points that don't have a real name.
1412 # We output ranges, if applicable, for these. Also calculate the end
1413 # point of the range.
1415 if (! $viacode[$i]) {
1416 if ($gc-> table('Surrogate')->contains($i)) {
1417 $viacode[$i] = 'Surrogate';
1418 $annotate_char_type[$i] = $SURROGATE_TYPE;
1420 $end = $gc->table('Surrogate')->containing_range($i)->end;
1422 elsif ($gc-> table('Private_use')->contains($i)) {
1423 $viacode[$i] = 'Private Use';
1424 $annotate_char_type[$i] = $PRIVATE_USE_TYPE;
1426 $end = $gc->table('Private_Use')->containing_range($i)->end;
1428 elsif (Property::property_ref('Noncharacter_Code_Point')-> table('Y')->
1431 $viacode[$i] = 'Noncharacter';
1432 $annotate_char_type[$i] = $NONCHARACTER_TYPE;
1434 $end = property_ref('Noncharacter_Code_Point')->table('Y')->
1435 containing_range($i)->end;
1437 elsif ($gc-> table('Control')->contains($i)) {
1438 $viacode[$i] = 'Control';
1439 $annotate_char_type[$i] = $CONTROL_TYPE;
1441 $end = 0x81 if $i == 0x80; # Hard-code this one known case
1443 elsif ($gc-> table('Unassigned')->contains($i)) {
1444 $viacode[$i] = 'Unassigned, block=' . $block-> value_of($i);
1445 $annotate_char_type[$i] = $UNASSIGNED_TYPE;
1448 # Because we name the unassigned by the blocks they are in, it
1449 # can't go past the end of that block, and it also can't go past
1450 # the unassigned range it is in. The special table makes sure
1451 # that the non-characters, which are unassigned, are separated
1453 $end = min($block->containing_range($i)->end,
1454 $unassigned_sans_noncharacters-> containing_range($i)->
1458 Carp::my_carp_bug("Can't figure out how to annotate "
1459 . sprintf("U+%04X", $i)
1460 . ". Proceeding anyway.");
1461 $viacode[$i] = 'UNKNOWN';
1462 $annotate_char_type[$i] = $UNKNOWN_TYPE;
1467 # Here, has a name, but if it's one in which the code point number is
1468 # appended to the name, do that.
1469 elsif ($annotate_char_type[$i] == $CP_IN_NAME) {
1470 $viacode[$i] .= sprintf("-%04X", $i);
1471 $end = $perl_charname->containing_range($i)->end;
1474 # And here, has a name, but if it's a hangul syllable one, replace it with
1475 # the correct name from the Unicode algorithm
1476 elsif ($annotate_char_type[$i] == $HANGUL_SYLLABLE) {
1478 my $SIndex = $i - $SBase;
1479 my $L = $LBase + $SIndex / $NCount;
1480 my $V = $VBase + ($SIndex % $NCount) / $TCount;
1481 my $T = $TBase + $SIndex % $TCount;
1482 $viacode[$i] = "HANGUL SYLLABLE $Jamo{$L}$Jamo{$V}";
1483 $viacode[$i] .= $Jamo{$T} if $T != $TBase;
1484 $end = $perl_charname->containing_range($i)->end;
1487 return if ! defined wantarray;
1488 return $i if ! defined $end; # If not a range, return the input
1490 # Save this whole range so can find the end point quickly
1491 $annotate_ranges->add_map($i, $end, $end);
1496 # Commented code below should work on Perl 5.8.
1497 ## This 'require' doesn't necessarily work in miniperl, and even if it does,
1498 ## the native perl version of it (which is what would operate under miniperl)
1499 ## is extremely slow, as it does a string eval every call.
1500 #my $has_fast_scalar_util = $
\18 !~ /miniperl/
1501 # && defined eval "require Scalar::Util";
1504 # # Returns the address of the blessed input object. Uses the XS version if
1505 # # available. It doesn't check for blessedness because that would do a
1506 # # string eval every call, and the program is structured so that this is
1507 # # never called for a non-blessed object.
1509 # return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util;
1511 # # Check at least that is a ref.
1512 # my $pkg = ref($_[0]) or return undef;
1514 # # Change to a fake package to defeat any overloaded stringify
1515 # bless $_[0], 'main::Fake';
1517 # # Numifying a ref gives its address.
1518 # my $addr = pack 'J', $_[0];
1520 # # Return to original class
1521 # bless $_[0], $pkg;
1528 return $a if $a >= $b;
1535 return $a if $a <= $b;
1539 sub clarify_number ($) {
1540 # This returns the input number with underscores inserted every 3 digits
1541 # in large (5 digits or more) numbers. Input must be entirely digits, not
1545 my $pos = length($number) - 3;
1546 return $number if $pos <= 1;
1548 substr($number, $pos, 0) = '_';
1557 # These routines give a uniform treatment of messages in this program. They
1558 # are placed in the Carp package to cause the stack trace to not include them,
1559 # although an alternative would be to use another package and set @CARP_NOT
1562 our $Verbose = 1 if main::DEBUG; # Useful info when debugging
1564 # This is a work-around suggested by Nicholas Clark to fix a problem with Carp
1565 # and overload trying to load Scalar:Util under miniperl. See
1566 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2009-11/msg01057.html
1567 undef $overload::VERSION;
1570 my $message = shift || "";
1571 my $nofold = shift || 0;
1574 $message = main::join_lines($message);
1575 $message =~ s/^$0: *//; # Remove initial program name
1576 $message =~ s/[.;,]+$//; # Remove certain ending punctuation
1577 $message = "\n$0: $message;";
1579 # Fold the message with program name, semi-colon end punctuation
1580 # (which looks good with the message that carp appends to it), and a
1581 # hanging indent for continuation lines.
1582 $message = main::simple_fold($message, "", 4) unless $nofold;
1583 $message =~ s/\n$//; # Remove the trailing nl so what carp
1584 # appends is to the same line
1587 return $message if defined wantarray; # If a caller just wants the msg
1594 # This is called when it is clear that the problem is caused by a bug in
1597 my $message = shift;
1598 $message =~ s/^$0: *//;
1599 $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");
1604 sub carp_too_few_args {
1606 my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'. No action taken.");
1610 my $args_ref = shift;
1613 my_carp_bug("Need at least $count arguments to "
1615 . ". Instead got: '"
1616 . join ', ', @$args_ref
1617 . "'. No action taken.");
1621 sub carp_extra_args {
1622 my $args_ref = shift;
1623 my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . "); Extras ignored.") if @_;
1625 unless (ref $args_ref) {
1626 my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref. Not checking arguments.");
1629 my ($package, $file, $line) = caller;
1630 my $subroutine = (caller 1)[3];
1633 if (ref $args_ref eq 'HASH') {
1634 foreach my $key (keys %$args_ref) {
1635 $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key};
1637 $list = join ', ', each %{$args_ref};
1639 elsif (ref $args_ref eq 'ARRAY') {
1640 foreach my $arg (@$args_ref) {
1641 $arg = $UNDEF unless defined $arg;
1643 $list = join ', ', @$args_ref;
1646 my_carp_bug("Can't cope with ref "
1648 . " . argument to 'carp_extra_args'. Not checking arguments.");
1652 my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine. Skipped.");
1660 # This program uses the inside-out method for objects, as recommended in
1661 # "Perl Best Practices". This closure aids in generating those. There
1662 # are two routines. setup_package() is called once per package to set
1663 # things up, and then set_access() is called for each hash representing a
1664 # field in the object. These routines arrange for the object to be
1665 # properly destroyed when no longer used, and for standard accessor
1666 # functions to be generated. If you need more complex accessors, just
1667 # write your own and leave those accesses out of the call to set_access().
1668 # More details below.
1670 my %constructor_fields; # fields that are to be used in constructors; see
1673 # The values of this hash will be the package names as keys to other
1674 # hashes containing the name of each field in the package as keys, and
1675 # references to their respective hashes as values.
1679 # Sets up the package, creating standard DESTROY and dump methods
1680 # (unless already defined). The dump method is used in debugging by
1682 # The optional parameters are:
1683 # a) a reference to a hash, that gets populated by later
1684 # set_access() calls with one of the accesses being
1685 # 'constructor'. The caller can then refer to this, but it is
1686 # not otherwise used by these two routines.
1687 # b) a reference to a callback routine to call during destruction
1688 # of the object, before any fields are actually destroyed
1691 my $constructor_ref = delete $args{'Constructor_Fields'};
1692 my $destroy_callback = delete $args{'Destroy_Callback'};
1693 Carp::carp_extra_args(\@_) if main::DEBUG && %args;
1696 my $package = (caller)[0];
1698 $package_fields{$package} = \%fields;
1699 $constructor_fields{$package} = $constructor_ref;
1701 unless ($package->can('DESTROY')) {
1702 my $destroy_name = "${package}::DESTROY";
1705 # Use typeglob to give the anonymous subroutine the name we want
1706 *$destroy_name = sub {
1708 my $addr = do { no overloading; pack 'J', $self; };
1710 $self->$destroy_callback if $destroy_callback;
1711 foreach my $field (keys %{$package_fields{$package}}) {
1712 #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n";
1713 delete $package_fields{$package}{$field}{$addr};
1719 unless ($package->can('dump')) {
1720 my $dump_name = "${package}::dump";
1724 return dump_inside_out($self, $package_fields{$package}, @_);
1731 # Arrange for the input field to be garbage collected when no longer
1732 # needed. Also, creates standard accessor functions for the field
1733 # based on the optional parameters-- none if none of these parameters:
1734 # 'addable' creates an 'add_NAME()' accessor function.
1735 # 'readable' or 'readable_array' creates a 'NAME()' accessor
1737 # 'settable' creates a 'set_NAME()' accessor function.
1738 # 'constructor' doesn't create an accessor function, but adds the
1739 # field to the hash that was previously passed to
1741 # Any of the accesses can be abbreviated down, so that 'a', 'ad',
1742 # 'add' etc. all mean 'addable'.
1743 # The read accessor function will work on both array and scalar
1744 # values. If another accessor in the parameter list is 'a', the read
1745 # access assumes an array. You can also force it to be array access
1746 # by specifying 'readable_array' instead of 'readable'
1748 # A sort-of 'protected' access can be set-up by preceding the addable,
1749 # readable or settable with some initial portion of 'protected_' (but,
1750 # the underscore is required), like 'p_a', 'pro_set', etc. The
1751 # "protection" is only by convention. All that happens is that the
1752 # accessor functions' names begin with an underscore. So instead of
1753 # calling set_foo, the call is _set_foo. (Real protection could be
1754 # accomplished by having a new subroutine, end_package, called at the
1755 # end of each package, and then storing the __LINE__ ranges and
1756 # checking them on every accessor. But that is way overkill.)
1758 # We create anonymous subroutines as the accessors and then use
1759 # typeglobs to assign them to the proper package and name
1761 my $name = shift; # Name of the field
1762 my $field = shift; # Reference to the inside-out hash containing the
1765 my $package = (caller)[0];
1767 if (! exists $package_fields{$package}) {
1768 croak "$0: Must call 'setup_package' before 'set_access'";
1771 # Stash the field so DESTROY can get it.
1772 $package_fields{$package}{$name} = $field;
1774 # Remaining arguments are the accessors. For each...
1775 foreach my $access (@_) {
1776 my $access = lc $access;
1780 # Match the input as far as it goes.
1781 if ($access =~ /^(p[^_]*)_/) {
1783 if (substr('protected_', 0, length $protected)
1787 # Add 1 for the underscore not included in $protected
1788 $access = substr($access, length($protected) + 1);
1796 if (substr('addable', 0, length $access) eq $access) {
1797 my $subname = "${package}::${protected}add_$name";
1800 # add_ accessor. Don't add if already there, which we
1801 # determine using 'eq' for scalars and '==' otherwise.
1804 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
1807 my $addr = do { no overloading; pack 'J', $self; };
1808 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
1810 return if grep { $value == $_ } @{$field->{$addr}};
1813 return if grep { $value eq $_ } @{$field->{$addr}};
1815 push @{$field->{$addr}}, $value;
1819 elsif (substr('constructor', 0, length $access) eq $access) {
1821 Carp::my_carp_bug("Can't set-up 'protected' constructors")
1824 $constructor_fields{$package}{$name} = $field;
1827 elsif (substr('readable_array', 0, length $access) eq $access) {
1829 # Here has read access. If one of the other parameters for
1830 # access is array, or this one specifies array (by being more
1831 # than just 'readable_'), then create a subroutine that
1832 # assumes the data is an array. Otherwise just a scalar
1833 my $subname = "${package}::${protected}$name";
1834 if (grep { /^a/i } @_
1835 or length($access) > length('readable_'))
1840 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1841 my $addr = do { no overloading; pack 'J', $_[0]; };
1842 if (ref $field->{$addr} ne 'ARRAY') {
1843 my $type = ref $field->{$addr};
1844 $type = 'scalar' unless $type;
1845 Carp::my_carp_bug("Trying to read $name as an array when it is a $type. Big problems.");
1848 return scalar @{$field->{$addr}} unless wantarray;
1850 # Make a copy; had problems with caller modifying the
1851 # original otherwise
1852 my @return = @{$field->{$addr}};
1858 # Here not an array value, a simpler function.
1862 Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1;
1864 return $field->{pack 'J', $_[0]};
1868 elsif (substr('settable', 0, length $access) eq $access) {
1869 my $subname = "${package}::${protected}set_$name";
1874 return Carp::carp_too_few_args(\@_, 2) if @_ < 2;
1875 Carp::carp_extra_args(\@_) if @_ > 2;
1877 # $self is $_[0]; $value is $_[1]
1879 $field->{pack 'J', $_[0]} = $_[1];
1884 Carp::my_carp_bug("Unknown accessor type $access. No accessor set.");
1893 # All input files use this object, which stores various attributes about them,
1894 # and provides for convenient, uniform handling. The run method wraps the
1895 # processing. It handles all the bookkeeping of opening, reading, and closing
1896 # the file, returning only significant input lines.
1898 # Each object gets a handler which processes the body of the file, and is
1899 # called by run(). Most should use the generic, default handler, which has
1900 # code scrubbed to handle things you might not expect. A handler should
1901 # basically be a while(next_line()) {...} loop.
1903 # You can also set up handlers to
1904 # 1) call before the first line is read for pre processing
1905 # 2) call to adjust each line of the input before the main handler gets them
1906 # 3) call upon EOF before the main handler exits its loop
1907 # 4) call at the end for post processing
1909 # $_ is used to store the input line, and is to be filtered by the
1910 # each_line_handler()s. So, if the format of the line is not in the desired
1911 # format for the main handler, these are used to do that adjusting. They can
1912 # be stacked (by enclosing them in an [ anonymous array ] in the constructor,
1913 # so the $_ output of one is used as the input to the next. None of the other
1914 # handlers are stackable, but could easily be changed to be so.
1916 # Most of the handlers can call insert_lines() or insert_adjusted_lines()
1917 # which insert the parameters as lines to be processed before the next input
1918 # file line is read. This allows the EOF handler to flush buffers, for
1919 # example. The difference between the two routines is that the lines inserted
1920 # by insert_lines() are subjected to the each_line_handler()s. (So if you
1921 # called it from such a handler, you would get infinite recursion.) Lines
1922 # inserted by insert_adjusted_lines() go directly to the main handler without
1923 # any adjustments. If the post-processing handler calls any of these, there
1924 # will be no effect. Some error checking for these conditions could be added,
1925 # but it hasn't been done.
1927 # carp_bad_line() should be called to warn of bad input lines, which clears $_
1928 # to prevent further processing of the line. This routine will output the
1929 # message as a warning once, and then keep a count of the lines that have the
1930 # same message, and output that count at the end of the file's processing.
1931 # This keeps the number of messages down to a manageable amount.
1933 # get_missings() should be called to retrieve any @missing input lines.
1934 # Messages will be raised if this isn't done if the options aren't to ignore
1937 sub trace { return main::trace(@_); }
1940 # Keep track of fields that are to be put into the constructor.
1941 my %constructor_fields;
1943 main::setup_package(Constructor_Fields => \%constructor_fields);
1945 my %file; # Input file name, required
1946 main::set_access('file', \%file, qw{ c r });
1948 my %first_released; # Unicode version file was first released in, required
1949 main::set_access('first_released', \%first_released, qw{ c r });
1951 my %handler; # Subroutine to process the input file, defaults to
1952 # 'process_generic_property_file'
1953 main::set_access('handler', \%handler, qw{ c });
1956 # name of property this file is for. defaults to none, meaning not
1957 # applicable, or is otherwise determinable, for example, from each line.
1958 main::set_access('property', \%property, qw{ c });
1961 # If this is true, the file is optional. If not present, no warning is
1962 # output. If it is present, the string given by this parameter is
1963 # evaluated, and if false the file is not processed.
1964 main::set_access('optional', \%optional, 'c', 'r');
1967 # This is used for debugging, to skip processing of all but a few input
1968 # files. Add 'non_skip => 1' to the constructor for those files you want
1969 # processed when you set the $debug_skip global.
1970 main::set_access('non_skip', \%non_skip, 'c');
1973 # This is used to skip processing of this input file semi-permanently.
1974 # It is used for files that we aren't planning to process anytime soon,
1975 # but want to allow to be in the directory and not raise a message that we
1976 # are not handling. Mostly for test files. This is in contrast to the
1977 # non_skip element, which is supposed to be used very temporarily for
1978 # debugging. Sets 'optional' to 1
1979 main::set_access('skip', \%skip, 'c');
1981 my %each_line_handler;
1982 # list of subroutines to look at and filter each non-comment line in the
1983 # file. defaults to none. The subroutines are called in order, each is
1984 # to adjust $_ for the next one, and the final one adjusts it for
1986 main::set_access('each_line_handler', \%each_line_handler, 'c');
1988 my %has_missings_defaults;
1989 # ? Are there lines in the file giving default values for code points
1990 # missing from it?. Defaults to NO_DEFAULTS. Otherwise NOT_IGNORED is
1991 # the norm, but IGNORED means it has such lines, but the handler doesn't
1992 # use them. Having these three states allows us to catch changes to the
1993 # UCD that this program should track
1994 main::set_access('has_missings_defaults',
1995 \%has_missings_defaults, qw{ c r });
1998 # Subroutine to call before doing anything else in the file. If undef, no
1999 # such handler is called.
2000 main::set_access('pre_handler', \%pre_handler, qw{ c });
2003 # Subroutine to call upon getting an EOF on the input file, but before
2004 # that is returned to the main handler. This is to allow buffers to be
2005 # flushed. The handler is expected to call insert_lines() or
2006 # insert_adjusted() with the buffered material
2007 main::set_access('eof_handler', \%eof_handler, qw{ c r });
2010 # Subroutine to call after all the lines of the file are read in and
2011 # processed. If undef, no such handler is called.
2012 main::set_access('post_handler', \%post_handler, qw{ c });
2014 my %progress_message;
2015 # Message to print to display progress in lieu of the standard one
2016 main::set_access('progress_message', \%progress_message, qw{ c });
2019 # cache open file handle, internal. Is undef if file hasn't been
2020 # processed at all, empty if has;
2021 main::set_access('handle', \%handle);
2024 # cache of lines added virtually to the file, internal
2025 main::set_access('added_lines', \%added_lines);
2028 # cache of errors found, internal
2029 main::set_access('errors', \%errors);
2032 # storage of '@missing' defaults lines
2033 main::set_access('missings', \%missings);
2038 my $self = bless \do{ my $anonymous_scalar }, $class;
2039 my $addr = do { no overloading; pack 'J', $self; };
2042 $handler{$addr} = \&main::process_generic_property_file;
2043 $non_skip{$addr} = 0;
2045 $has_missings_defaults{$addr} = $NO_DEFAULTS;
2046 $handle{$addr} = undef;
2047 $added_lines{$addr} = [ ];
2048 $each_line_handler{$addr} = [ ];
2049 $errors{$addr} = { };
2050 $missings{$addr} = [ ];
2052 # Two positional parameters.
2053 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
2054 $file{$addr} = main::internal_file_to_platform(shift);
2055 $first_released{$addr} = shift;
2057 # The rest of the arguments are key => value pairs
2058 # %constructor_fields has been set up earlier to list all possible
2059 # ones. Either set or push, depending on how the default has been set
2062 foreach my $key (keys %args) {
2063 my $argument = $args{$key};
2065 # Note that the fields are the lower case of the constructor keys
2066 my $hash = $constructor_fields{lc $key};
2067 if (! defined $hash) {
2068 Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self. Skipped");
2071 if (ref $hash->{$addr} eq 'ARRAY') {
2072 if (ref $argument eq 'ARRAY') {
2073 foreach my $argument (@{$argument}) {
2074 next if ! defined $argument;
2075 push @{$hash->{$addr}}, $argument;
2079 push @{$hash->{$addr}}, $argument if defined $argument;
2083 $hash->{$addr} = $argument;
2088 # If the file has a property for it, it means that the property is not
2089 # listed in the file's entries. So add a handler to the list of line
2090 # handlers to insert the property name into the lines, to provide a
2091 # uniform interface to the final processing subroutine.
2092 # the final code doesn't have to worry about that.
2093 if ($property{$addr}) {
2094 push @{$each_line_handler{$addr}}, \&_insert_property_into_line;
2097 if ($non_skip{$addr} && ! $debug_skip && $verbosity) {
2098 print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n";
2101 $optional{$addr} = 1 if $skip{$addr};
2109 qw("") => "_operator_stringify",
2110 "." => \&main::_operator_dot,
2113 sub _operator_stringify {
2116 return __PACKAGE__ . " object for " . $self->file;
2119 # flag to make sure extracted files are processed early
2120 my $seen_non_extracted_non_age = 0;
2123 # Process the input object $self. This opens and closes the file and
2124 # calls all the handlers for it. Currently, this can only be called
2125 # once per file, as it destroy's the EOF handler
2128 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2130 my $addr = do { no overloading; pack 'J', $self; };
2132 my $file = $file{$addr};
2134 # Don't process if not expecting this file (because released later
2135 # than this Unicode version), and isn't there. This means if someone
2136 # copies it into an earlier version's directory, we will go ahead and
2138 return if $first_released{$addr} gt $v_version && ! -e $file;
2140 # If in debugging mode and this file doesn't have the non-skip
2141 # flag set, and isn't one of the critical files, skip it.
2143 && $first_released{$addr} ne v0
2144 && ! $non_skip{$addr})
2146 print "Skipping $file in debugging\n" if $verbosity;
2150 # File could be optional
2151 if ($optional{$addr}) {
2152 return unless -e $file;
2153 my $result = eval $optional{$addr};
2154 if (! defined $result) {
2155 Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}. $file Skipped.");
2160 print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n";
2166 if (! defined $file || ! -e $file) {
2168 # If the file doesn't exist, see if have internal data for it
2169 # (based on first_released being 0).
2170 if ($first_released{$addr} eq v0) {
2171 $handle{$addr} = 'pretend_is_open';
2174 if (! $optional{$addr} # File could be optional
2175 && $v_version ge $first_released{$addr})
2177 print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr};
2184 # Here, the file exists. Some platforms may change the case of
2186 if ($seen_non_extracted_non_age) {
2187 if ($file =~ /$EXTRACTED/i) {
2188 Carp::my_carp_bug(join_lines(<<END
2189 $file should be processed just after the 'Prop...Alias' files, and before
2190 anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may
2191 have subtle problems
2196 elsif ($EXTRACTED_DIR
2197 && $first_released{$addr} ne v0
2198 && $file !~ /$EXTRACTED/i
2199 && lc($file) ne 'dage.txt')
2201 # We don't set this (by the 'if' above) if we have no
2202 # extracted directory, so if running on an early version,
2203 # this test won't work. Not worth worrying about.
2204 $seen_non_extracted_non_age = 1;
2207 # And mark the file as having being processed, and warn if it
2208 # isn't a file we are expecting. As we process the files,
2209 # they are deleted from the hash, so any that remain at the
2210 # end of the program are files that we didn't process.
2211 my $fkey = File::Spec->rel2abs($file);
2212 my $expecting = delete $potential_files{$fkey};
2213 $expecting = delete $potential_files{lc($fkey)} unless defined $expecting;
2214 Carp::my_carp("Was not expecting '$file'.") if
2216 && ! defined $handle{$addr};
2218 # Having deleted from expected files, we can quit if not to do
2219 # anything. Don't print progress unless really want verbosity
2221 print "Skipping $file.\n" if $verbosity >= $VERBOSE;
2225 # Open the file, converting the slashes used in this program
2226 # into the proper form for the OS
2228 if (not open $file_handle, "<", $file) {
2229 Carp::my_carp("Can't open $file. Skipping: $!");
2232 $handle{$addr} = $file_handle; # Cache the open file handle
2235 if ($verbosity >= $PROGRESS) {
2236 if ($progress_message{$addr}) {
2237 print "$progress_message{$addr}\n";
2240 # If using a virtual file, say so.
2241 print "Processing ", (-e $file)
2243 : "substitute $file",
2249 # Call any special handler for before the file.
2250 &{$pre_handler{$addr}}($self) if $pre_handler{$addr};
2252 # Then the main handler
2253 &{$handler{$addr}}($self);
2255 # Then any special post-file handler.
2256 &{$post_handler{$addr}}($self) if $post_handler{$addr};
2258 # If any errors have been accumulated, output the counts (as the first
2259 # error message in each class was output when it was encountered).
2260 if ($errors{$addr}) {
2263 foreach my $error (keys %{$errors{$addr}}) {
2264 $total += $errors{$addr}->{$error};
2265 delete $errors{$addr}->{$error};
2270 = "A total of $total lines had errors in $file. ";
2272 $message .= ($types == 1)
2273 ? '(Only the first one was displayed.)'
2274 : '(Only the first of each type was displayed.)';
2275 Carp::my_carp($message);
2279 if (@{$missings{$addr}}) {
2280 Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines. Generated tables likely are wrong");
2283 # If a real file handle, close it.
2284 close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if
2286 $handle{$addr} = ""; # Uses empty to indicate that has already seen
2287 # the file, as opposed to undef
2292 # Sets $_ to be the next logical input line, if any. Returns non-zero
2293 # if such a line exists. 'logical' means that any lines that have
2294 # been added via insert_lines() will be returned in $_ before the file
2298 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2300 my $addr = do { no overloading; pack 'J', $self; };
2302 # Here the file is open (or if the handle is not a ref, is an open
2303 # 'virtual' file). Get the next line; any inserted lines get priority
2304 # over the file itself.
2308 while (1) { # Loop until find non-comment, non-empty line
2309 #local $to_trace = 1 if main::DEBUG;
2310 my $inserted_ref = shift @{$added_lines{$addr}};
2311 if (defined $inserted_ref) {
2312 ($adjusted, $_) = @{$inserted_ref};
2313 trace $adjusted, $_ if main::DEBUG && $to_trace;
2314 return 1 if $adjusted;
2317 last if ! ref $handle{$addr}; # Don't read unless is real file
2318 last if ! defined ($_ = readline $handle{$addr});
2321 trace $_ if main::DEBUG && $to_trace;
2323 # See if this line is the comment line that defines what property
2324 # value that code points that are not listed in the file should
2325 # have. The format or existence of these lines is not guaranteed
2326 # by Unicode since they are comments, but the documentation says
2327 # that this was added for machine-readability, so probably won't
2328 # change. This works starting in Unicode Version 5.0. They look
2331 # @missing: 0000..10FFFF; Not_Reordered
2332 # @missing: 0000..10FFFF; Decomposition_Mapping; <code point>
2333 # @missing: 0000..10FFFF; ; NaN
2335 # Save the line for a later get_missings() call.
2336 if (/$missing_defaults_prefix/) {
2337 if ($has_missings_defaults{$addr} == $NO_DEFAULTS) {
2338 $self->carp_bad_line("Unexpected \@missing line. Assuming no missing entries");
2340 elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) {
2341 my @defaults = split /\s* ; \s*/x, $_;
2343 # The first field is the @missing, which ends in a
2344 # semi-colon, so can safely shift.
2347 # Some of these lines may have empty field placeholders
2348 # which get in the way. An example is:
2349 # @missing: 0000..10FFFF; ; NaN
2350 # Remove them. Process starting from the top so the
2351 # splice doesn't affect things still to be looked at.
2352 for (my $i = @defaults - 1; $i >= 0; $i--) {
2353 next if $defaults[$i] ne "";
2354 splice @defaults, $i, 1;
2357 # What's left should be just the property (maybe) and the
2358 # default. Having only one element means it doesn't have
2362 if (@defaults >= 1) {
2363 if (@defaults == 1) {
2364 $default = $defaults[0];
2367 $property = $defaults[0];
2368 $default = $defaults[1];
2374 || ($default =~ /^</
2375 && $default !~ /^<code *point>$/i
2376 && $default !~ /^<none>$/i))
2378 $self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries");
2382 # If the property is missing from the line, it should
2383 # be the one for the whole file
2384 $property = $property{$addr} if ! defined $property;
2386 # Change <none> to the null string, which is what it
2387 # really means. If the default is the code point
2388 # itself, set it to <code point>, which is what
2389 # Unicode uses (but sometimes they've forgotten the
2391 if ($default =~ /^<none>$/i) {
2394 elsif ($default =~ /^<code *point>$/i) {
2395 $default = $CODE_POINT;
2398 # Store them as a sub-arrays with both components.
2399 push @{$missings{$addr}}, [ $default, $property ];
2403 # There is nothing for the caller to process on this comment
2408 # Remove comments and trailing space, and skip this line if the
2414 # Call any handlers for this line, and skip further processing of
2415 # the line if the handler sets the line to null.
2416 foreach my $sub_ref (@{$each_line_handler{$addr}}) {
2421 # Here the line is ok. return success.
2423 } # End of looping through lines.
2425 # If there is an EOF handler, call it (only once) and if it generates
2426 # more lines to process go back in the loop to handle them.
2427 if ($eof_handler{$addr}) {
2428 &{$eof_handler{$addr}}($self);
2429 $eof_handler{$addr} = ""; # Currently only get one shot at it.
2430 goto LINE if $added_lines{$addr};
2433 # Return failure -- no more lines.
2438 # Not currently used, not fully tested.
2440 # # Non-destructive look-ahead one non-adjusted, non-comment, non-blank
2441 # # record. Not callable from an each_line_handler(), nor does it call
2442 # # an each_line_handler() on the line.
2445 # my $addr = do { no overloading; pack 'J', $self; };
2447 # foreach my $inserted_ref (@{$added_lines{$addr}}) {
2448 # my ($adjusted, $line) = @{$inserted_ref};
2449 # next if $adjusted;
2451 # # Remove comments and trailing space, and return a non-empty
2454 # $line =~ s/\s+$//;
2455 # return $line if $line ne "";
2458 # return if ! ref $handle{$addr}; # Don't read unless is real file
2459 # while (1) { # Loop until find non-comment, non-empty line
2460 # local $to_trace = 1 if main::DEBUG;
2461 # trace $_ if main::DEBUG && $to_trace;
2462 # return if ! defined (my $line = readline $handle{$addr});
2464 # push @{$added_lines{$addr}}, [ 0, $line ];
2467 # $line =~ s/\s+$//;
2468 # return $line if $line ne "";
2476 # Lines can be inserted so that it looks like they were in the input
2477 # file at the place it was when this routine is called. See also
2478 # insert_adjusted_lines(). Lines inserted via this routine go through
2479 # any each_line_handler()
2483 # Each inserted line is an array, with the first element being 0 to
2484 # indicate that this line hasn't been adjusted, and needs to be
2487 push @{$added_lines{pack 'J', $self}}, map { [ 0, $_ ] } @_;
2491 sub insert_adjusted_lines {
2492 # Lines can be inserted so that it looks like they were in the input
2493 # file at the place it was when this routine is called. See also
2494 # insert_lines(). Lines inserted via this routine are already fully
2495 # adjusted, ready to be processed; each_line_handler()s handlers will
2496 # not be called. This means this is not a completely general
2497 # facility, as only the last each_line_handler on the stack should
2498 # call this. It could be made more general, by passing to each of the
2499 # line_handlers their position on the stack, which they would pass on
2500 # to this routine, and that would replace the boolean first element in
2501 # the anonymous array pushed here, so that the next_line routine could
2502 # use that to call only those handlers whose index is after it on the
2503 # stack. But this is overkill for what is needed now.
2506 trace $_[0] if main::DEBUG && $to_trace;
2508 # Each inserted line is an array, with the first element being 1 to
2509 # indicate that this line has been adjusted
2511 push @{$added_lines{pack 'J', $self}}, map { [ 1, $_ ] } @_;
2516 # Returns the stored up @missings lines' values, and clears the list.
2517 # The values are in an array, consisting of the default in the first
2518 # element, and the property in the 2nd. However, since these lines
2519 # can be stacked up, the return is an array of all these arrays.
2522 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2524 my $addr = do { no overloading; pack 'J', $self; };
2526 # If not accepting a list return, just return the first one.
2527 return shift @{$missings{$addr}} unless wantarray;
2529 my @return = @{$missings{$addr}};
2530 undef @{$missings{$addr}};
2534 sub _insert_property_into_line {
2535 # Add a property field to $_, if this file requires it.
2538 my $addr = do { no overloading; pack 'J', $self; };
2539 my $property = $property{$addr};
2540 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2542 $_ =~ s/(;|$)/; $property$1/;
2547 # Output consistent error messages, using either a generic one, or the
2548 # one given by the optional parameter. To avoid gazillions of the
2549 # same message in case the syntax of a file is way off, this routine
2550 # only outputs the first instance of each message, incrementing a
2551 # count so the totals can be output at the end of the file.
2554 my $message = shift;
2555 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2557 my $addr = do { no overloading; pack 'J', $self; };
2559 $message = 'Unexpected line' unless $message;
2561 # No trailing punctuation so as to fit with our addenda.
2562 $message =~ s/[.:;,]$//;
2564 # If haven't seen this exact message before, output it now. Otherwise
2565 # increment the count of how many times it has occurred
2566 unless ($errors{$addr}->{$message}) {
2567 Carp::my_carp("$message in '$_' in "
2569 . " at line $.. Skipping this line;");
2570 $errors{$addr}->{$message} = 1;
2573 $errors{$addr}->{$message}++;
2576 # Clear the line to prevent any further (meaningful) processing of it.
2583 package Multi_Default;
2585 # Certain properties in early versions of Unicode had more than one possible
2586 # default for code points missing from the files. In these cases, one
2587 # default applies to everything left over after all the others are applied,
2588 # and for each of the others, there is a description of which class of code
2589 # points applies to it. This object helps implement this by storing the
2590 # defaults, and for all but that final default, an eval string that generates
2591 # the class that it applies to.
2596 main::setup_package();
2599 # The defaults structure for the classes
2600 main::set_access('class_defaults', \%class_defaults);
2603 # The default that applies to everything left over.
2604 main::set_access('other_default', \%other_default, 'r');
2608 # The constructor is called with default => eval pairs, terminated by
2609 # the left-over default. e.g.
2610 # Multi_Default->new(
2611 # 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C
2613 # 'R' => 'some other expression that evaluates to code points',
2621 my $self = bless \do{my $anonymous_scalar}, $class;
2622 my $addr = do { no overloading; pack 'J', $self; };
2625 my $default = shift;
2627 $class_defaults{$addr}->{$default} = $eval;
2630 $other_default{$addr} = shift;
2635 sub get_next_defaults {
2636 # Iterates and returns the next class of defaults.
2638 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2640 my $addr = do { no overloading; pack 'J', $self; };
2642 return each %{$class_defaults{$addr}};
2648 # An alias is one of the names that a table goes by. This class defines them
2649 # including some attributes. Everything is currently setup in the
2655 main::setup_package();
2658 main::set_access('name', \%name, 'r');
2661 # Should this name match loosely or not.
2662 main::set_access('loose_match', \%loose_match, 'r');
2665 # Some aliases should not get their own entries because they are covered
2666 # by a wild-card, and some we want to discourage use of. Binary
2667 main::set_access('make_pod_entry', \%make_pod_entry, 'r');
2670 # Aliases have a status, like deprecated, or even suppressed (which means
2671 # they don't appear in documentation). Enum
2672 main::set_access('status', \%status, 'r');
2675 # Similarly, some aliases should not be considered as usable ones for
2676 # external use, such as file names, or we don't want documentation to
2677 # recommend them. Boolean
2678 main::set_access('externally_ok', \%externally_ok, 'r');
2683 my $self = bless \do { my $anonymous_scalar }, $class;
2684 my $addr = do { no overloading; pack 'J', $self; };
2686 $name{$addr} = shift;
2687 $loose_match{$addr} = shift;
2688 $make_pod_entry{$addr} = shift;
2689 $externally_ok{$addr} = shift;
2690 $status{$addr} = shift;
2692 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2694 # Null names are never ok externally
2695 $externally_ok{$addr} = 0 if $name{$addr} eq "";
2703 # A range is the basic unit for storing code points, and is described in the
2704 # comments at the beginning of the program. Each range has a starting code
2705 # point; an ending code point (not less than the starting one); a value
2706 # that applies to every code point in between the two end-points, inclusive;
2707 # and an enum type that applies to the value. The type is for the user's
2708 # convenience, and has no meaning here, except that a non-zero type is
2709 # considered to not obey the normal Unicode rules for having standard forms.
2711 # The same structure is used for both map and match tables, even though in the
2712 # latter, the value (and hence type) is irrelevant and could be used as a
2713 # comment. In map tables, the value is what all the code points in the range
2714 # map to. Type 0 values have the standardized version of the value stored as
2715 # well, so as to not have to recalculate it a lot.
2717 sub trace { return main::trace(@_); }
2721 main::setup_package();
2724 main::set_access('start', \%start, 'r', 's');
2727 main::set_access('end', \%end, 'r', 's');
2730 main::set_access('value', \%value, 'r');
2733 main::set_access('type', \%type, 'r');
2736 # The value in internal standard form. Defined only if the type is 0.
2737 main::set_access('standard_form', \%standard_form);
2739 # Note that if these fields change, the dump() method should as well
2742 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
2745 my $self = bless \do { my $anonymous_scalar }, $class;
2746 my $addr = do { no overloading; pack 'J', $self; };
2748 $start{$addr} = shift;
2749 $end{$addr} = shift;
2753 my $value = delete $args{'Value'}; # Can be 0
2754 $value = "" unless defined $value;
2755 $value{$addr} = $value;
2757 $type{$addr} = delete $args{'Type'} || 0;
2759 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2761 if (! $type{$addr}) {
2762 $standard_form{$addr} = main::standardize($value);
2770 qw("") => "_operator_stringify",
2771 "." => \&main::_operator_dot,
2774 sub _operator_stringify {
2776 my $addr = do { no overloading; pack 'J', $self; };
2778 # Output it like '0041..0065 (value)'
2779 my $return = sprintf("%04X", $start{$addr})
2781 . sprintf("%04X", $end{$addr});
2782 my $value = $value{$addr};
2783 my $type = $type{$addr};
2785 $return .= "$value";
2786 $return .= ", Type=$type" if $type != 0;
2793 # The standard form is the value itself if the standard form is
2794 # undefined (that is if the value is special)
2797 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2799 my $addr = do { no overloading; pack 'J', $self; };
2801 return $standard_form{$addr} if defined $standard_form{$addr};
2802 return $value{$addr};
2806 # Human, not machine readable. For machine readable, comment out this
2807 # entire routine and let the standard one take effect.
2810 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
2812 my $addr = do { no overloading; pack 'J', $self; };
2814 my $return = $indent
2815 . sprintf("%04X", $start{$addr})
2817 . sprintf("%04X", $end{$addr})
2818 . " '$value{$addr}';";
2819 if (! defined $standard_form{$addr}) {
2820 $return .= "(type=$type{$addr})";
2822 elsif ($standard_form{$addr} ne $value{$addr}) {
2823 $return .= "(standard '$standard_form{$addr}')";
2829 package _Range_List_Base;
2831 # Base class for range lists. A range list is simply an ordered list of
2832 # ranges, so that the ranges with the lowest starting numbers are first in it.
2834 # When a new range is added that is adjacent to an existing range that has the
2835 # same value and type, it merges with it to form a larger range.
2837 # Ranges generally do not overlap, except that there can be multiple entries
2838 # of single code point ranges. This is because of NameAliases.txt.
2840 # In this program, there is a standard value such that if two different
2841 # values, have the same standard value, they are considered equivalent. This
2842 # value was chosen so that it gives correct results on Unicode data
2844 # There are a number of methods to manipulate range lists, and some operators
2845 # are overloaded to handle them.
2847 sub trace { return main::trace(@_); }
2853 main::setup_package();
2856 # The list of ranges
2857 main::set_access('ranges', \%ranges, 'readable_array');
2860 # The highest code point in the list. This was originally a method, but
2861 # actual measurements said it was used a lot.
2862 main::set_access('max', \%max, 'r');
2864 my %each_range_iterator;
2865 # Iterator position for each_range()
2866 main::set_access('each_range_iterator', \%each_range_iterator);
2869 # Name of parent this is attached to, if any. Solely for better error
2871 main::set_access('owner_name_of', \%owner_name_of, 'p_r');
2873 my %_search_ranges_cache;
2874 # A cache of the previous result from _search_ranges(), for better
2876 main::set_access('_search_ranges_cache', \%_search_ranges_cache);
2882 # Optional initialization data for the range list.
2883 my $initialize = delete $args{'Initialize'};
2887 # Use _union() to initialize. _union() returns an object of this
2888 # class, which means that it will call this constructor recursively.
2889 # But it won't have this $initialize parameter so that it won't
2890 # infinitely loop on this.
2891 return _union($class, $initialize, %args) if defined $initialize;
2893 $self = bless \do { my $anonymous_scalar }, $class;
2894 my $addr = do { no overloading; pack 'J', $self; };
2896 # Optional parent object, only for debug info.
2897 $owner_name_of{$addr} = delete $args{'Owner'};
2898 $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr};
2900 # Stringify, in case it is an object.
2901 $owner_name_of{$addr} = "$owner_name_of{$addr}";
2903 # This is used only for error messages, and so a colon is added
2904 $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne "";
2906 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
2908 # Max is initialized to a negative value that isn't adjacent to 0,
2912 $_search_ranges_cache{$addr} = 0;
2913 $ranges{$addr} = [];
2920 qw("") => "_operator_stringify",
2921 "." => \&main::_operator_dot,
2924 sub _operator_stringify {
2926 my $addr = do { no overloading; pack 'J', $self; };
2928 return "Range_List attached to '$owner_name_of{$addr}'"
2929 if $owner_name_of{$addr};
2930 return "anonymous Range_List " . \$self;
2934 # Returns the union of the input code points. It can be called as
2935 # either a constructor or a method. If called as a method, the result
2936 # will be a new() instance of the calling object, containing the union
2937 # of that object with the other parameter's code points; if called as
2938 # a constructor, the first parameter gives the class the new object
2939 # should be, and the second parameter gives the code points to go into
2941 # In either case, there are two parameters looked at by this routine;
2942 # any additional parameters are passed to the new() constructor.
2944 # The code points can come in the form of some object that contains
2945 # ranges, and has a conventionally named method to access them; or
2946 # they can be an array of individual code points (as integers); or
2947 # just a single code point.
2949 # If they are ranges, this routine doesn't make any effort to preserve
2950 # the range values of one input over the other. Therefore this base
2951 # class should not allow _union to be called from other than
2952 # initialization code, so as to prevent two tables from being added
2953 # together where the range values matter. The general form of this
2954 # routine therefore belongs in a derived class, but it was moved here
2955 # to avoid duplication of code. The failure to overload this in this
2956 # class keeps it safe.
2960 my @args; # Arguments to pass to the constructor
2964 # If a method call, will start the union with the object itself, and
2965 # the class of the new object will be the same as self.
2972 # Add the other required parameter.
2974 # Rest of parameters are passed on to the constructor
2976 # Accumulate all records from both lists.
2978 for my $arg (@args) {
2979 #local $to_trace = 0 if main::DEBUG;
2980 trace "argument = $arg" if main::DEBUG && $to_trace;
2981 if (! defined $arg) {
2983 if (defined $self) {
2985 $message .= $owner_name_of{pack 'J', $self};
2987 Carp::my_carp_bug($message .= "Undefined argument to _union. No union done.");
2990 $arg = [ $arg ] if ! ref $arg;
2991 my $type = ref $arg;
2992 if ($type eq 'ARRAY') {
2993 foreach my $element (@$arg) {
2994 push @records, Range->new($element, $element);
2997 elsif ($arg->isa('Range')) {
2998 push @records, $arg;
3000 elsif ($arg->can('ranges')) {
3001 push @records, $arg->ranges;
3005 if (defined $self) {
3007 $message .= $owner_name_of{pack 'J', $self};
3009 Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done.");
3014 # Sort with the range containing the lowest ordinal first, but if
3015 # two ranges start at the same code point, sort with the bigger range
3016 # of the two first, because it takes fewer cycles.
3017 @records = sort { ($a->start <=> $b->start)
3019 # if b is shorter than a, b->end will be
3020 # less than a->end, and we want to select
3021 # a, so want to return -1
3022 ($b->end <=> $a->end)
3025 my $new = $class->new(@_);
3027 # Fold in records so long as they add new information.
3028 for my $set (@records) {
3029 my $start = $set->start;
3030 my $end = $set->end;
3031 my $value = $set->value;
3032 if ($start > $new->max) {
3033 $new->_add_delete('+', $start, $end, $value);
3035 elsif ($end > $new->max) {
3036 $new->_add_delete('+', $new->max +1, $end, $value);
3043 sub range_count { # Return the number of ranges in the range list
3045 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3048 return scalar @{$ranges{pack 'J', $self}};
3052 # Returns the minimum code point currently in the range list, or if
3053 # the range list is empty, 2 beyond the max possible. This is a
3054 # method because used so rarely, that not worth saving between calls,
3055 # and having to worry about changing it as ranges are added and
3059 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3061 my $addr = do { no overloading; pack 'J', $self; };
3063 # If the range list is empty, return a large value that isn't adjacent
3064 # to any that could be in the range list, for simpler tests
3065 return $MAX_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}};
3066 return $ranges{$addr}->[0]->start;
3070 # Boolean: Is argument in the range list? If so returns $i such that:
3071 # range[$i]->end < $codepoint <= range[$i+1]->end
3072 # which is one beyond what you want; this is so that the 0th range
3073 # doesn't return false
3075 my $codepoint = shift;
3076 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3078 my $i = $self->_search_ranges($codepoint);
3079 return 0 unless defined $i;
3081 # The search returns $i, such that
3082 # range[$i-1]->end < $codepoint <= range[$i]->end
3083 # So is in the table if and only iff it is at least the start position
3086 return 0 if $ranges{pack 'J', $self}->[$i]->start > $codepoint;
3090 sub containing_range {
3091 # Returns the range object that contains the code point, undef if none
3094 my $codepoint = shift;
3095 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3097 my $i = $self->contains($codepoint);
3100 # contains() returns 1 beyond where we should look
3102 return $ranges{pack 'J', $self}->[$i-1];
3106 # Returns the value associated with the code point, undef if none
3109 my $codepoint = shift;
3110 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3112 my $range = $self->containing_range($codepoint);
3113 return unless defined $range;
3115 return $range->value;
3119 # Returns the type of the range containing the code point, undef if
3120 # the code point is not in the table
3123 my $codepoint = shift;
3124 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3126 my $range = $self->containing_range($codepoint);
3127 return unless defined $range;
3129 return $range->type;
3132 sub _search_ranges {
3133 # Find the range in the list which contains a code point, or where it
3134 # should go if were to add it. That is, it returns $i, such that:
3135 # range[$i-1]->end < $codepoint <= range[$i]->end
3136 # Returns undef if no such $i is possible (e.g. at end of table), or
3137 # if there is an error.
3140 my $code_point = shift;
3141 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3143 my $addr = do { no overloading; pack 'J', $self; };
3145 return if $code_point > $max{$addr};
3146 my $r = $ranges{$addr}; # The current list of ranges
3147 my $range_list_size = scalar @$r;
3150 use integer; # want integer division
3152 # Use the cached result as the starting guess for this one, because,
3153 # an experiment on 5.1 showed that 90% of the time the cache was the
3154 # same as the result on the next call (and 7% it was one less).
3155 $i = $_search_ranges_cache{$addr};
3156 $i = 0 if $i >= $range_list_size; # Reset if no longer valid (prob.
3157 # from an intervening deletion
3158 #local $to_trace = 1 if main::DEBUG;
3159 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);
3160 return $i if $code_point <= $r->[$i]->end
3161 && ($i == 0 || $r->[$i-1]->end < $code_point);
3163 # Here the cache doesn't yield the correct $i. Try adding 1.
3164 if ($i < $range_list_size - 1
3165 && $r->[$i]->end < $code_point &&
3166 $code_point <= $r->[$i+1]->end)
3169 trace "next \$i is correct: $i" if main::DEBUG && $to_trace;
3170 $_search_ranges_cache{$addr} = $i;
3174 # Here, adding 1 also didn't work. We do a binary search to
3175 # find the correct position, starting with current $i
3177 my $upper = $range_list_size - 1;
3179 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;
3181 if ($code_point <= $r->[$i]->end) {
3183 # Here we have met the upper constraint. We can quit if we
3184 # also meet the lower one.
3185 last if $i == 0 || $r->[$i-1]->end < $code_point;
3187 $upper = $i; # Still too high.
3192 # Here, $r[$i]->end < $code_point, so look higher up.
3196 # Split search domain in half to try again.
3197 my $temp = ($upper + $lower) / 2;
3199 # No point in continuing unless $i changes for next time
3203 # We can't reach the highest element because of the averaging.
3204 # So if one below the upper edge, force it there and try one
3206 if ($i == $range_list_size - 2) {
3208 trace "Forcing to upper edge" if main::DEBUG && $to_trace;
3209 $i = $range_list_size - 1;
3211 # Change $lower as well so if fails next time through,
3212 # taking the average will yield the same $i, and we will
3213 # quit with the error message just below.
3217 Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go. No action taken.");
3221 } # End of while loop
3223 if (main::DEBUG && $to_trace) {
3224 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i;
3225 trace "i= [ $i ]", $r->[$i];
3226 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1;
3229 # Here we have found the offset. Cache it as a starting point for the
3231 $_search_ranges_cache{$addr} = $i;
3236 # Add, replace or delete ranges to or from a list. The $type
3237 # parameter gives which:
3238 # '+' => insert or replace a range, returning a list of any changed
3240 # '-' => delete a range, returning a list of any deleted ranges.
3242 # The next three parameters give respectively the start, end, and
3243 # value associated with the range. 'value' should be null unless the
3246 # The range list is kept sorted so that the range with the lowest
3247 # starting position is first in the list, and generally, adjacent
3248 # ranges with the same values are merged into a single larger one (see
3249 # exceptions below).
3251 # There are more parameters; all are key => value pairs:
3252 # Type gives the type of the value. It is only valid for '+'.
3253 # All ranges have types; if this parameter is omitted, 0 is
3254 # assumed. Ranges with type 0 are assumed to obey the
3255 # Unicode rules for casing, etc; ranges with other types are
3256 # not. Otherwise, the type is arbitrary, for the caller's
3257 # convenience, and looked at only by this routine to keep
3258 # adjacent ranges of different types from being merged into
3259 # a single larger range, and when Replace =>
3260 # $IF_NOT_EQUIVALENT is specified (see just below).
3261 # Replace determines what to do if the range list already contains
3262 # ranges which coincide with all or portions of the input
3263 # range. It is only valid for '+':
3264 # => $NO means that the new value is not to replace
3265 # any existing ones, but any empty gaps of the
3266 # range list coinciding with the input range
3267 # will be filled in with the new value.
3268 # => $UNCONDITIONALLY means to replace the existing values with
3269 # this one unconditionally. However, if the
3270 # new and old values are identical, the
3271 # replacement is skipped to save cycles
3272 # => $IF_NOT_EQUIVALENT means to replace the existing values
3273 # with this one if they are not equivalent.
3274 # Ranges are equivalent if their types are the
3275 # same, and they are the same string; or if
3276 # both are type 0 ranges, if their Unicode
3277 # standard forms are identical. In this last
3278 # case, the routine chooses the more "modern"
3279 # one to use. This is because some of the
3280 # older files are formatted with values that
3281 # are, for example, ALL CAPs, whereas the
3282 # derived files have a more modern style,
3283 # which looks better. By looking for this
3284 # style when the pre-existing and replacement
3285 # standard forms are the same, we can move to
3287 # => $MULTIPLE means that if this range duplicates an
3288 # existing one, but has a different value,
3289 # don't replace the existing one, but insert
3290 # this, one so that the same range can occur
3291 # multiple times. They are stored LIFO, so
3292 # that the final one inserted is the first one
3293 # returned in an ordered search of the table.
3294 # => anything else is the same as => $IF_NOT_EQUIVALENT
3296 # "same value" means identical for non-type-0 ranges, and it means
3297 # having the same standard forms for type-0 ranges.
3299 return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5;
3302 my $operation = shift; # '+' for add/replace; '-' for delete;
3309 $value = "" if not defined $value; # warning: $value can be "0"
3311 my $replace = delete $args{'Replace'};
3312 $replace = $IF_NOT_EQUIVALENT unless defined $replace;
3314 my $type = delete $args{'Type'};
3315 $type = 0 unless defined $type;
3317 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
3319 my $addr = do { no overloading; pack 'J', $self; };
3321 if ($operation ne '+' && $operation ne '-') {
3322 Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'. No action taken.");
3325 unless (defined $start && defined $end) {
3326 Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete. No action taken.");
3329 unless ($end >= $start) {
3330 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.");
3333 #local $to_trace = 1 if main::DEBUG;
3335 if ($operation eq '-') {
3336 if ($replace != $IF_NOT_EQUIVALENT) {
3337 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.");
3338 $replace = $IF_NOT_EQUIVALENT;
3341 Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list. Assuming Type => 0.");
3345 Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list. Assuming Value => \"\".");
3350 my $r = $ranges{$addr}; # The current list of ranges
3351 my $range_list_size = scalar @$r; # And its size
3352 my $max = $max{$addr}; # The current high code point in
3353 # the list of ranges
3355 # Do a special case requiring fewer machine cycles when the new range
3356 # starts after the current highest point. The Unicode input data is
3357 # structured so this is common.
3358 if ($start > $max) {
3360 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace;
3361 return if $operation eq '-'; # Deleting a non-existing range is a
3364 # If the new range doesn't logically extend the current final one
3365 # in the range list, create a new range at the end of the range
3366 # list. (max cleverly is initialized to a negative number not
3367 # adjacent to 0 if the range list is empty, so even adding a range
3368 # to an empty range list starting at 0 will have this 'if'
3370 if ($start > $max + 1 # non-adjacent means can't extend.
3371 || @{$r}[-1]->value ne $value # values differ, can't extend.
3372 || @{$r}[-1]->type != $type # types differ, can't extend.
3374 push @$r, Range->new($start, $end,
3380 # Here, the new range starts just after the current highest in
3381 # the range list, and they have the same type and value.
3382 # Extend the current range to incorporate the new one.
3383 @{$r}[-1]->set_end($end);
3386 # This becomes the new maximum.
3391 #local $to_trace = 0 if main::DEBUG;
3393 trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace;
3395 # Here, the input range isn't after the whole rest of the range list.
3396 # Most likely 'splice' will be needed. The rest of the routine finds
3397 # the needed splice parameters, and if necessary, does the splice.
3398 # First, find the offset parameter needed by the splice function for
3399 # the input range. Note that the input range may span multiple
3400 # existing ones, but we'll worry about that later. For now, just find
3401 # the beginning. If the input range is to be inserted starting in a
3402 # position not currently in the range list, it must (obviously) come
3403 # just after the range below it, and just before the range above it.
3404 # Slightly less obviously, it will occupy the position currently
3405 # occupied by the range that is to come after it. More formally, we
3406 # are looking for the position, $i, in the array of ranges, such that:
3408 # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end
3410 # (The ordered relationships within existing ranges are also shown in
3411 # the equation above). However, if the start of the input range is
3412 # within an existing range, the splice offset should point to that
3413 # existing range's position in the list; that is $i satisfies a
3414 # somewhat different equation, namely:
3416 #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end
3418 # More briefly, $start can come before or after r[$i]->start, and at
3419 # this point, we don't know which it will be. However, these
3420 # two equations share these constraints:
3422 # r[$i-1]->end < $start <= r[$i]->end
3424 # And that is good enough to find $i.
3426 my $i = $self->_search_ranges($start);
3428 Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined. Operation '$operation' not performed");
3432 # The search function returns $i such that:
3434 # r[$i-1]->end < $start <= r[$i]->end
3436 # That means that $i points to the first range in the range list
3437 # that could possibly be affected by this operation. We still don't
3438 # know if the start of the input range is within r[$i], or if it
3439 # points to empty space between r[$i-1] and r[$i].
3440 trace "[$i] is the beginning splice point. Existing range there is ", $r->[$i] if main::DEBUG && $to_trace;
3442 # Special case the insertion of data that is not to replace any
3444 if ($replace == $NO) { # If $NO, has to be operation '+'
3445 #local $to_trace = 1 if main::DEBUG;
3446 trace "Doesn't replace" if main::DEBUG && $to_trace;
3448 # Here, the new range is to take effect only on those code points
3449 # that aren't already in an existing range. This can be done by
3450 # looking through the existing range list and finding the gaps in
3451 # the ranges that this new range affects, and then calling this
3452 # function recursively on each of those gaps, leaving untouched
3453 # anything already in the list. Gather up a list of the changed
3454 # gaps first so that changes to the internal state as new ranges
3455 # are added won't be a problem.
3458 # First, if the starting point of the input range is outside an
3459 # existing one, there is a gap from there to the beginning of the
3460 # existing range -- add a span to fill the part that this new
3462 if ($start < $r->[$i]->start) {
3463 push @gap_list, Range->new($start,
3465 $r->[$i]->start - 1),
3467 trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace;
3470 # Then look through the range list for other gaps until we reach
3471 # the highest range affected by the input one.
3473 for ($j = $i+1; $j < $range_list_size; $j++) {
3474 trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace;
3475 last if $end < $r->[$j]->start;
3477 # If there is a gap between when this range starts and the
3478 # previous one ends, add a span to fill it. Note that just
3479 # because there are two ranges doesn't mean there is a
3480 # non-zero gap between them. It could be that they have
3481 # different values or types
3482 if ($r->[$j-1]->end + 1 != $r->[$j]->start) {
3484 Range->new($r->[$j-1]->end + 1,
3485 $r->[$j]->start - 1,
3487 trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace;
3491 # Here, we have either found an existing range in the range list,
3492 # beyond the area affected by the input one, or we fell off the
3493 # end of the loop because the input range affects the whole rest
3494 # of the range list. In either case, $j is 1 higher than the
3495 # highest affected range. If $j == $i, it means that there are no
3496 # affected ranges, that the entire insertion is in the gap between
3497 # r[$i-1], and r[$i], which we already have taken care of before
3499 # On the other hand, if there are affected ranges, it might be
3500 # that there is a gap that needs filling after the final such
3501 # range to the end of the input range
3502 if ($r->[$j-1]->end < $end) {
3503 push @gap_list, Range->new(main::max($start,
3504 $r->[$j-1]->end + 1),
3507 trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace;
3510 # Call recursively to fill in all the gaps.
3511 foreach my $gap (@gap_list) {
3512 $self->_add_delete($operation,
3522 # Here, we have taken care of the case where $replace is $NO.
3523 # Remember that here, r[$i-1]->end < $start <= r[$i]->end
3524 # If inserting a multiple record, this is where it goes, before the
3525 # first (if any) existing one. This implies an insertion, and no
3526 # change to any existing ranges. Note that $i can be -1 if this new
3527 # range doesn't actually duplicate any existing, and comes at the
3528 # beginning of the list.
3529 if ($replace == $MULTIPLE) {
3531 if ($start != $end) {
3532 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.");
3536 # Don't add an exact duplicate, as it isn't really a multiple
3537 if ($end >= $r->[$i]->start) {
3538 my $existing_value = $r->[$i]->value;
3539 my $existing_type = $r->[$i]->type;
3540 return if $value eq $existing_value && $type eq $existing_type;
3542 # If the multiple value is part of an existing range, we want
3543 # to split up that range, so that only the single code point
3544 # is affected. To do this, we first call ourselves
3545 # recursively to delete that code point from the table, having
3546 # preserved its current data above. Then we call ourselves
3547 # recursively again to add the new multiple, which we know by
3548 # the test just above is different than the current code
3549 # point's value, so it will become a range containing a single
3550 # code point: just itself. Finally, we add back in the
3551 # pre-existing code point, which will again be a single code
3552 # point range. Because 'i' likely will have changed as a
3553 # result of these operations, we can't just continue on, but
3554 # do this operation recursively as well.
3555 if ($r->[$i]->start != $r->[$i]->end) {
3556 $self->_add_delete('-', $start, $end, "");
3557 $self->_add_delete('+', $start, $end, $value, Type => $type);
3558 return $self->_add_delete('+', $start, $end, $existing_value, Type => $existing_type, Replace => $MULTIPLE);
3562 trace "Adding multiple record at $i with $start..$end, $value" if main::DEBUG && $to_trace;
3563 my @return = splice @$r,
3570 if (main::DEBUG && $to_trace) {
3571 trace "After splice:";
3572 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3573 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3574 trace "i =[", $i, "]", $r->[$i] if $i >= 0;
3575 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3576 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3577 trace 'i+3=[', $i+3, ']', $r->[$i+3] if $i < @$r - 3;
3582 # Here, we have taken care of $NO and $MULTIPLE replaces. This leaves
3583 # delete, insert, and replace either unconditionally or if not
3584 # equivalent. $i still points to the first potential affected range.
3585 # Now find the highest range affected, which will determine the length
3586 # parameter to splice. (The input range can span multiple existing
3587 # ones.) If this isn't a deletion, while we are looking through the
3588 # range list, see also if this is a replacement rather than a clean
3589 # insertion; that is if it will change the values of at least one
3590 # existing range. Start off assuming it is an insert, until find it
3592 my $clean_insert = $operation eq '+';
3593 my $j; # This will point to the highest affected range
3595 # For non-zero types, the standard form is the value itself;
3596 my $standard_form = ($type) ? $value : main::standardize($value);
3598 for ($j = $i; $j < $range_list_size; $j++) {
3599 trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace;
3601 # If find a range that it doesn't overlap into, we can stop
3603 last if $end < $r->[$j]->start;
3605 # Here, overlaps the range at $j. If the values don't match,
3606 # and so far we think this is a clean insertion, it becomes a
3607 # non-clean insertion, i.e., a 'change' or 'replace' instead.
3608 if ($clean_insert) {
3609 if ($r->[$j]->standard_form ne $standard_form) {
3611 if ($replace == $CROAK) {
3612 main::croak("The range to add "
3613 . sprintf("%04X", $start)
3615 . sprintf("%04X", $end)
3616 . " with value '$value' overlaps an existing range $r->[$j]");
3621 # Here, the two values are essentially the same. If the
3622 # two are actually identical, replacing wouldn't change
3623 # anything so skip it.
3624 my $pre_existing = $r->[$j]->value;
3625 if ($pre_existing ne $value) {
3627 # Here the new and old standardized values are the
3628 # same, but the non-standardized values aren't. If
3629 # replacing unconditionally, then replace
3630 if( $replace == $UNCONDITIONALLY) {
3635 # Here, are replacing conditionally. Decide to
3636 # replace or not based on which appears to look
3637 # the "nicest". If one is mixed case and the
3638 # other isn't, choose the mixed case one.
3639 my $new_mixed = $value =~ /[A-Z]/
3640 && $value =~ /[a-z]/;
3641 my $old_mixed = $pre_existing =~ /[A-Z]/
3642 && $pre_existing =~ /[a-z]/;
3644 if ($old_mixed != $new_mixed) {
3645 $clean_insert = 0 if $new_mixed;
3646 if (main::DEBUG && $to_trace) {
3647 if ($clean_insert) {
3648 trace "Retaining $pre_existing over $value";
3651 trace "Replacing $pre_existing with $value";
3657 # Here casing wasn't different between the two.
3658 # If one has hyphens or underscores and the
3659 # other doesn't, choose the one with the
3661 my $new_punct = $value =~ /[-_]/;
3662 my $old_punct = $pre_existing =~ /[-_]/;
3664 if ($old_punct != $new_punct) {
3665 $clean_insert = 0 if $new_punct;
3666 if (main::DEBUG && $to_trace) {
3667 if ($clean_insert) {
3668 trace "Retaining $pre_existing over $value";
3671 trace "Replacing $pre_existing with $value";
3674 } # else existing one is just as "good";
3675 # retain it to save cycles.
3681 } # End of loop looking for highest affected range.
3683 # Here, $j points to one beyond the highest range that this insertion
3684 # affects (hence to beyond the range list if that range is the final
3685 # one in the range list).
3687 # The splice length is all the affected ranges. Get it before
3688 # subtracting, for efficiency, so we don't have to later add 1.
3689 my $length = $j - $i;
3691 $j--; # $j now points to the highest affected range.
3692 trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace;
3694 # Here, have taken care of $NO and $MULTIPLE replaces.
3695 # $j points to the highest affected range. But it can be < $i or even
3696 # -1. These happen only if the insertion is entirely in the gap
3697 # between r[$i-1] and r[$i]. Here's why: j < i means that the j loop
3698 # above exited first time through with $end < $r->[$i]->start. (And
3699 # then we subtracted one from j) This implies also that $start <
3700 # $r->[$i]->start, but we know from above that $r->[$i-1]->end <
3701 # $start, so the entire input range is in the gap.
3704 # Here the entire input range is in the gap before $i.
3706 if (main::DEBUG && $to_trace) {
3708 trace "Entire range is between $r->[$i-1] and $r->[$i]";
3711 trace "Entire range is before $r->[$i]";
3714 return if $operation ne '+'; # Deletion of a non-existent range is
3719 # Here part of the input range is not in the gap before $i. Thus,
3720 # there is at least one affected one, and $j points to the highest
3723 # At this point, here is the situation:
3724 # This is not an insertion of a multiple, nor of tentative ($NO)
3726 # $i points to the first element in the current range list that
3727 # may be affected by this operation. In fact, we know
3728 # that the range at $i is affected because we are in
3729 # the else branch of this 'if'
3730 # $j points to the highest affected range.
3732 # r[$i-1]->end < $start <= r[$i]->end
3734 # r[$i-1]->end < $start <= $end <= r[$j]->end
3737 # $clean_insert is a boolean which is set true if and only if
3738 # this is a "clean insertion", i.e., not a change nor a
3739 # deletion (multiple was handled above).
3741 # We now have enough information to decide if this call is a no-op
3742 # or not. It is a no-op if this is an insertion of already
3745 if (main::DEBUG && $to_trace && $clean_insert
3747 && $start >= $r->[$i]->start)
3751 return if $clean_insert
3752 && $i == $j # more than one affected range => not no-op
3754 # Here, r[$i-1]->end < $start <= $end <= r[$i]->end
3755 # Further, $start and/or $end is >= r[$i]->start
3756 # The test below hence guarantees that
3757 # r[$i]->start < $start <= $end <= r[$i]->end
3758 # This means the input range is contained entirely in
3759 # the one at $i, so is a no-op
3760 && $start >= $r->[$i]->start;
3763 # Here, we know that some action will have to be taken. We have
3764 # calculated the offset and length (though adjustments may be needed)
3765 # for the splice. Now start constructing the replacement list.
3767 my $splice_start = $i;
3772 # See if should extend any adjacent ranges.
3773 if ($operation eq '-') { # Don't extend deletions
3774 $extends_below = $extends_above = 0;
3776 else { # Here, should extend any adjacent ranges. See if there are
3778 $extends_below = ($i > 0
3779 # can't extend unless adjacent
3780 && $r->[$i-1]->end == $start -1
3781 # can't extend unless are same standard value
3782 && $r->[$i-1]->standard_form eq $standard_form
3783 # can't extend unless share type
3784 && $r->[$i-1]->type == $type);
3785 $extends_above = ($j+1 < $range_list_size
3786 && $r->[$j+1]->start == $end +1
3787 && $r->[$j+1]->standard_form eq $standard_form
3788 && $r->[$j+1]->type == $type);
3790 if ($extends_below && $extends_above) { # Adds to both
3791 $splice_start--; # start replace at element below
3792 $length += 2; # will replace on both sides
3793 trace "Extends both below and above ranges" if main::DEBUG && $to_trace;
3795 # The result will fill in any gap, replacing both sides, and
3796 # create one large range.
3797 @replacement = Range->new($r->[$i-1]->start,
3804 # Here we know that the result won't just be the conglomeration of
3805 # a new range with both its adjacent neighbors. But it could
3806 # extend one of them.
3808 if ($extends_below) {
3810 # Here the new element adds to the one below, but not to the
3811 # one above. If inserting, and only to that one range, can
3812 # just change its ending to include the new one.
3813 if ($length == 0 && $clean_insert) {
3814 $r->[$i-1]->set_end($end);
3815 trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace;
3819 trace "Changing inserted range to start at ", sprintf("%04X", $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace;
3820 $splice_start--; # start replace at element below
3821 $length++; # will replace the element below
3822 $start = $r->[$i-1]->start;
3825 elsif ($extends_above) {
3827 # Here the new element adds to the one above, but not below.
3828 # Mirror the code above
3829 if ($length == 0 && $clean_insert) {
3830 $r->[$j+1]->set_start($start);
3831 trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace;
3835 trace "Changing inserted range to end at ", sprintf("%04X", $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace;
3836 $length++; # will replace the element above
3837 $end = $r->[$j+1]->end;
3841 trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace;
3843 # Finally, here we know there will have to be a splice.
3844 # If the change or delete affects only the highest portion of the
3845 # first affected range, the range will have to be split. The
3846 # splice will remove the whole range, but will replace it by a new
3847 # range containing just the unaffected part. So, in this case,
3848 # add to the replacement list just this unaffected portion.
3849 if (! $extends_below
3850 && $start > $r->[$i]->start && $start <= $r->[$i]->end)
3853 Range->new($r->[$i]->start,
3855 Value => $r->[$i]->value,
3856 Type => $r->[$i]->type);
3859 # In the case of an insert or change, but not a delete, we have to
3860 # put in the new stuff; this comes next.
3861 if ($operation eq '+') {
3862 push @replacement, Range->new($start,
3868 trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i;
3869 #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace;
3871 # And finally, if we're changing or deleting only a portion of the
3872 # highest affected range, it must be split, as the lowest one was.
3873 if (! $extends_above
3874 && $j >= 0 # Remember that j can be -1 if before first
3876 && $end >= $r->[$j]->start
3877 && $end < $r->[$j]->end)
3880 Range->new($end + 1,
3882 Value => $r->[$j]->value,
3883 Type => $r->[$j]->type);
3887 # And do the splice, as calculated above
3888 if (main::DEBUG && $to_trace) {
3889 trace "replacing $length element(s) at $i with ";
3890 foreach my $replacement (@replacement) {
3891 trace " $replacement";
3893 trace "Before splice:";
3894 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3895 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3896 trace "i =[", $i, "]", $r->[$i];
3897 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3898 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3901 my @return = splice @$r, $splice_start, $length, @replacement;
3903 if (main::DEBUG && $to_trace) {
3904 trace "After splice:";
3905 trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2;
3906 trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1;
3907 trace "i =[", $i, "]", $r->[$i];
3908 trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1;
3909 trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2;
3910 trace "removed ", @return if @return;
3913 # An actual deletion could have changed the maximum in the list.
3914 # There was no deletion if the splice didn't return something, but
3915 # otherwise recalculate it. This is done too rarely to worry about
3917 if ($operation eq '-' && @return) {
3918 $max{$addr} = $r->[-1]->end;
3923 sub reset_each_range { # reset the iterator for each_range();
3925 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3928 undef $each_range_iterator{pack 'J', $self};
3933 # Iterate over each range in a range list. Results are undefined if
3934 # the range list is changed during the iteration.
3937 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3939 my $addr = do { no overloading; pack 'J', $self; };
3941 return if $self->is_empty;
3943 $each_range_iterator{$addr} = -1
3944 if ! defined $each_range_iterator{$addr};
3945 $each_range_iterator{$addr}++;
3946 return $ranges{$addr}->[$each_range_iterator{$addr}]
3947 if $each_range_iterator{$addr} < @{$ranges{$addr}};
3948 undef $each_range_iterator{$addr};
3952 sub count { # Returns count of code points in range list
3954 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3956 my $addr = do { no overloading; pack 'J', $self; };
3959 foreach my $range (@{$ranges{$addr}}) {
3960 $count += $range->end - $range->start + 1;
3965 sub delete_range { # Delete a range
3970 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3972 return $self->_add_delete('-', $start, $end, "");
3975 sub is_empty { # Returns boolean as to if a range list is empty
3977 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3980 return scalar @{$ranges{pack 'J', $self}} == 0;
3984 # Quickly returns a scalar suitable for separating tables into
3985 # buckets, i.e. it is a hash function of the contents of a table, so
3986 # there are relatively few conflicts.
3989 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
3991 my $addr = do { no overloading; pack 'J', $self; };
3993 # These are quickly computable. Return looks like 'min..max;count'
3994 return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}};
3996 } # End closure for _Range_List_Base
3999 use base '_Range_List_Base';
4001 # A Range_List is a range list for match tables; i.e. the range values are
4002 # not significant. Thus a number of operations can be safely added to it,
4003 # such as inversion, intersection. Note that union is also an unsafe
4004 # operation when range values are cared about, and that method is in the base
4005 # class, not here. But things are set up so that that method is callable only
4006 # during initialization. Only in this derived class, is there an operation
4007 # that combines two tables. A Range_Map can thus be used to initialize a
4008 # Range_List, and its mappings will be in the list, but are not significant to
4011 sub trace { return main::trace(@_); }
4017 '+' => sub { my $self = shift;
4020 return $self->_union($other)
4022 '&' => sub { my $self = shift;
4025 return $self->_intersect($other, 0);
4032 # Returns a new Range_List that gives all code points not in $self.
4036 my $new = Range_List->new;
4038 # Go through each range in the table, finding the gaps between them
4039 my $max = -1; # Set so no gap before range beginning at 0
4040 for my $range ($self->ranges) {
4041 my $start = $range->start;
4042 my $end = $range->end;
4044 # If there is a gap before this range, the inverse will contain
4046 if ($start > $max + 1) {
4047 $new->add_range($max + 1, $start - 1);
4052 # And finally, add the gap from the end of the table to the max
4053 # possible code point
4054 if ($max < $MAX_UNICODE_CODEPOINT) {
4055 $new->add_range($max + 1, $MAX_UNICODE_CODEPOINT);
4061 # Returns a new Range_List with the argument deleted from it. The
4062 # argument can be a single code point, a range, or something that has
4063 # a range, with the _range_list() method on it returning them
4067 my $reversed = shift;
4068 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4071 Carp::my_carp_bug("Can't cope with a "
4073 . " being the second parameter in a '-'. Subtraction ignored.");
4077 my $new = Range_List->new(Initialize => $self);
4079 if (! ref $other) { # Single code point
4080 $new->delete_range($other, $other);
4082 elsif ($other->isa('Range')) {
4083 $new->delete_range($other->start, $other->end);
4085 elsif ($other->can('_range_list')) {
4086 foreach my $range ($other->_range_list->ranges) {
4087 $new->delete_range($range->start, $range->end);
4091 Carp::my_carp_bug("Can't cope with a "
4093 . " argument to '-'. Subtraction ignored."
4102 # Returns either a boolean giving whether the two inputs' range lists
4103 # intersect (overlap), or a new Range_List containing the intersection
4104 # of the two lists. The optional final parameter being true indicates
4105 # to do the check instead of the intersection.
4107 my $a_object = shift;
4108 my $b_object = shift;
4109 my $check_if_overlapping = shift;
4110 $check_if_overlapping = 0 unless defined $check_if_overlapping;
4111 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4113 if (! defined $b_object) {
4115 $message .= $a_object->_owner_name_of if defined $a_object;
4116 Carp::my_carp_bug($message .= "Called with undefined value. Intersection not done.");
4120 # a & b = !(!a | !b), or in our terminology = ~ ( ~a + -b )
4121 # Thus the intersection could be much more simply be written:
4122 # return ~(~$a_object + ~$b_object);
4123 # But, this is slower, and when taking the inverse of a large
4124 # range_size_1 table, back when such tables were always stored that
4125 # way, it became prohibitively slow, hence the code was changed to the
4128 if ($b_object->isa('Range')) {
4129 $b_object = Range_List->new(Initialize => $b_object,
4130 Owner => $a_object->_owner_name_of);
4132 $b_object = $b_object->_range_list if $b_object->can('_range_list');
4134 my @a_ranges = $a_object->ranges;
4135 my @b_ranges = $b_object->ranges;
4137 #local $to_trace = 1 if main::DEBUG;
4138 trace "intersecting $a_object with ", scalar @a_ranges, "ranges and $b_object with", scalar @b_ranges, " ranges" if main::DEBUG && $to_trace;
4140 # Start with the first range in each list
4142 my $range_a = $a_ranges[$a_i];
4144 my $range_b = $b_ranges[$b_i];
4146 my $new = __PACKAGE__->new(Owner => $a_object->_owner_name_of)
4147 if ! $check_if_overlapping;
4149 # If either list is empty, there is no intersection and no overlap
4150 if (! defined $range_a || ! defined $range_b) {
4151 return $check_if_overlapping ? 0 : $new;
4153 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
4155 # Otherwise, must calculate the intersection/overlap. Start with the
4156 # very first code point in each list
4157 my $a = $range_a->start;
4158 my $b = $range_b->start;
4160 # Loop through all the ranges of each list; in each iteration, $a and
4161 # $b are the current code points in their respective lists
4164 # If $a and $b are the same code point, ...
4167 # it means the lists overlap. If just checking for overlap
4168 # know the answer now,
4169 return 1 if $check_if_overlapping;
4171 # The intersection includes this code point plus anything else
4172 # common to both current ranges.
4174 my $end = main::min($range_a->end, $range_b->end);
4175 if (! $check_if_overlapping) {
4176 trace "adding intersection range ", sprintf("%04X", $start) . ".." . sprintf("%04X", $end) if main::DEBUG && $to_trace;
4177 $new->add_range($start, $end);
4180 # Skip ahead to the end of the current intersect
4183 # If the current intersect ends at the end of either range (as
4184 # it must for at least one of them), the next possible one
4185 # will be the beginning code point in it's list's next range.
4186 if ($a == $range_a->end) {
4187 $range_a = $a_ranges[++$a_i];
4188 last unless defined $range_a;
4189 $a = $range_a->start;
4191 if ($b == $range_b->end) {
4192 $range_b = $b_ranges[++$b_i];
4193 last unless defined $range_b;
4194 $b = $range_b->start;
4197 trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace;
4201 # Not equal, but if the range containing $a encompasses $b,
4202 # change $a to be the middle of the range where it does equal
4203 # $b, so the next iteration will get the intersection
4204 if ($range_a->end >= $b) {
4209 # Here, the current range containing $a is entirely below
4210 # $b. Go try to find a range that could contain $b.
4211 $a_i = $a_object->_search_ranges($b);
4213 # If no range found, quit.
4214 last unless defined $a_i;
4216 # The search returns $a_i, such that
4217 # range_a[$a_i-1]->end < $b <= range_a[$a_i]->end
4218 # Set $a to the beginning of this new range, and repeat.
4219 $range_a = $a_ranges[$a_i];
4220 $a = $range_a->start;
4223 else { # Here, $b < $a.
4225 # Mirror image code to the leg just above
4226 if ($range_b->end >= $a) {
4230 $b_i = $b_object->_search_ranges($a);
4231 last unless defined $b_i;
4232 $range_b = $b_ranges[$b_i];
4233 $b = $range_b->start;
4236 } # End of looping through ranges.
4238 # Intersection fully computed, or now know that there is no overlap
4239 return $check_if_overlapping ? 0 : $new;
4243 # Returns boolean giving whether the two arguments overlap somewhere
4247 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4249 return $self->_intersect($other, 1);
4253 # Add a range to the list.
4258 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4260 return $self->_add_delete('+', $start, $end, "");
4263 sub matches_identically_to {
4264 # Return a boolean as to whether or not two Range_Lists match identical
4265 # sets of code points.
4269 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4271 # These are ordered in increasing real time to figure out (at least
4272 # until a patch changes that and doesn't change this)
4273 return 0 if $self->max != $other->max;
4274 return 0 if $self->min != $other->min;
4275 return 0 if $self->range_count != $other->range_count;
4276 return 0 if $self->count != $other->count;
4278 # Here they could be identical because all the tests above passed.
4279 # The loop below is somewhat simpler since we know they have the same
4280 # number of elements. Compare range by range, until reach the end or
4281 # find something that differs.
4282 my @a_ranges = $self->ranges;
4283 my @b_ranges = $other->ranges;
4284 for my $i (0 .. @a_ranges - 1) {
4285 my $a = $a_ranges[$i];
4286 my $b = $b_ranges[$i];
4287 trace "self $a; other $b" if main::DEBUG && $to_trace;
4288 return 0 if ! defined $b
4289 || $a->start != $b->start
4290 || $a->end != $b->end;
4295 sub is_code_point_usable {
4296 # This used only for making the test script. See if the input
4297 # proposed trial code point is one that Perl will handle. If second
4298 # parameter is 0, it won't select some code points for various
4299 # reasons, noted below.
4302 my $try_hard = shift;
4303 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4305 return 0 if $code < 0; # Never use a negative
4307 # shun null. I'm (khw) not sure why this was done, but NULL would be
4308 # the character very frequently used.
4309 return $try_hard if $code == 0x0000;
4311 # shun non-character code points.
4312 return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF;
4313 return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF
4315 return $try_hard if $code > $MAX_UNICODE_CODEPOINT; # keep in range
4316 return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate
4321 sub get_valid_code_point {
4322 # Return a code point that's part of the range list. Returns nothing
4323 # if the table is empty or we can't find a suitable code point. This
4324 # used only for making the test script.
4327 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4329 my $addr = do { no overloading; pack 'J', $self; };
4331 # On first pass, don't choose less desirable code points; if no good
4332 # one is found, repeat, allowing a less desirable one to be selected.
4333 for my $try_hard (0, 1) {
4335 # Look through all the ranges for a usable code point.
4336 for my $set ($self->ranges) {
4338 # Try the edge cases first, starting with the end point of the
4340 my $end = $set->end;
4341 return $end if is_code_point_usable($end, $try_hard);
4343 # End point didn't, work. Start at the beginning and try
4344 # every one until find one that does work.
4345 for my $trial ($set->start .. $end - 1) {
4346 return $trial if is_code_point_usable($trial, $try_hard);
4350 return (); # If none found, give up.
4353 sub get_invalid_code_point {
4354 # Return a code point that's not part of the table. Returns nothing
4355 # if the table covers all code points or a suitable code point can't
4356 # be found. This used only for making the test script.
4359 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4361 # Just find a valid code point of the inverse, if any.
4362 return Range_List->new(Initialize => ~ $self)->get_valid_code_point;
4364 } # end closure for Range_List
4367 use base '_Range_List_Base';
4369 # A Range_Map is a range list in which the range values (called maps) are
4370 # significant, and hence shouldn't be manipulated by our other code, which
4371 # could be ambiguous or lose things. For example, in taking the union of two
4372 # lists, which share code points, but which have differing values, which one
4373 # has precedence in the union?
4374 # It turns out that these operations aren't really necessary for map tables,
4375 # and so this class was created to make sure they aren't accidentally
4381 # Add a range containing a mapping value to the list
4384 # Rest of parameters passed on
4386 return $self->_add_delete('+', @_);
4390 # Adds entry to a range list which can duplicate an existing entry
4393 my $code_point = shift;
4395 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4397 return $self->add_map($code_point, $code_point,
4398 $value, Replace => $MULTIPLE);
4400 } # End of closure for package Range_Map
4402 package _Base_Table;
4404 # A table is the basic data structure that gets written out into a file for
4405 # use by the Perl core. This is the abstract base class implementing the
4406 # common elements from the derived ones. A list of the methods to be
4407 # furnished by an implementing class is just after the constructor.
4409 sub standardize { return main::standardize($_[0]); }
4410 sub trace { return main::trace(@_); }
4414 main::setup_package();
4417 # Object containing the ranges of the table.
4418 main::set_access('range_list', \%range_list, 'p_r', 'p_s');
4421 # The full table name.
4422 main::set_access('full_name', \%full_name, 'r');
4425 # The table name, almost always shorter
4426 main::set_access('name', \%name, 'r');
4429 # The shortest of all the aliases for this table, with underscores removed
4430 main::set_access('short_name', \%short_name);
4432 my %nominal_short_name_length;
4433 # The length of short_name before removing underscores
4434 main::set_access('nominal_short_name_length',
4435 \%nominal_short_name_length);
4438 # The complete name, including property.
4439 main::set_access('complete_name', \%complete_name, 'r');
4442 # Parent property this table is attached to.
4443 main::set_access('property', \%property, 'r');
4446 # Ordered list of alias objects of the table's name. The first ones in
4447 # the list are output first in comments
4448 main::set_access('aliases', \%aliases, 'readable_array');
4451 # A comment associated with the table for human readers of the files
4452 main::set_access('comment', \%comment, 's');
4455 # A comment giving a short description of the table's meaning for human
4456 # readers of the files.
4457 main::set_access('description', \%description, 'readable_array');
4460 # A comment giving a short note about the table for human readers of the
4462 main::set_access('note', \%note, 'readable_array');
4465 # Boolean; if set this table is for internal core Perl only use.
4466 main::set_access('internal_only', \%internal_only, 'r');
4468 my %find_table_from_alias;
4469 # The parent property passes this pointer to a hash which this class adds
4470 # all its aliases to, so that the parent can quickly take an alias and
4472 main::set_access('find_table_from_alias', \%find_table_from_alias, 'p_r');
4475 # After this table is made equivalent to another one; we shouldn't go
4476 # changing the contents because that could mean it's no longer equivalent
4477 main::set_access('locked', \%locked, 'r');
4480 # This gives the final path to the file containing the table. Each
4481 # directory in the path is an element in the array
4482 main::set_access('file_path', \%file_path, 'readable_array');
4485 # What is the table's status, normal, $OBSOLETE, etc. Enum
4486 main::set_access('status', \%status, 'r');
4489 # A comment about its being obsolete, or whatever non normal status it has
4490 main::set_access('status_info', \%status_info, 'r');
4492 my %caseless_equivalent;
4493 # The table this is equivalent to under /i matching, if any.
4494 main::set_access('caseless_equivalent', \%caseless_equivalent, 'r', 's');
4497 # Is the table to be output with each range only a single code point?
4498 # This is done to avoid breaking existing code that may have come to rely
4499 # on this behavior in previous versions of this program.)
4500 main::set_access('range_size_1', \%range_size_1, 'r', 's');
4503 # A boolean set iff this table is a Perl extension to the Unicode
4505 main::set_access('perl_extension', \%perl_extension, 'r');
4507 my %output_range_counts;
4508 # A boolean set iff this table is to have comments written in the
4509 # output file that contain the number of code points in the range.
4510 # The constructor can override the global flag of the same name.
4511 main::set_access('output_range_counts', \%output_range_counts, 'r');
4514 # The format of the entries of the table. This is calculated from the
4515 # data in the table (or passed in the constructor). This is an enum e.g.,
4517 main::set_access('format', \%format, 'r', 'p_s');
4520 # All arguments are key => value pairs, which you can see below, most
4521 # of which match fields documented above. Otherwise: Pod_Entry,
4522 # Externally_Ok, and Fuzzy apply to the names of the table, and are
4523 # documented in the Alias package
4525 return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2;
4529 my $self = bless \do { my $anonymous_scalar }, $class;
4530 my $addr = do { no overloading; pack 'J', $self; };
4534 $name{$addr} = delete $args{'Name'};
4535 $find_table_from_alias{$addr} = delete $args{'_Alias_Hash'};
4536 $full_name{$addr} = delete $args{'Full_Name'};
4537 my $complete_name = $complete_name{$addr}
4538 = delete $args{'Complete_Name'};
4539 $format{$addr} = delete $args{'Format'};
4540 $internal_only{$addr} = delete $args{'Internal_Only'} || 0;
4541 $output_range_counts{$addr} = delete $args{'Output_Range_Counts'};
4542 $property{$addr} = delete $args{'_Property'};
4543 $range_list{$addr} = delete $args{'_Range_List'};
4544 $status{$addr} = delete $args{'Status'} || $NORMAL;
4545 $status_info{$addr} = delete $args{'_Status_Info'} || "";
4546 $range_size_1{$addr} = delete $args{'Range_Size_1'} || 0;
4547 $caseless_equivalent{$addr} = delete $args{'Caseless_Equivalent'} || 0;
4549 my $description = delete $args{'Description'};
4550 my $externally_ok = delete $args{'Externally_Ok'};
4551 my $loose_match = delete $args{'Fuzzy'};
4552 my $note = delete $args{'Note'};
4553 my $make_pod_entry = delete $args{'Pod_Entry'};
4554 my $perl_extension = delete $args{'Perl_Extension'};
4556 # Shouldn't have any left over
4557 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4559 # Can't use || above because conceivably the name could be 0, and
4560 # can't use // operator in case this program gets used in Perl 5.8
4561 $full_name{$addr} = $name{$addr} if ! defined $full_name{$addr};
4562 $output_range_counts{$addr} = $output_range_counts if
4563 ! defined $output_range_counts{$addr};
4565 $aliases{$addr} = [ ];
4566 $comment{$addr} = [ ];
4567 $description{$addr} = [ ];
4569 $file_path{$addr} = [ ];
4570 $locked{$addr} = "";
4572 push @{$description{$addr}}, $description if $description;
4573 push @{$note{$addr}}, $note if $note;
4575 if ($status{$addr} eq $PLACEHOLDER) {
4577 # A placeholder table doesn't get documented, is a perl extension,
4578 # and quite likely will be empty
4579 $make_pod_entry = 0 if ! defined $make_pod_entry;
4580 $perl_extension = 1 if ! defined $perl_extension;
4581 push @tables_that_may_be_empty, $complete_name{$addr};
4583 elsif (! $status{$addr}) {
4585 # If hasn't set its status already, see if it is on one of the
4586 # lists of properties or tables that have particular statuses; if
4587 # not, is normal. The lists are prioritized so the most serious
4588 # ones are checked first
4589 if (exists $why_suppressed{$complete_name}
4590 # Don't suppress if overridden
4591 && ! grep { $_ eq $complete_name{$addr} }
4592 @output_mapped_properties)
4594 $status{$addr} = $SUPPRESSED;
4596 elsif (exists $why_deprecated{$complete_name}) {
4597 $status{$addr} = $DEPRECATED;
4599 elsif (exists $why_stabilized{$complete_name}) {
4600 $status{$addr} = $STABILIZED;
4602 elsif (exists $why_obsolete{$complete_name}) {
4603 $status{$addr} = $OBSOLETE;
4606 # Existence above doesn't necessarily mean there is a message
4607 # associated with it. Use the most serious message.
4608 if ($status{$addr}) {
4609 if ($why_suppressed{$complete_name}) {
4611 = $why_suppressed{$complete_name};
4613 elsif ($why_deprecated{$complete_name}) {
4615 = $why_deprecated{$complete_name};
4617 elsif ($why_stabilized{$complete_name}) {
4619 = $why_stabilized{$complete_name};
4621 elsif ($why_obsolete{$complete_name}) {
4623 = $why_obsolete{$complete_name};
4628 $perl_extension{$addr} = $perl_extension || 0;
4630 # Don't list a property by default that is internal only
4631 $make_pod_entry = 0 if ! defined $make_pod_entry
4632 && $name{$addr} =~ /^_/;
4634 # By convention what typically gets printed only or first is what's
4635 # first in the list, so put the full name there for good output
4636 # clarity. Other routines rely on the full name being first on the
4638 $self->add_alias($full_name{$addr},
4639 Externally_Ok => $externally_ok,
4640 Fuzzy => $loose_match,
4641 Pod_Entry => $make_pod_entry,
4642 Status => $status{$addr},
4645 # Then comes the other name, if meaningfully different.
4646 if (standardize($full_name{$addr}) ne standardize($name{$addr})) {
4647 $self->add_alias($name{$addr},
4648 Externally_Ok => $externally_ok,
4649 Fuzzy => $loose_match,
4650 Pod_Entry => $make_pod_entry,
4651 Status => $status{$addr},
4658 # Here are the methods that are required to be defined by any derived
4661 handle_special_range
4665 # write() knows how to write out normal ranges, but it calls
4666 # handle_special_range() when it encounters a non-normal one.
4667 # append_to_body() is called by it after it has handled all
4668 # ranges to add anything after the main portion of the table.
4669 # And finally, pre_body() is called after all this to build up
4670 # anything that should appear before the main portion of the
4671 # table. Doing it this way allows things in the middle to
4672 # affect what should appear before the main portion of the
4677 Carp::my_carp_bug( __LINE__
4678 . ": Must create method '$sub()' for "
4686 "." => \&main::_operator_dot,
4687 '!=' => \&main::_operator_not_equal,
4688 '==' => \&main::_operator_equal,
4692 # Returns the array of ranges associated with this table.
4695 return $range_list{pack 'J', shift}->ranges;
4699 # Add a synonym for this table.
4701 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
4704 my $name = shift; # The name to add.
4705 my $pointer = shift; # What the alias hash should point to. For
4706 # map tables, this is the parent property;
4707 # for match tables, it is the table itself.
4710 my $loose_match = delete $args{'Fuzzy'};
4712 my $make_pod_entry = delete $args{'Pod_Entry'};
4713 $make_pod_entry = $YES unless defined $make_pod_entry;
4715 my $externally_ok = delete $args{'Externally_Ok'};
4716 $externally_ok = 1 unless defined $externally_ok;
4718 my $status = delete $args{'Status'};
4719 $status = $NORMAL unless defined $status;
4721 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
4723 # Capitalize the first letter of the alias unless it is one of the CJK
4724 # ones which specifically begins with a lower 'k'. Do this because
4725 # Unicode has varied whether they capitalize first letters or not, and
4726 # have later changed their minds and capitalized them, but not the
4727 # other way around. So do it always and avoid changes from release to
4729 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
4731 my $addr = do { no overloading; pack 'J', $self; };
4733 # Figure out if should be loosely matched if not already specified.
4734 if (! defined $loose_match) {
4736 # Is a loose_match if isn't null, and doesn't begin with an
4737 # underscore and isn't just a number
4739 && substr($name, 0, 1) ne '_'
4740 && $name !~ qr{^[0-9_.+-/]+$})
4749 # If this alias has already been defined, do nothing.
4750 return if defined $find_table_from_alias{$addr}->{$name};
4752 # That includes if it is standardly equivalent to an existing alias,
4753 # in which case, add this name to the list, so won't have to search
4755 my $standard_name = main::standardize($name);
4756 if (defined $find_table_from_alias{$addr}->{$standard_name}) {
4757 $find_table_from_alias{$addr}->{$name}
4758 = $find_table_from_alias{$addr}->{$standard_name};
4762 # Set the index hash for this alias for future quick reference.
4763 $find_table_from_alias{$addr}->{$name} = $pointer;
4764 $find_table_from_alias{$addr}->{$standard_name} = $pointer;
4765 local $to_trace = 0 if main::DEBUG;
4766 trace "adding alias $name to $pointer" if main::DEBUG && $to_trace;
4767 trace "adding alias $standard_name to $pointer" if main::DEBUG && $to_trace;
4770 # Put the new alias at the end of the list of aliases unless the final
4771 # element begins with an underscore (meaning it is for internal perl
4772 # use) or is all numeric, in which case, put the new one before that
4773 # one. This floats any all-numeric or underscore-beginning aliases to
4774 # the end. This is done so that they are listed last in output lists,
4775 # to encourage the user to use a better name (either more descriptive
4776 # or not an internal-only one) instead. This ordering is relied on
4777 # implicitly elsewhere in this program, like in short_name()
4778 my $list = $aliases{$addr};
4779 my $insert_position = (@$list == 0
4780 || (substr($list->[-1]->name, 0, 1) ne '_'
4781 && $list->[-1]->name =~ /\D/))
4787 Alias->new($name, $loose_match, $make_pod_entry,
4788 $externally_ok, $status);
4790 # This name may be shorter than any existing ones, so clear the cache
4791 # of the shortest, so will have to be recalculated.
4793 undef $short_name{pack 'J', $self};
4798 # Returns a name suitable for use as the base part of a file name.
4799 # That is, shorter wins. It can return undef if there is no suitable
4800 # name. The name has all non-essential underscores removed.
4802 # The optional second parameter is a reference to a scalar in which
4803 # this routine will store the length the returned name had before the
4804 # underscores were removed, or undef if the return is undef.
4806 # The shortest name can change if new aliases are added. So using
4807 # this should be deferred until after all these are added. The code
4808 # that does that should clear this one's cache.
4809 # Any name with alphabetics is preferred over an all numeric one, even
4813 my $nominal_length_ptr = shift;
4814 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4816 my $addr = do { no overloading; pack 'J', $self; };
4818 # For efficiency, don't recalculate, but this means that adding new
4819 # aliases could change what the shortest is, so the code that does
4820 # that needs to undef this.
4821 if (defined $short_name{$addr}) {
4822 if ($nominal_length_ptr) {
4823 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4825 return $short_name{$addr};
4828 # Look at each alias
4829 foreach my $alias ($self->aliases()) {
4831 # Don't use an alias that isn't ok to use for an external name.
4832 next if ! $alias->externally_ok;
4834 my $name = main::Standardize($alias->name);
4835 trace $self, $name if main::DEBUG && $to_trace;
4837 # Take the first one, or a shorter one that isn't numeric. This
4838 # relies on numeric aliases always being last in the array
4839 # returned by aliases(). Any alpha one will have precedence.
4840 if (! defined $short_name{$addr}
4842 && length($name) < length($short_name{$addr})))
4844 # Remove interior underscores.
4845 ($short_name{$addr} = $name) =~ s/ (?<= . ) _ (?= . ) //xg;
4847 $nominal_short_name_length{$addr} = length $name;
4851 # If the short name isn't a nice one, perhaps an equivalent table has
4853 if (! defined $short_name{$addr}
4854 || $short_name{$addr} eq ""
4855 || $short_name{$addr} eq "_")
4858 foreach my $follower ($self->children) { # All equivalents
4859 my $follower_name = $follower->short_name;
4860 next unless defined $follower_name;
4862 # Anything (except undefined) is better than underscore or
4864 if (! defined $return || $return eq "_") {
4865 $return = $follower_name;
4869 # If the new follower name isn't "_" and is shorter than the
4870 # current best one, prefer the new one.
4871 next if $follower_name eq "_";
4872 next if length $follower_name > length $return;
4873 $return = $follower_name;
4875 $short_name{$addr} = $return if defined $return;
4878 # If no suitable external name return undef
4879 if (! defined $short_name{$addr}) {
4880 $$nominal_length_ptr = undef if $nominal_length_ptr;
4884 # Don't allow a null short name.
4885 if ($short_name{$addr} eq "") {
4886 $short_name{$addr} = '_';
4887 $nominal_short_name_length{$addr} = 1;
4890 trace $self, $short_name{$addr} if main::DEBUG && $to_trace;
4892 if ($nominal_length_ptr) {
4893 $$nominal_length_ptr = $nominal_short_name_length{$addr};
4895 return $short_name{$addr};
4899 # Returns the external name that this table should be known by. This
4900 # is usually the short_name, but not if the short_name is undefined,
4901 # in which case the external_name is arbitrarily set to the
4905 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4907 my $short = $self->short_name;
4908 return $short if defined $short;
4913 sub add_description { # Adds the parameter as a short description.
4916 my $description = shift;
4918 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4921 push @{$description{pack 'J', $self}}, $description;
4926 sub add_note { # Adds the parameter as a short note.
4931 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4934 push @{$note{pack 'J', $self}}, $note;
4939 sub add_comment { # Adds the parameter as a comment.
4941 return unless $debugging_build;
4944 my $comment = shift;
4945 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4950 push @{$comment{pack 'J', $self}}, $comment;
4956 # Return the current comment for this table. If called in list
4957 # context, returns the array of comments. In scalar, returns a string
4958 # of each element joined together with a period ending each.
4961 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4963 my $addr = do { no overloading; pack 'J', $self; };
4964 my @list = @{$comment{$addr}};
4965 return @list if wantarray;
4967 foreach my $sentence (@list) {
4968 $return .= '. ' if $return;
4969 $return .= $sentence;
4972 $return .= '.' if $return;
4977 # Initialize the table with the argument which is any valid
4978 # initialization for range lists.
4981 my $addr = do { no overloading; pack 'J', $self; };
4982 my $initialization = shift;
4983 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
4985 # Replace the current range list with a new one of the same exact
4987 my $class = ref $range_list{$addr};
4988 $range_list{$addr} = $class->new(Owner => $self,
4989 Initialize => $initialization);
4995 # The header that is output for the table in the file it is written
4999 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5002 $return .= $DEVELOPMENT_ONLY if $compare_versions;
5008 # Write a representation of the table to its file. It calls several
5009 # functions furnished by sub-classes of this abstract base class to
5010 # handle non-normal ranges, to add stuff before the table, and at its
5014 my $tab_stops = shift; # The number of tab stops over to put any
5016 my $suppress_value = shift; # Optional, if the value associated with
5017 # a range equals this one, don't write
5019 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5021 my $addr = do { no overloading; pack 'J', $self; };
5023 # Start with the header
5024 my @HEADER = $self->header;
5027 push @HEADER, "\n", main::simple_fold($comment{$addr}, '# '), "\n"
5030 # Things discovered processing the main body of the document may
5031 # affect what gets output before it, therefore pre_body() isn't called
5032 # until after all other processing of the table is done.
5034 # The main body looks like a 'here' document. If annotating, get rid
5035 # of the comments before passing to the caller, as some callers, such
5036 # as charnames.pm, can't cope with them. (Outputting range counts
5037 # also introduces comments, but these don't show up in the tables that
5038 # can't cope with comments, and there aren't that many of them that
5039 # it's worth the extra real time to get rid of them).
5042 # Use the line below in Perls that don't have /r
5043 #push @OUT, 'return join "\n", map { s/\s*#.*//mg; $_ } split "\n", <<\'END\';' . "\n";
5044 push @OUT, "return <<'END' =~ s/\\s*#.*//mgr;\n";
5046 push @OUT, "return <<'END';\n";
5049 if ($range_list{$addr}->is_empty) {
5051 # This is a kludge for empty tables to silence a warning in
5052 # utf8.c, which can't really deal with empty tables, but it can
5053 # deal with a table that matches nothing, as the inverse of 'Any'
5055 push @OUT, "!utf8::Any\n";
5057 elsif ($self->name eq 'N'
5059 # To save disk space and table cache space, avoid putting out
5060 # binary N tables, but instead create a file which just inverts
5061 # the Y table. Since the file will still exist and occupy a
5062 # certain number of blocks, might as well output the whole
5063 # thing if it all will fit in one block. The number of
5064 # ranges below is an approximate number for that.
5065 && ($self->property->type == $BINARY
5066 || $self->property->type == $FORCED_BINARY)
5067 # && $self->property->tables == 2 Can't do this because the
5068 # non-binary properties, like NFDQC aren't specifiable
5070 && $range_list{$addr}->ranges > 15
5071 && ! $annotate) # Under --annotate, want to see everything
5073 push @OUT, "!utf8::" . $self->property->name . "\n";
5076 my $range_size_1 = $range_size_1{$addr};
5077 my $format; # Used only in $annotate option
5078 my $include_name; # Used only in $annotate option
5082 # if annotating each code point, must print 1 per line.
5083 # The variable could point to a subroutine, and we don't want
5084 # to lose that fact, so only set if not set already
5085 $range_size_1 = 1 if ! $range_size_1;
5087 $format = $self->format;
5089 # The name of the character is output only for tables that
5090 # don't already include the name in the output.
5091 my $property = $self->property;
5093 ! ($property == $perl_charname
5094 || $property == main::property_ref('Unicode_1_Name')
5095 || $property == main::property_ref('Name')
5096 || $property == main::property_ref('Name_Alias')
5100 # Output each range as part of the here document.
5102 for my $set ($range_list{$addr}->ranges) {
5103 if ($set->type != 0) {
5104 $self->handle_special_range($set);
5107 my $start = $set->start;
5108 my $end = $set->end;
5109 my $value = $set->value;
5111 # Don't output ranges whose value is the one to suppress
5112 next RANGE if defined $suppress_value
5113 && $value eq $suppress_value;
5115 # If there is a range and doesn't need a single point range
5117 if ($start != $end && ! $range_size_1) {
5118 push @OUT, sprintf "%04X\t%04X", $start, $end;
5119 $OUT[-1] .= "\t$value" if $value ne "";
5121 # Add a comment with the size of the range, if requested.
5122 # Expand Tabs to make sure they all start in the same
5123 # column, and then unexpand to use mostly tabs.
5124 if (! $output_range_counts{$addr}) {
5128 $OUT[-1] = Text::Tabs::expand($OUT[-1]);
5129 my $count = main::clarify_number($end - $start + 1);
5132 my $width = $tab_stops * 8 - 1;
5133 $OUT[-1] = sprintf("%-*s # [%s]\n",
5137 $OUT[-1] = Text::Tabs::unexpand($OUT[-1]);
5142 # Here to output a single code point per line
5144 # If not to annotate, use the simple formats
5147 # Use any passed in subroutine to output.
5148 if (ref $range_size_1 eq 'CODE') {
5149 for my $i ($start .. $end) {
5150 push @OUT, &{$range_size_1}($i, $value);
5155 # Here, caller is ok with default output.
5156 for (my $i = $start; $i <= $end; $i++) {
5157 push @OUT, sprintf "%04X\t\t%s\n", $i, $value;
5163 # Here, wants annotation.
5164 for (my $i = $start; $i <= $end; $i++) {
5166 # Get character information if don't have it already
5167 main::populate_char_info($i)
5168 if ! defined $viacode[$i];
5169 my $type = $annotate_char_type[$i];
5171 # Figure out if should output the next code points as part
5172 # of a range or not. If this is not in an annotation
5173 # range, then won't output as a range, so returns $i.
5174 # Otherwise use the end of the annotation range, but no
5175 # further than the maximum possible end point of the loop.
5176 my $range_end = main::min($annotate_ranges->value_of($i)
5180 # Use a range if it is a range, and either is one of the
5181 # special annotation ranges, or the range is at most 3
5182 # long. This last case causes the algorithmically named
5183 # code points to be output individually in spans of at
5184 # most 3, as they are the ones whose $type is > 0.
5185 if ($range_end != $i
5186 && ( $type < 0 || $range_end - $i > 2))
5188 # Here is to output a range. We don't allow a
5189 # caller-specified output format--just use the
5191 push @OUT, sprintf "%04X\t%04X\t%s\t#", $i,
5194 my $range_name = $viacode[$i];
5196 # For the code points which end in their hex value, we
5197 # eliminate that from the output annotation, and
5198 # capitalize only the first letter of each word.
5199 if ($type == $CP_IN_NAME) {
5200 my $hex = sprintf "%04X", $i;
5201 $range_name =~ s/-$hex$//;
5202 my @words = split " ", $range_name;
5203 for my $word (@words) {
5204 $word = ucfirst(lc($word)) if $word ne 'CJK';
5206 $range_name = join " ", @words;
5208 elsif ($type == $HANGUL_SYLLABLE) {
5209 $range_name = "Hangul Syllable";
5212 $OUT[-1] .= " $range_name" if $range_name;
5214 # Include the number of code points in the range
5215 my $count = main::clarify_number($range_end - $i + 1);
5216 $OUT[-1] .= " [$count]\n";
5218 # Skip to the end of the range
5221 else { # Not in a range.
5224 # When outputting the names of each character, use
5225 # the character itself if printable
5226 $comment .= "'" . chr($i) . "' " if $printable[$i];
5228 # To make it more readable, use a minimum indentation
5231 # Determine the annotation
5232 if ($format eq $DECOMP_STRING_FORMAT) {
5234 # This is very specialized, with the type of
5235 # decomposition beginning the line enclosed in
5236 # <...>, and the code points that the code point
5237 # decomposes to separated by blanks. Create two
5238 # strings, one of the printable characters, and
5239 # one of their official names.
5240 (my $map = $value) =~ s/ \ * < .*? > \ +//x;
5244 foreach my $to (split " ", $map) {
5245 $to = CORE::hex $to;
5246 $to_name .= " + " if $to_name;
5247 $to_chr .= chr($to);
5248 main::populate_char_info($to)
5249 if ! defined $viacode[$to];
5250 $to_name .= $viacode[$to];
5254 "=> '$to_chr'; $viacode[$i] => $to_name";
5255 $comment_indent = 25; # Determined by experiment
5259 # Assume that any table that has hex format is a
5260 # mapping of one code point to another.
5261 if ($format eq $HEX_FORMAT) {
5262 my $decimal_value = CORE::hex $value;
5263 main::populate_char_info($decimal_value)
5264 if ! defined $viacode[$decimal_value];
5266 . chr($decimal_value)
5267 . "'; " if $printable[$decimal_value];
5269 $comment .= $viacode[$i] if $include_name
5271 if ($format eq $HEX_FORMAT) {
5272 my $decimal_value = CORE::hex $value;
5273 $comment .= " => $viacode[$decimal_value]"
5274 if $viacode[$decimal_value];
5277 # If including the name, no need to indent, as the
5278 # name will already be way across the line.
5279 $comment_indent = ($include_name) ? 0 : 60;
5282 # Use any passed in routine to output the base part of
5284 if (ref $range_size_1 eq 'CODE') {
5285 my $base_part = &{$range_size_1}($i, $value);
5287 push @OUT, $base_part;
5290 push @OUT, sprintf "%04X\t\t%s", $i, $value;
5293 # And add the annotation.
5294 $OUT[-1] = sprintf "%-*s\t# %s", $comment_indent,
5296 $comment if $comment;
5300 } # End of loop through all the table's ranges
5303 # Add anything that goes after the main body, but within the here
5305 my $append_to_body = $self->append_to_body;
5306 push @OUT, $append_to_body if $append_to_body;
5308 # And finish the here document.
5311 # Done with the main portion of the body. Can now figure out what
5312 # should appear before it in the file.
5313 my $pre_body = $self->pre_body;
5314 push @HEADER, $pre_body, "\n" if $pre_body;
5316 # All these files should have a .pl suffix added to them.
5317 my @file_with_pl = @{$file_path{$addr}};
5318 $file_with_pl[-1] .= '.pl';
5320 main::write(\@file_with_pl,
5321 $annotate, # utf8 iff annotating
5327 sub set_status { # Set the table's status
5329 my $status = shift; # The status enum value
5330 my $info = shift; # Any message associated with it.
5331 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5333 my $addr = do { no overloading; pack 'J', $self; };
5335 $status{$addr} = $status;
5336 $status_info{$addr} = $info;
5341 # Don't allow changes to the table from now on. This stores a stack
5342 # trace of where it was called, so that later attempts to modify it
5343 # can immediately show where it got locked.
5346 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5348 my $addr = do { no overloading; pack 'J', $self; };
5350 $locked{$addr} = "";
5352 my $line = (caller(0))[2];
5355 # Accumulate the stack trace
5357 my ($pkg, $file, $caller_line, $caller) = caller $i++;
5359 last unless defined $caller;
5361 $locked{$addr} .= " called from $caller() at line $line\n";
5362 $line = $caller_line;
5364 $locked{$addr} .= " called from main at line $line\n";
5369 sub carp_if_locked {
5370 # Return whether a table is locked or not, and, by the way, complain
5374 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5376 my $addr = do { no overloading; pack 'J', $self; };
5378 return 0 if ! $locked{$addr};
5379 Carp::my_carp_bug("Can't modify a locked table. Stack trace of locking:\n$locked{$addr}\n\n");
5383 sub set_file_path { # Set the final directory path for this table
5385 # Rest of parameters passed on
5388 @{$file_path{pack 'J', $self}} = @_;
5392 # Accessors for the range list stored in this table. First for
5401 matches_identically_to
5414 return $self->_range_list->$sub(@_);
5418 # Then for ones that should fail if locked
5428 return if $self->carp_if_locked;
5430 return $self->_range_list->$sub(@_);
5437 use base '_Base_Table';
5439 # A Map Table is a table that contains the mappings from code points to
5440 # values. There are two weird cases:
5441 # 1) Anomalous entries are ones that aren't maps of ranges of code points, but
5442 # are written in the table's file at the end of the table nonetheless. It
5443 # requires specially constructed code to handle these; utf8.c can not read
5444 # these in, so they should not go in $map_directory. As of this writing,
5445 # the only case that these happen is for named sequences used in
5446 # charnames.pm. But this code doesn't enforce any syntax on these, so
5447 # something else could come along that uses it.
5448 # 2) Specials are anything that doesn't fit syntactically into the body of the
5449 # table. The ranges for these have a map type of non-zero. The code below
5450 # knows about and handles each possible type. In most cases, these are
5451 # written as part of the header.
5453 # A map table deliberately can't be manipulated at will unlike match tables.
5454 # This is because of the ambiguities having to do with what to do with
5455 # overlapping code points. And there just isn't a need for those things;
5456 # what one wants to do is just query, add, replace, or delete mappings, plus
5457 # write the final result.
5458 # However, there is a method to get the list of possible ranges that aren't in
5459 # this table to use for defaulting missing code point mappings. And,
5460 # map_add_or_replace_non_nulls() does allow one to add another table to this
5461 # one, but it is clearly very specialized, and defined that the other's
5462 # non-null values replace this one's if there is any overlap.
5464 sub trace { return main::trace(@_); }
5468 main::setup_package();
5471 # Many input files omit some entries; this gives what the mapping for the
5472 # missing entries should be
5473 main::set_access('default_map', \%default_map, 'r');
5475 my %anomalous_entries;
5476 # Things that go in the body of the table which don't fit the normal
5477 # scheme of things, like having a range. Not much can be done with these
5478 # once there except to output them. This was created to handle named
5480 main::set_access('anomalous_entry', \%anomalous_entries, 'a');
5481 main::set_access('anomalous_entries', # Append singular, read plural
5482 \%anomalous_entries,
5486 # This is a string, solely for documentation, indicating how one can get
5487 # access to this property via the Perl core.
5488 main::set_access('core_access', \%core_access, 'r', 's');
5491 # Enum as to whether or not to write out this map table:
5493 # $EXTERNAL_MAP means its existence is noted in the documentation, and
5494 # it should not be removed nor its format changed. This
5495 # is done for those files that have traditionally been
5497 # $INTERNAL_MAP means Perl reserves the right to do anything it wants
5499 main::set_access('to_output_map', \%to_output_map, 's');
5508 # Optional initialization data for the table.
5509 my $initialize = delete $args{'Initialize'};
5511 my $core_access = delete $args{'Core_Access'};
5512 my $default_map = delete $args{'Default_Map'};
5513 my $property = delete $args{'_Property'};
5514 my $full_name = delete $args{'Full_Name'};
5516 # Rest of parameters passed on
5518 my $range_list = Range_Map->new(Owner => $property);
5520 my $self = $class->SUPER::new(
5522 Complete_Name => $full_name,
5523 Full_Name => $full_name,
5524 _Property => $property,
5525 _Range_List => $range_list,
5528 my $addr = do { no overloading; pack 'J', $self; };
5530 $anomalous_entries{$addr} = [];
5531 $core_access{$addr} = $core_access;
5532 $default_map{$addr} = $default_map;
5534 $self->initialize($initialize) if defined $initialize;
5541 qw("") => "_operator_stringify",
5544 sub _operator_stringify {
5547 my $name = $self->property->full_name;
5548 $name = '""' if $name eq "";
5549 return "Map table for Property '$name'";
5553 # Add a synonym for this table (which means the property itself)
5556 # Rest of parameters passed on.
5558 $self->SUPER::add_alias($name, $self->property, @_);
5563 # Add a range of code points to the list of specially-handled code
5564 # points. $MULTI_CP is assumed if the type of special is not passed
5573 my $type = delete $args{'Type'} || 0;
5574 # Rest of parameters passed on
5576 # Can't change the table if locked.
5577 return if $self->carp_if_locked;
5579 my $addr = do { no overloading; pack 'J', $self; };
5581 $self->_range_list->add_map($lower, $upper,
5588 sub append_to_body {
5589 # Adds to the written HERE document of the table's body any anomalous
5590 # entries in the table..
5593 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5595 my $addr = do { no overloading; pack 'J', $self; };
5597 return "" unless @{$anomalous_entries{$addr}};
5598 return join("\n", @{$anomalous_entries{$addr}}) . "\n";
5601 sub map_add_or_replace_non_nulls {
5602 # This adds the mappings in the table $other to $self. Non-null
5603 # mappings from $other override those in $self. It essentially merges
5604 # the two tables, with the second having priority except for null
5609 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5611 return if $self->carp_if_locked;
5613 if (! $other->isa(__PACKAGE__)) {
5614 Carp::my_carp_bug("$other should be a "
5622 my $addr = do { no overloading; pack 'J', $self; };
5623 my $other_addr = do { no overloading; pack 'J', $other; };
5625 local $to_trace = 0 if main::DEBUG;
5627 my $self_range_list = $self->_range_list;
5628 my $other_range_list = $other->_range_list;
5629 foreach my $range ($other_range_list->ranges) {
5630 my $value = $range->value;
5631 next if $value eq "";
5632 $self_range_list->_add_delete('+',
5636 Type => $range->type,
5637 Replace => $UNCONDITIONALLY);
5643 sub set_default_map {
5644 # Define what code points that are missing from the input files should
5649 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5651 my $addr = do { no overloading; pack 'J', $self; };
5653 # Convert the input to the standard equivalent, if any (won't have any
5654 # for $STRING properties)
5655 my $standard = $self->_find_table_from_alias->{$map};
5656 $map = $standard->name if defined $standard;
5658 # Warn if there already is a non-equivalent default map for this
5659 # property. Note that a default map can be a ref, which means that
5660 # what it actually means is delayed until later in the program, and it
5661 # IS permissible to override it here without a message.
5662 my $default_map = $default_map{$addr};
5663 if (defined $default_map
5664 && ! ref($default_map)
5665 && $default_map ne $map
5666 && main::Standardize($map) ne $default_map)
5668 my $property = $self->property;
5669 my $map_table = $property->table($map);
5670 my $default_table = $property->table($default_map);
5671 if (defined $map_table
5672 && defined $default_table
5673 && $map_table != $default_table)
5675 Carp::my_carp("Changing the default mapping for "
5677 . " from $default_map to $map'");
5681 $default_map{$addr} = $map;
5683 # Don't also create any missing table for this map at this point,
5684 # because if we did, it could get done before the main table add is
5685 # done for PropValueAliases.txt; instead the caller will have to make
5686 # sure it exists, if desired.
5691 # Returns boolean: should we write this map table?
5694 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5696 my $addr = do { no overloading; pack 'J', $self; };
5698 # If overridden, use that
5699 return $to_output_map{$addr} if defined $to_output_map{$addr};
5701 my $full_name = $self->full_name;
5702 return $global_to_output_map{$full_name}
5703 if defined $global_to_output_map{$full_name};
5705 # If table says to output, do so; if says to suppress it, do so.
5706 return $INTERNAL_MAP if $self->internal_only;
5707 return $EXTERNAL_MAP if grep { $_ eq $full_name } @output_mapped_properties;
5708 return 0 if $self->status eq $SUPPRESSED;
5710 my $type = $self->property->type;
5712 # Don't want to output binary map tables even for debugging.
5713 return 0 if $type == $BINARY;
5715 # But do want to output string ones.
5716 return $EXTERNAL_MAP if $type == $STRING;
5718 # Otherwise is an $ENUM, do output it, for Perl's purposes
5719 return $INTERNAL_MAP;
5723 # Returns a Range_List that is gaps of the current table. That is,
5727 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5729 my $current = Range_List->new(Initialize => $self->_range_list,
5730 Owner => $self->property);
5736 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5738 my $return = $self->SUPER::header();
5740 $return .= $INTERNAL_ONLY if $self->to_output_map == $INTERNAL_MAP;
5744 sub set_final_comment {
5745 # Just before output, create the comment that heads the file
5746 # containing this table.
5748 return unless $debugging_build;
5751 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5753 # No sense generating a comment if aren't going to write it out.
5754 return if ! $self->to_output_map;
5756 my $addr = do { no overloading; pack 'J', $self; };
5758 my $property = $self->property;
5760 # Get all the possible names for this property. Don't use any that
5761 # aren't ok for use in a file name, etc. This is perhaps causing that
5762 # flag to do double duty, and may have to be changed in the future to
5763 # have our own flag for just this purpose; but it works now to exclude
5764 # Perl generated synonyms from the lists for properties, where the
5765 # name is always the proper Unicode one.
5766 my @property_aliases = grep { $_->externally_ok } $self->aliases;
5768 my $count = $self->count;
5769 my $default_map = $default_map{$addr};
5771 # The ranges that map to the default aren't output, so subtract that
5772 # to get those actually output. A property with matching tables
5773 # already has the information calculated.
5774 if ($property->type != $STRING) {
5775 $count -= $property->table($default_map)->count;
5777 elsif (defined $default_map) {
5779 # But for $STRING properties, must calculate now. Subtract the
5780 # count from each range that maps to the default.
5781 foreach my $range ($self->_range_list->ranges) {
5782 if ($range->value eq $default_map) {
5783 $count -= $range->end +1 - $range->start;
5789 # Get a string version of $count with underscores in large numbers,
5791 my $string_count = main::clarify_number($count);
5793 my $code_points = ($count == 1)
5794 ? 'single code point'
5795 : "$string_count code points";
5800 if (@property_aliases <= 1) {
5801 $mapping = 'mapping';
5802 $these_mappings = 'this mapping';
5806 $mapping = 'synonymous mappings';
5807 $these_mappings = 'these mappings';
5811 if ($count >= $MAX_UNICODE_CODEPOINTS) {
5812 $cp = "any code point in Unicode Version $string_version";
5816 if ($default_map eq "") {
5817 $map_to = 'the null string';
5819 elsif ($default_map eq $CODE_POINT) {
5823 $map_to = "'$default_map'";
5826 $cp = "the single code point";
5829 $cp = "one of the $code_points";
5831 $cp .= " in Unicode Version $string_version for which the mapping is not to $map_to";
5836 my $status = $self->status;
5838 my $warn = uc $status_past_participles{$status};
5841 !!!!!!! $warn !!!!!!!!!!!!!!!!!!!
5842 All property or property=value combinations contained in this file are $warn.
5843 See $unicode_reference_url for what this means.
5847 $comment .= "This file returns the $mapping:\n";
5849 for my $i (0 .. @property_aliases - 1) {
5850 $comment .= sprintf("%-8s%s\n",
5852 $property_aliases[$i]->name . '(cp)'
5856 "\nwhere 'cp' is $cp. Note that $these_mappings $are ";
5858 my $access = $core_access{$addr};
5860 $comment .= "accessible through the Perl core via $access.";
5863 $comment .= "not accessible through the Perl core directly.";
5866 # And append any commentary already set from the actual property.
5867 $comment .= "\n\n" . $self->comment if $self->comment;
5868 if ($self->description) {
5869 $comment .= "\n\n" . join " ", $self->description;
5872 $comment .= "\n\n" . join " ", $self->note;
5876 if (! $self->perl_extension) {
5879 For information about what this property really means, see:
5880 $unicode_reference_url
5884 if ($count) { # Format differs for empty table
5885 $comment.= "\nThe format of the ";
5886 if ($self->range_size_1) {
5888 main body of lines of this file is: CODE_POINT\\t\\tMAPPING where CODE_POINT
5889 is in hex; MAPPING is what CODE_POINT maps to.
5894 # There are tables which end up only having one element per
5895 # range, but it is not worth keeping track of for making just
5896 # this comment a little better.
5898 non-comment portions of the main body of lines of this file is:
5899 START\\tSTOP\\tMAPPING where START is the starting code point of the
5900 range, in hex; STOP is the ending point, or if omitted, the range has just one
5901 code point; MAPPING is what each code point between START and STOP maps to.
5903 if ($self->output_range_counts) {
5905 Numbers in comments in [brackets] indicate how many code points are in the
5906 range (omitted when the range is a single code point or if the mapping is to
5912 $self->set_comment(main::join_lines($comment));
5916 my %swash_keys; # Makes sure don't duplicate swash names.
5918 # The remaining variables are temporaries used while writing each table,
5919 # to output special ranges.
5920 my @multi_code_point_maps; # Map is to more than one code point.
5922 sub handle_special_range {
5923 # Called in the middle of write when it finds a range it doesn't know
5928 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
5930 my $addr = do { no overloading; pack 'J', $self; };
5932 my $type = $range->type;
5934 my $low = $range->start;
5935 my $high = $range->end;
5936 my $map = $range->value;
5938 # No need to output the range if it maps to the default.
5939 return if $map eq $default_map{$addr};
5941 my $property = $self->property;
5943 # Switch based on the map type...
5944 if ($type == $HANGUL_SYLLABLE) {
5946 # These are entirely algorithmically determinable based on
5947 # some constants furnished by Unicode; for now, just set a
5948 # flag to indicate that have them. After everything is figured
5949 # out, we will output the code that does the algorithm. (Don't
5950 # output them if not needed because we are suppressing this
5952 $has_hangul_syllables = 1 if $property->to_output_map;
5954 elsif ($type == $CP_IN_NAME) {
5956 # Code points whose name ends in their code point are also
5957 # algorithmically determinable, but need information about the map
5958 # to do so. Both the map and its inverse are stored in data
5959 # structures output in the file. They are stored in the mean time
5960 # in global lists The lists will be written out later into Name.pm,
5961 # which is created only if needed. In order to prevent duplicates
5962 # in the list, only add to them for one property, should multiple
5964 if ($needing_code_points_ending_in_code_point == 0) {
5965 $needing_code_points_ending_in_code_point = $property;
5967 if ($property == $needing_code_points_ending_in_code_point) {
5968 push @{$names_ending_in_code_point{$map}->{'low'}}, $low;
5969 push @{$names_ending_in_code_point{$map}->{'high'}}, $high;
5971 my $squeezed = $map =~ s/[-\s]+//gr;
5972 push @{$loose_names_ending_in_code_point{$squeezed}->{'low'}},
5974 push @{$loose_names_ending_in_code_point{$squeezed}->{'high'}},
5977 push @code_points_ending_in_code_point, { low => $low,
5983 elsif ($range->type == $MULTI_CP || $range->type == $NULL) {
5985 # Multi-code point maps and null string maps have an entry
5986 # for each code point in the range. They use the same
5988 for my $code_point ($low .. $high) {
5990 # The pack() below can't cope with surrogates. XXX This may
5992 if ($code_point >= 0xD800 && $code_point <= 0xDFFF) {
5993 Carp::my_carp("Surrogate code point '$code_point' in mapping to '$map' in $self. No map created");
5997 # Generate the hash entries for these in the form that
5998 # utf8.c understands.
6002 foreach my $to (split " ", $map) {
6003 if ($to !~ /^$code_point_re$/) {
6004 Carp::my_carp("Illegal code point '$to' in mapping '$map' from $code_point in $self. No map created");
6007 $tostr .= sprintf "\\x{%s}", $to;
6008 $to = CORE::hex $to;
6010 $to_name .= " + " if $to_name;
6011 $to_chr .= chr($to);
6012 main::populate_char_info($to)
6013 if ! defined $viacode[$to];
6014 $to_name .= $viacode[$to];
6018 # I (khw) have never waded through this line to
6019 # understand it well enough to comment it.
6020 my $utf8 = sprintf(qq["%s" => "$tostr",],
6021 join("", map { sprintf "\\x%02X", $_ }
6022 unpack("U0C*", pack("U", $code_point))));
6024 # Add a comment so that a human reader can more easily
6025 # see what's going on.
6026 push @multi_code_point_maps,
6027 sprintf("%-45s # U+%04X", $utf8, $code_point);
6029 $multi_code_point_maps[-1] .= " => $map";
6032 main::populate_char_info($code_point)
6033 if ! defined $viacode[$code_point];
6034 $multi_code_point_maps[-1] .= " '"
6036 . "' => '$to_chr'; $viacode[$code_point] => $to_name";
6041 Carp::my_carp("Unrecognized map type '$range->type' in '$range' in $self. Not written");
6048 # Returns the string that should be output in the file before the main
6049 # body of this table. It isn't called until the main body is
6050 # calculated, saving a pass. The string includes some hash entries
6051 # identifying the format of the body, and what the single value should
6052 # be for all ranges missing from it. It also includes any code points
6053 # which have map_types that don't go in the main table.
6056 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6058 my $addr = do { no overloading; pack 'J', $self; };
6060 my $name = $self->property->swash_name;
6062 if (defined $swash_keys{$name}) {
6063 Carp::my_carp(join_lines(<<END
6064 Already created a swash name '$name' for $swash_keys{$name}. This means that
6065 the same name desired for $self shouldn't be used. Bad News. This must be
6066 fixed before production use, but proceeding anyway
6070 $swash_keys{$name} = "$self";
6074 # Here we assume we were called after have gone through the whole
6075 # file. If we actually generated anything for each map type, add its
6076 # respective header and trailer
6077 my $specials_name = "";
6078 if (@multi_code_point_maps) {
6079 $specials_name = "utf8::ToSpec$name";
6082 # Some code points require special handling because their mappings are each to
6083 # multiple code points. These do not appear in the main body, but are defined
6084 # in the hash below.
6086 # Each key is the string of N bytes that together make up the UTF-8 encoding
6087 # for the code point. (i.e. the same as looking at the code point's UTF-8
6088 # under "use bytes"). Each value is the UTF-8 of the translation, for speed.
6089 \%$specials_name = (
6091 $pre_body .= join("\n", @multi_code_point_maps) . "\n);\n";
6094 my $format = $self->format;
6097 # The name this swash is to be known by, with the format of the mappings in
6098 # the main body of the table, and what all code points missing from this file
6100 \$utf8::SwashInfo{'To$name'}{'format'} = '$format'; # $map_table_formats{$format}
6102 if ($specials_name) {
6104 \$utf8::SwashInfo{'To$name'}{'specials_name'} = '$specials_name'; # Name of hash of special mappings
6107 my $default_map = $default_map{$addr};
6108 $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '$default_map';";
6110 if ($default_map eq $CODE_POINT) {
6111 $return .= ' # code point maps to itself';
6113 elsif ($default_map eq "") {
6114 $return .= ' # code point maps to the null string';
6118 $return .= $pre_body;
6124 # Write the table to the file.
6127 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6129 my $addr = do { no overloading; pack 'J', $self; };
6131 # Clear the temporaries
6132 undef @multi_code_point_maps;
6134 # Calculate the format of the table if not already done.
6135 my $format = $self->format;
6136 my $type = $self->property->type;
6137 my $default_map = $self->default_map;
6138 if (! defined $format) {
6139 if ($type == $BINARY) {
6141 # Don't bother checking the values, because we elsewhere
6142 # verify that a binary table has only 2 values.
6143 $format = $BINARY_FORMAT;
6146 my @ranges = $self->_range_list->ranges;
6148 # default an empty table based on its type and default map
6151 # But it turns out that the only one we can say is a
6152 # non-string (besides binary, handled above) is when the
6153 # table is a string and the default map is to a code point
6154 if ($type == $STRING && $default_map eq $CODE_POINT) {
6155 $format = $HEX_FORMAT;
6158 $format = $STRING_FORMAT;
6163 # Start with the most restrictive format, and as we find
6164 # something that doesn't fit with that, change to the next
6165 # most restrictive, and so on.
6166 $format = $DECIMAL_FORMAT;
6167 foreach my $range (@ranges) {
6168 next if $range->type != 0; # Non-normal ranges don't
6169 # affect the main body
6170 my $map = $range->value;
6171 if ($map ne $default_map) {
6172 last if $format eq $STRING_FORMAT; # already at
6175 $format = $INTEGER_FORMAT
6176 if $format eq $DECIMAL_FORMAT
6177 && $map !~ / ^ [0-9] $ /x;
6178 $format = $FLOAT_FORMAT
6179 if $format eq $INTEGER_FORMAT
6180 && $map !~ / ^ -? [0-9]+ $ /x;
6181 $format = $RATIONAL_FORMAT
6182 if $format eq $FLOAT_FORMAT
6183 && $map !~ / ^ -? [0-9]+ \. [0-9]* $ /x;
6184 $format = $HEX_FORMAT
6185 if $format eq $RATIONAL_FORMAT
6186 && $map !~ / ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x;
6187 $format = $STRING_FORMAT if $format eq $HEX_FORMAT
6188 && $map =~ /[^0-9A-F]/;
6193 } # end of calculating format
6195 if ($default_map eq $CODE_POINT
6196 && $format ne $HEX_FORMAT
6197 && ! defined $self->format) # manual settings are always
6200 Carp::my_carp_bug("Expecting hex format for mapping table for $self, instead got '$format'")
6203 $self->_set_format($format);
6205 # Core Perl has a different definition of mapping ranges than we do,
6206 # that is applicable mainly to mapping code points, so for tables
6207 # where it is possible that core Perl could be used to read it,
6208 # make it range size 1 to prevent possible confusion
6209 $self->set_range_size_1(1) if $format eq $HEX_FORMAT;
6211 return $self->SUPER::write(
6212 ($self->property == $block)
6213 ? 7 # block file needs more tab stops
6215 $default_map); # don't write defaulteds
6218 # Accessors for the underlying list that should fail if locked.
6228 return if $self->carp_if_locked;
6229 return $self->_range_list->$sub(@_);
6232 } # End closure for Map_Table
6234 package Match_Table;
6235 use base '_Base_Table';
6237 # A Match table is one which is a list of all the code points that have
6238 # the same property and property value, for use in \p{property=value}
6239 # constructs in regular expressions. It adds very little data to the base
6240 # structure, but many methods, as these lists can be combined in many ways to
6242 # There are only a few concepts added:
6243 # 1) Equivalents and Relatedness.
6244 # Two tables can match the identical code points, but have different names.
6245 # This always happens when there is a perl single form extension
6246 # \p{IsProperty} for the Unicode compound form \P{Property=True}. The two
6247 # tables are set to be related, with the Perl extension being a child, and
6248 # the Unicode property being the parent.
6250 # It may be that two tables match the identical code points and we don't
6251 # know if they are related or not. This happens most frequently when the
6252 # Block and Script properties have the exact range. But note that a
6253 # revision to Unicode could add new code points to the script, which would
6254 # now have to be in a different block (as the block was filled, or there
6255 # would have been 'Unknown' script code points in it and they wouldn't have
6256 # been identical). So we can't rely on any two properties from Unicode
6257 # always matching the same code points from release to release, and thus
6258 # these tables are considered coincidentally equivalent--not related. When
6259 # two tables are unrelated but equivalent, one is arbitrarily chosen as the
6260 # 'leader', and the others are 'equivalents'. This concept is useful
6261 # to minimize the number of tables written out. Only one file is used for
6262 # any identical set of code points, with entries in Heavy.pl mapping all
6263 # the involved tables to it.
6265 # Related tables will always be identical; we set them up to be so. Thus
6266 # if the Unicode one is deprecated, the Perl one will be too. Not so for
6267 # unrelated tables. Relatedness makes generating the documentation easier.
6270 # Like equivalents, two tables may be the inverses of each other, the
6271 # intersection between them is null, and the union is every Unicode code
6272 # point. The two tables that occupy a binary property are necessarily like
6273 # this. By specifying one table as the complement of another, we can avoid
6274 # storing it on disk (using the other table and performing a fast
6275 # transform), and some memory and calculations.
6277 # 3) Conflicting. It may be that there will eventually be name clashes, with
6278 # the same name meaning different things. For a while, there actually were
6279 # conflicts, but they have so far been resolved by changing Perl's or
6280 # Unicode's definitions to match the other, but when this code was written,
6281 # it wasn't clear that that was what was going to happen. (Unicode changed
6282 # because of protests during their beta period.) Name clashes are warned
6283 # about during compilation, and the documentation. The generated tables
6284 # are sane, free of name clashes, because the code suppresses the Perl
6285 # version. But manual intervention to decide what the actual behavior
6286 # should be may be required should this happen. The introductory comments
6287 # have more to say about this.
6289 sub standardize { return main::standardize($_[0]); }
6290 sub trace { return main::trace(@_); }
6295 main::setup_package();
6298 # The leader table of this one; initially $self.
6299 main::set_access('leader', \%leader, 'r');
6302 # An array of any tables that have this one as their leader
6303 main::set_access('equivalents', \%equivalents, 'readable_array');
6306 # The parent table to this one, initially $self. This allows us to
6307 # distinguish between equivalent tables that are related (for which this
6308 # is set to), and those which may not be, but share the same output file
6309 # because they match the exact same set of code points in the current
6311 main::set_access('parent', \%parent, 'r');
6314 # An array of any tables that have this one as their parent
6315 main::set_access('children', \%children, 'readable_array');
6318 # Array of any tables that would have the same name as this one with
6319 # a different meaning. This is used for the generated documentation.
6320 main::set_access('conflicting', \%conflicting, 'readable_array');
6323 # Set in the constructor for tables that are expected to match all code
6325 main::set_access('matches_all', \%matches_all, 'r');
6328 # Points to the complement that this table is expressed in terms of; 0 if
6330 main::set_access('complement', \%complement, 'r');
6337 # The property for which this table is a listing of property values.
6338 my $property = delete $args{'_Property'};
6340 my $name = delete $args{'Name'};
6341 my $full_name = delete $args{'Full_Name'};
6342 $full_name = $name if ! defined $full_name;
6345 my $initialize = delete $args{'Initialize'};
6346 my $matches_all = delete $args{'Matches_All'} || 0;
6347 my $format = delete $args{'Format'};
6348 # Rest of parameters passed on.
6350 my $range_list = Range_List->new(Initialize => $initialize,
6351 Owner => $property);
6353 my $complete = $full_name;
6354 $complete = '""' if $complete eq ""; # A null name shouldn't happen,
6355 # but this helps debug if it
6357 # The complete name for a match table includes it's property in a
6358 # compound form 'property=table', except if the property is the
6359 # pseudo-property, perl, in which case it is just the single form,
6360 # 'table' (If you change the '=' must also change the ':' in lots of
6361 # places in this program that assume an equal sign)
6362 $complete = $property->full_name . "=$complete" if $property != $perl;
6364 my $self = $class->SUPER::new(%args,
6366 Complete_Name => $complete,
6367 Full_Name => $full_name,
6368 _Property => $property,
6369 _Range_List => $range_list,
6370 Format => $EMPTY_FORMAT,
6372 my $addr = do { no overloading; pack 'J', $self; };
6374 $conflicting{$addr} = [ ];
6375 $equivalents{$addr} = [ ];
6376 $children{$addr} = [ ];
6377 $matches_all{$addr} = $matches_all;
6378 $leader{$addr} = $self;
6379 $parent{$addr} = $self;
6380 $complement{$addr} = 0;
6382 if (defined $format && $format ne $EMPTY_FORMAT) {
6383 Carp::my_carp_bug("'Format' must be '$EMPTY_FORMAT' in a match table instead of '$format'. Using '$EMPTY_FORMAT'");
6389 # See this program's beginning comment block about overloading these.
6392 qw("") => "_operator_stringify",
6396 return if $self->carp_if_locked;
6404 return $self->_range_list + $other;
6410 return $self->_range_list & $other;
6416 return if $self->carp_if_locked;
6418 my $addr = do { no overloading; pack 'J', $self; };
6422 # Change the range list of this table to be the
6424 $self->_set_range_list($self->_range_list
6427 else { # $other is just a simple value
6428 $self->add_range($other, $other);
6432 '-' => sub { my $self = shift;
6434 my $reversed = shift;
6437 Carp::my_carp_bug("Can't cope with a "
6439 . " being the first parameter in a '-'. Subtraction ignored.");
6443 return $self->_range_list - $other;
6445 '~' => sub { my $self = shift;
6446 return ~ $self->_range_list;
6450 sub _operator_stringify {
6453 my $name = $self->complete_name;
6454 return "Table '$name'";
6458 # Returns the range list associated with this table, which will be the
6459 # complement's if it has one.
6463 if (($complement = $self->complement) != 0) {
6464 return ~ $complement->_range_list;
6467 return $self->SUPER::_range_list;
6472 # Add a synonym for this table. See the comments in the base class
6476 # Rest of parameters passed on.
6478 $self->SUPER::add_alias($name, $self, @_);
6482 sub add_conflicting {
6483 # Add the name of some other object to the list of ones that name
6484 # clash with this match table.
6487 my $conflicting_name = shift; # The name of the conflicting object
6488 my $p = shift || 'p'; # Optional, is this a \p{} or \P{} ?
6489 my $conflicting_object = shift; # Optional, the conflicting object
6490 # itself. This is used to
6491 # disambiguate the text if the input
6492 # name is identical to any of the
6493 # aliases $self is known by.
6494 # Sometimes the conflicting object is
6495 # merely hypothetical, so this has to
6496 # be an optional parameter.
6497 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6499 my $addr = do { no overloading; pack 'J', $self; };
6501 # Check if the conflicting name is exactly the same as any existing
6502 # alias in this table (as long as there is a real object there to
6503 # disambiguate with).
6504 if (defined $conflicting_object) {
6505 foreach my $alias ($self->aliases) {
6506 if ($alias->name eq $conflicting_name) {
6508 # Here, there is an exact match. This results in
6509 # ambiguous comments, so disambiguate by changing the
6510 # conflicting name to its object's complete equivalent.
6511 $conflicting_name = $conflicting_object->complete_name;
6517 # Convert to the \p{...} final name
6518 $conflicting_name = "\\$p" . "{$conflicting_name}";
6521 return if grep { $conflicting_name eq $_ } @{$conflicting{$addr}};
6523 push @{$conflicting{$addr}}, $conflicting_name;
6528 sub is_set_equivalent_to {
6529 # Return boolean of whether or not the other object is a table of this
6530 # type and has been marked equivalent to this one.
6534 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6536 return 0 if ! defined $other; # Can happen for incomplete early
6538 unless ($other->isa(__PACKAGE__)) {
6539 my $ref_other = ref $other;
6540 my $ref_self = ref $self;
6541 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.");
6545 # Two tables are equivalent if they have the same leader.
6547 return $leader{pack 'J', $self} == $leader{pack 'J', $other};
6551 sub set_equivalent_to {
6552 # Set $self equivalent to the parameter table.
6553 # The required Related => 'x' parameter is a boolean indicating
6554 # whether these tables are related or not. If related, $other becomes
6555 # the 'parent' of $self; if unrelated it becomes the 'leader'
6557 # Related tables share all characteristics except names; equivalents
6558 # not quite so many.
6559 # If they are related, one must be a perl extension. This is because
6560 # we can't guarantee that Unicode won't change one or the other in a
6561 # later release even if they are identical now.
6567 my $related = delete $args{'Related'};
6569 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
6571 return if ! defined $other; # Keep on going; happens in some early
6574 if (! defined $related) {
6575 Carp::my_carp_bug("set_equivalent_to must have 'Related => [01] parameter. Assuming $self is not related to $other");
6579 # If already are equivalent, no need to re-do it; if subroutine
6580 # returns null, it found an error, also do nothing
6581 my $are_equivalent = $self->is_set_equivalent_to($other);
6582 return if ! defined $are_equivalent || $are_equivalent;
6584 my $addr = do { no overloading; pack 'J', $self; };
6585 my $current_leader = ($related) ? $parent{$addr} : $leader{$addr};
6588 if ($current_leader->perl_extension) {
6589 if ($other->perl_extension) {
6590 Carp::my_carp_bug("Use add_alias() to set two Perl tables '$self' and '$other', equivalent.");
6593 } elsif ($self->property != $other->property # Depending on
6599 && ! $other->perl_extension)
6601 Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other");
6606 if (! $self->is_empty && ! $self->matches_identically_to($other)) {
6607 Carp::my_carp_bug("$self should be empty or match identically to $other. Not setting equivalent");
6611 my $leader = do { no overloading; pack 'J', $current_leader; };
6612 my $other_addr = do { no overloading; pack 'J', $other; };
6614 # Any tables that are equivalent to or children of this table must now
6615 # instead be equivalent to or (children) to the new leader (parent),
6616 # still equivalent. The equivalency includes their matches_all info,
6617 # and for related tables, their status
6618 # All related tables are of necessity equivalent, but the converse
6619 # isn't necessarily true
6620 my $status = $other->status;
6621 my $status_info = $other->status_info;
6622 my $matches_all = $matches_all{other_addr};
6623 my $caseless_equivalent = $other->caseless_equivalent;
6624 foreach my $table ($current_leader, @{$equivalents{$leader}}) {
6625 next if $table == $other;
6626 trace "setting $other to be the leader of $table, status=$status" if main::DEBUG && $to_trace;
6628 my $table_addr = do { no overloading; pack 'J', $table; };
6629 $leader{$table_addr} = $other;
6630 $matches_all{$table_addr} = $matches_all;
6631 $self->_set_range_list($other->_range_list);
6632 push @{$equivalents{$other_addr}}, $table;
6634 $parent{$table_addr} = $other;
6635 push @{$children{$other_addr}}, $table;
6636 $table->set_status($status, $status_info);
6637 $self->set_caseless_equivalent($caseless_equivalent);
6641 # Now that we've declared these to be equivalent, any changes to one
6642 # of the tables would invalidate that equivalency.
6648 sub set_complement {
6649 # Set $self to be the complement of the parameter table. $self is
6650 # locked, as what it contains should all come from the other table.
6656 Carp::carp_extra_args(\%args) if main::DEBUG && %args;
6658 if ($other->complement != 0) {
6659 Carp::my_carp_bug("Can't set $self to be the complement of $other, which itself is the complement of " . $other->complement);
6662 my $addr = do { no overloading; pack 'J', $self; };
6663 $complement{$addr} = $other;
6668 sub add_range { # Add a range to the list for this table.
6670 # Rest of parameters passed on
6672 return if $self->carp_if_locked;
6673 return $self->_range_list->add_range(@_);
6678 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6680 # All match tables are to be used only by the Perl core.
6681 return $self->SUPER::header() . $INTERNAL_ONLY;
6684 sub pre_body { # Does nothing for match tables.
6688 sub append_to_body { # Does nothing for match tables.
6694 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6696 return $self->SUPER::write(2); # 2 tab stops
6699 sub set_final_comment {
6700 # This creates a comment for the file that is to hold the match table
6701 # $self. It is somewhat convoluted to make the English read nicely,
6702 # but, heh, it's just a comment.
6703 # This should be called only with the leader match table of all the
6704 # ones that share the same file. It lists all such tables, ordered so
6705 # that related ones are together.
6707 return unless $debugging_build;
6709 my $leader = shift; # Should only be called on the leader table of
6710 # an equivalent group
6711 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
6713 my $addr = do { no overloading; pack 'J', $leader; };
6715 if ($leader{$addr} != $leader) {
6716 Carp::my_carp_bug(<<END
6717 set_final_comment() must be called on a leader table, which $leader is not.
6718 It is equivalent to $leader{$addr}. No comment created
6724 # Get the number of code points matched by each of the tables in this
6725 # file, and add underscores for clarity.
6726 my $count = $leader->count;
6727 my $string_count = main::clarify_number($count);
6729 my $loose_count = 0; # how many aliases loosely matched
6730 my $compound_name = ""; # ? Are any names compound?, and if so, an
6732 my $properties_with_compound_names = 0; # count of these
6735 my %flags; # The status flags used in the file
6736 my $total_entries = 0; # number of entries written in the comment
6737 my $matches_comment = ""; # The portion of the comment about the
6739 my @global_comments; # List of all the tables' comments that are
6740 # there before this routine was called.
6742 # Get list of all the parent tables that are equivalent to this one
6743 # (including itself).
6744 my @parents = grep { $parent{main::objaddr $_} == $_ }
6745 main::uniques($leader, @{$equivalents{$addr}});
6746 my $has_unrelated = (@parents >= 2); # boolean, ? are there unrelated
6749 for my $parent (@parents) {
6751 my $property = $parent->property;
6753 # Special case 'N' tables in properties with two match tables when
6754 # the other is a 'Y' one. These are likely to be binary tables,
6755 # but not necessarily. In either case, \P{} will match the
6756 # complement of \p{}, and so if something is a synonym of \p, the
6757 # complement of that something will be the synonym of \P. This
6758 # would be true of any property with just two match tables, not
6759 # just those whose values are Y and N; but that would require a
6760 # little extra work, and there are none such so far in Unicode.
6761 my $perl_p = 'p'; # which is it? \p{} or \P{}
6762 my @yes_perl_synonyms; # list of any synonyms for the 'Y' table
6764 if (scalar $property->tables == 2
6765 && $parent == $property->table('N')
6766 && defined (my $yes = $property->table('Y')))
6768 my $yes_addr = do { no overloading; pack 'J', $yes; };
6770 = grep { $_->property == $perl }
6773 $parent{$yes_addr}->children);
6775 # But these synonyms are \P{} ,not \p{}
6779 my @description; # Will hold the table description
6780 my @note; # Will hold the table notes.
6781 my @conflicting; # Will hold the table conflicts.
6783 # Look at the parent, any yes synonyms, and all the children
6784 my $parent_addr = do { no overloading; pack 'J', $parent; };
6785 for my $table ($parent,
6787 @{$children{$parent_addr}})
6789 my $table_addr = do { no overloading; pack 'J', $table; };
6790 my $table_property = $table->property;
6792 # Tables are separated by a blank line to create a grouping.
6793 $matches_comment .= "\n" if $matches_comment;
6795 # The table is named based on the property and value
6796 # combination it is for, like script=greek. But there may be
6797 # a number of synonyms for each side, like 'sc' for 'script',
6798 # and 'grek' for 'greek'. Any combination of these is a valid
6799 # name for this table. In this case, there are three more,
6800 # 'sc=grek', 'sc=greek', and 'script='grek'. Rather than
6801 # listing all possible combinations in the comment, we make
6802 # sure that each synonym occurs at least once, and add
6803 # commentary that the other combinations are possible.
6804 # Because regular expressions don't recognize things like
6805 # \p{jsn=}, only look at non-null right-hand-sides
6806 my @property_aliases = $table_property->aliases;
6807 my @table_aliases = grep { $_->name ne "" } $table->aliases;
6809 # The alias lists above are already ordered in the order we
6810 # want to output them. To ensure that each synonym is listed,
6811 # we must use the max of the two numbers. But if there are no
6812 # legal synonyms (nothing in @table_aliases), then we don't
6814 my $listed_combos = (@table_aliases)
6815 ? main::max(scalar @table_aliases,
6816 scalar @property_aliases)
6818 trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG;
6821 my $property_had_compound_name = 0;
6823 for my $i (0 .. $listed_combos - 1) {
6826 # The current alias for the property is the next one on
6827 # the list, or if beyond the end, start over. Similarly
6828 # for the table (\p{prop=table})
6829 my $property_alias = $property_aliases
6830 [$i % @property_aliases]->name;
6831 my $table_alias_object = $table_aliases
6832 [$i % @table_aliases];
6833 my $table_alias = $table_alias_object->name;
6834 my $loose_match = $table_alias_object->loose_match;
6836 if ($table_alias !~ /\D/) { # Clarify large numbers.
6837 $table_alias = main::clarify_number($table_alias)
6840 # Add a comment for this alias combination
6841 my $current_match_comment;
6842 if ($table_property == $perl) {
6843 $current_match_comment = "\\$perl_p"
6847 $current_match_comment
6848 = "\\p{$property_alias=$table_alias}";
6849 $property_had_compound_name = 1;
6852 # Flag any abnormal status for this table.
6853 my $flag = $property->status
6855 || $table_alias_object->status;
6857 if ($flag ne $PLACEHOLDER) {
6858 $flags{$flag} = $status_past_participles{$flag};
6860 $flags{$flag} = <<END;
6861 a placeholder because it is not in Version $string_version of Unicode, but is
6862 needed by the Perl core to work gracefully. Because it is not in this version
6863 of Unicode, it will not be listed in $pod_file.pod
6870 # Pretty up the comment. Note the \b; it says don't make
6871 # this line a continuation.
6872 $matches_comment .= sprintf("\b%-1s%-s%s\n",
6875 $current_match_comment);
6876 } # End of generating the entries for this table.
6878 # Save these for output after this group of related tables.
6879 push @description, $table->description;
6880 push @note, $table->note;
6881 push @conflicting, $table->conflicting;
6883 # And this for output after all the tables.
6884 push @global_comments, $table->comment;
6886 # Compute an alternate compound name using the final property
6887 # synonym and the first table synonym with a colon instead of
6888 # the equal sign used elsewhere.
6889 if ($property_had_compound_name) {
6890 $properties_with_compound_names ++;
6891 if (! $compound_name || @property_aliases > 1) {
6892 $compound_name = $property_aliases[-1]->name
6894 . $table_aliases[0]->name;
6897 } # End of looping through all children of this table
6899 # Here have assembled in $matches_comment all the related tables
6900 # to the current parent (preceded by the same info for all the
6901 # previous parents). Put out information that applies to all of
6902 # the current family.
6905 # But output the conflicting information now, as it applies to
6907 my $conflicting = join ", ", @conflicting;
6909 $matches_comment .= <<END;
6911 Note that contrary to what you might expect, the above is NOT the same as
6913 $matches_comment .= "any of: " if @conflicting > 1;
6914 $matches_comment .= "$conflicting\n";
6918 $matches_comment .= "\n Meaning: "
6919 . join('; ', @description)
6923 $matches_comment .= "\n Note: "
6924 . join("\n ", @note)
6927 } # End of looping through all tables
6935 $code_points = 'single code point';
6939 $code_points = "$string_count code points";
6944 if ($total_entries == 1) {
6947 $any_of_these = 'this'
6950 $synonyms = " any of the following regular expression constructs";
6951 $entries = 'entries';
6952 $any_of_these = 'any of these'
6956 if ($has_unrelated) {
6958 This file is for tables that are not necessarily related: To conserve
6959 resources, every table that matches the identical set of code points in this
6960 version of Unicode uses this file. Each one is listed in a separate group
6961 below. It could be that the tables will match the same set of code points in
6962 other Unicode releases, or it could be purely coincidence that they happen to
6963 be the same in Unicode $string_version, and hence may not in other versions.
6969 foreach my $flag (sort keys %flags) {
6971 '$flag' below means that this form is $flags{$flag}.
6973 next if $flag eq $PLACEHOLDER;
6974 $comment .= "Consult $pod_file.pod\n";
6979 if ($total_entries == 0) {
6980 Carp::my_carp("No regular expression construct can match $leader, as all names for it are the null string. Creating file anyway.");
6982 This file returns the $code_points in Unicode Version $string_version for
6983 $leader, but it is inaccessible through Perl regular expressions, as
6984 "\\p{prop=}" is not recognized.
6989 This file returns the $code_points in Unicode Version $string_version that
6993 $pod_file.pod should be consulted for the syntax rules for $any_of_these,
6994 including if adding or subtracting white space, underscore, and hyphen
6995 characters matters or doesn't matter, and other permissible syntactic
6996 variants. Upper/lower case distinctions never matter.
7000 if ($compound_name) {
7003 A colon can be substituted for the equals sign, and
7005 if ($properties_with_compound_names > 1) {
7007 within each group above,
7010 $compound_name = sprintf("%-8s\\p{%s}", " ", $compound_name);
7012 # Note the \b below, it says don't make that line a continuation.
7014 anything to the left of the equals (or colon) can be combined with anything to
7015 the right. Thus, for example,
7021 # And append any comment(s) from the actual tables. They are all
7022 # gathered here, so may not read all that well.
7023 if (@global_comments) {
7024 $comment .= "\n" . join("\n\n", @global_comments) . "\n";
7027 if ($count) { # The format differs if no code points, and needs no
7028 # explanation in that case
7031 The format of the lines of this file is:
7034 START\\tSTOP\\twhere START is the starting code point of the range, in hex;
7035 STOP is the ending point, or if omitted, the range has just one code point.
7037 if ($leader->output_range_counts) {
7039 Numbers in comments in [brackets] indicate how many code points are in the
7045 $leader->set_comment(main::join_lines($comment));
7049 # Accessors for the underlying list
7051 get_valid_code_point
7052 get_invalid_code_point
7060 return $self->_range_list->$sub(@_);
7063 } # End closure for Match_Table
7067 # The Property class represents a Unicode property, or the $perl
7068 # pseudo-property. It contains a map table initialized empty at construction
7069 # time, and for properties accessible through regular expressions, various
7070 # match tables, created through the add_match_table() method, and referenced
7071 # by the table('NAME') or tables() methods, the latter returning a list of all
7072 # of the match tables. Otherwise table operations implicitly are for the map
7075 # Most of the data in the property is actually about its map table, so it
7076 # mostly just uses that table's accessors for most methods. The two could
7077 # have been combined into one object, but for clarity because of their
7078 # differing semantics, they have been kept separate. It could be argued that
7079 # the 'file' and 'directory' fields should be kept with the map table.
7081 # Each property has a type. This can be set in the constructor, or in the
7082 # set_type accessor, but mostly it is figured out by the data. Every property
7083 # starts with unknown type, overridden by a parameter to the constructor, or
7084 # as match tables are added, or ranges added to the map table, the data is
7085 # inspected, and the type changed. After the table is mostly or entirely
7086 # filled, compute_type() should be called to finalize they analysis.
7088 # There are very few operations defined. One can safely remove a range from
7089 # the map table, and property_add_or_replace_non_nulls() adds the maps from another
7090 # table to this one, replacing any in the intersection of the two.
7092 sub standardize { return main::standardize($_[0]); }
7093 sub trace { return main::trace(@_) if main::DEBUG && $to_trace }
7097 # This hash will contain as keys, all the aliases of all properties, and
7098 # as values, pointers to their respective property objects. This allows
7099 # quick look-up of a property from any of its names.
7100 my %alias_to_property_of;
7102 sub dump_alias_to_property_of {
7105 print "\n", main::simple_dumper (\%alias_to_property_of), "\n";
7110 # This is a package subroutine, not called as a method.
7111 # If the single parameter is a literal '*' it returns a list of all
7112 # defined properties.
7113 # Otherwise, the single parameter is a name, and it returns a pointer
7114 # to the corresponding property object, or undef if none.
7116 # Properties can have several different names. The 'standard' form of
7117 # each of them is stored in %alias_to_property_of as they are defined.
7118 # But it's possible that this subroutine will be called with some
7119 # variant, so if the initial lookup fails, it is repeated with the
7120 # standardized form of the input name. If found, besides returning the
7121 # result, the input name is added to the list so future calls won't
7122 # have to do the conversion again.
7126 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7128 if (! defined $name) {
7129 Carp::my_carp_bug("Undefined input property. No action taken.");
7133 return main::uniques(values %alias_to_property_of) if $name eq '*';
7135 # Return cached result if have it.
7136 my $result = $alias_to_property_of{$name};
7137 return $result if defined $result;
7139 # Convert the input to standard form.
7140 my $standard_name = standardize($name);
7142 $result = $alias_to_property_of{$standard_name};
7143 return unless defined $result; # Don't cache undefs
7145 # Cache the result before returning it.
7146 $alias_to_property_of{$name} = $result;
7151 main::setup_package();
7154 # A pointer to the map table object for this property
7155 main::set_access('map', \%map);
7158 # The property's full name. This is a duplicate of the copy kept in the
7159 # map table, but is needed because stringify needs it during
7160 # construction of the map table, and then would have a chicken before egg
7162 main::set_access('full_name', \%full_name, 'r');
7165 # This hash will contain as keys, all the aliases of any match tables
7166 # attached to this property, and as values, the pointers to their
7167 # respective tables. This allows quick look-up of a table from any of its
7169 main::set_access('table_ref', \%table_ref);
7172 # The type of the property, $ENUM, $BINARY, etc
7173 main::set_access('type', \%type, 'r');
7176 # The filename where the map table will go (if actually written).
7177 # Normally defaulted, but can be overridden.
7178 main::set_access('file', \%file, 'r', 's');
7181 # The directory where the map table will go (if actually written).
7182 # Normally defaulted, but can be overridden.
7183 main::set_access('directory', \%directory, 's');
7185 my %pseudo_map_type;
7186 # This is used to affect the calculation of the map types for all the
7187 # ranges in the table. It should be set to one of the values that signify
7188 # to alter the calculation.
7189 main::set_access('pseudo_map_type', \%pseudo_map_type, 'r');
7191 my %has_only_code_point_maps;
7192 # A boolean used to help in computing the type of data in the map table.
7193 main::set_access('has_only_code_point_maps', \%has_only_code_point_maps);
7196 # A list of the first few distinct mappings this property has. This is
7197 # used to disambiguate between binary and enum property types, so don't
7198 # have to keep more than three.
7199 main::set_access('unique_maps', \%unique_maps);
7201 my %pre_declared_maps;
7202 # A boolean that gives whether the input data should declare all the
7203 # tables used, or not. If the former, unknown ones raise a warning.
7204 main::set_access('pre_declared_maps',
7205 \%pre_declared_maps, 'r', 's');
7208 # The only required parameter is the positionally first, name. All
7209 # other parameters are key => value pairs. See the documentation just
7210 # above for the meanings of the ones not passed directly on to the map
7211 # table constructor.
7214 my $name = shift || "";
7216 my $self = property_ref($name);
7217 if (defined $self) {
7218 my $options_string = join ", ", @_;
7219 $options_string = ". Ignoring options $options_string" if $options_string;
7220 Carp::my_carp("$self is already in use. Using existing one$options_string;");
7226 $self = bless \do { my $anonymous_scalar }, $class;
7227 my $addr = do { no overloading; pack 'J', $self; };
7229 $directory{$addr} = delete $args{'Directory'};
7230 $file{$addr} = delete $args{'File'};
7231 $full_name{$addr} = delete $args{'Full_Name'} || $name;
7232 $type{$addr} = delete $args{'Type'} || $UNKNOWN;
7233 $pseudo_map_type{$addr} = delete $args{'Map_Type'};
7234 $pre_declared_maps{$addr} = delete $args{'Pre_Declared_Maps'}
7235 # Starting in this release, property
7236 # values should be defined for all
7237 # properties, except those overriding this
7238 // $v_version ge v5.1.0;
7240 # Rest of parameters passed on.
7242 $has_only_code_point_maps{$addr} = 1;
7243 $table_ref{$addr} = { };
7244 $unique_maps{$addr} = { };
7246 $map{$addr} = Map_Table->new($name,
7247 Full_Name => $full_name{$addr},
7248 _Alias_Hash => \%alias_to_property_of,
7254 # See this program's beginning comment block about overloading the copy
7255 # constructor. Few operations are defined on properties, but a couple are
7256 # useful. It is safe to take the inverse of a property, and to remove a
7257 # single code point from it.
7260 qw("") => "_operator_stringify",
7261 "." => \&main::_operator_dot,
7262 '==' => \&main::_operator_equal,
7263 '!=' => \&main::_operator_not_equal,
7264 '=' => sub { return shift },
7265 '-=' => "_minus_and_equal",
7268 sub _operator_stringify {
7269 return "Property '" . shift->full_name . "'";
7272 sub _minus_and_equal {
7273 # Remove a single code point from the map table of a property.
7277 my $reversed = shift;
7278 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7281 Carp::my_carp_bug("Can't cope with a "
7283 . " argument to '-='. Subtraction ignored.");
7286 elsif ($reversed) { # Shouldn't happen in a -=, but just in case
7287 Carp::my_carp_bug("Can't cope with a "
7289 . " being the first parameter in a '-='. Subtraction ignored.");
7294 $map{pack 'J', $self}->delete_range($other, $other);
7299 sub add_match_table {
7300 # Add a new match table for this property, with name given by the
7301 # parameter. It returns a pointer to the table.
7307 my $addr = do { no overloading; pack 'J', $self; };
7309 my $table = $table_ref{$addr}{$name};
7310 my $standard_name = main::standardize($name);
7312 || (defined ($table = $table_ref{$addr}{$standard_name})))
7314 Carp::my_carp("Table '$name' in $self is already in use. Using existing one");
7315 $table_ref{$addr}{$name} = $table;
7320 # See if this is a perl extension, if not passed in.
7321 my $perl_extension = delete $args{'Perl_Extension'};
7323 = $self->perl_extension if ! defined $perl_extension;
7325 $table = Match_Table->new(
7327 Perl_Extension => $perl_extension,
7328 _Alias_Hash => $table_ref{$addr},
7331 # gets property's status by default
7332 Status => $self->status,
7333 _Status_Info => $self->status_info,
7335 return unless defined $table;
7338 # Save the names for quick look up
7339 $table_ref{$addr}{$standard_name} = $table;
7340 $table_ref{$addr}{$name} = $table;
7342 # Perhaps we can figure out the type of this property based on the
7343 # fact of adding this match table. First, string properties don't
7344 # have match tables; second, a binary property can't have 3 match
7346 if ($type{$addr} == $UNKNOWN) {
7347 $type{$addr} = $NON_STRING;
7349 elsif ($type{$addr} == $STRING) {
7350 Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News.");
7351 $type{$addr} = $NON_STRING;
7353 elsif ($type{$addr} != $ENUM && $type{$addr} != $FORCED_BINARY) {
7354 if (scalar main::uniques(values %{$table_ref{$addr}}) > 2
7355 && $type{$addr} == $BINARY)
7357 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.");
7358 $type{$addr} = $ENUM;
7365 sub delete_match_table {
7366 # Delete the table referred to by $2 from the property $1.
7369 my $table_to_remove = shift;
7370 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7372 my $addr = do { no overloading; pack 'J', $self; };
7374 # Remove all names that refer to it.
7375 foreach my $key (keys %{$table_ref{$addr}}) {
7376 delete $table_ref{$addr}{$key}
7377 if $table_ref{$addr}{$key} == $table_to_remove;
7380 $table_to_remove->DESTROY;
7385 # Return a pointer to the match table (with name given by the
7386 # parameter) associated with this property; undef if none.
7390 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7392 my $addr = do { no overloading; pack 'J', $self; };
7394 return $table_ref{$addr}{$name} if defined $table_ref{$addr}{$name};
7396 # If quick look-up failed, try again using the standard form of the
7397 # input name. If that succeeds, cache the result before returning so
7398 # won't have to standardize this input name again.
7399 my $standard_name = main::standardize($name);
7400 return unless defined $table_ref{$addr}{$standard_name};
7402 $table_ref{$addr}{$name} = $table_ref{$addr}{$standard_name};
7403 return $table_ref{$addr}{$name};
7407 # Return a list of pointers to all the match tables attached to this
7411 return main::uniques(values %{$table_ref{pack 'J', shift}});
7415 # Returns the directory the map table for this property should be
7416 # output in. If a specific directory has been specified, that has
7417 # priority; 'undef' is returned if the type isn't defined;
7418 # or $map_directory for everything else.
7420 my $addr = do { no overloading; pack 'J', shift; };
7422 return $directory{$addr} if defined $directory{$addr};
7423 return undef if $type{$addr} == $UNKNOWN;
7424 return $map_directory;
7428 # Return the name that is used to both:
7429 # 1) Name the file that the map table is written to.
7430 # 2) The name of swash related stuff inside that file.
7431 # The reason for this is that the Perl core historically has used
7432 # certain names that aren't the same as the Unicode property names.
7433 # To continue using these, $file is hard-coded in this file for those,
7434 # but otherwise the standard name is used. This is different from the
7435 # external_name, so that the rest of the files, like in lib can use
7436 # the standard name always, without regard to historical precedent.
7439 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7441 my $addr = do { no overloading; pack 'J', $self; };
7443 return $file{$addr} if defined $file{$addr};
7444 return $map{$addr}->external_name;
7447 sub to_create_match_tables {
7448 # Returns a boolean as to whether or not match tables should be
7449 # created for this property.
7452 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7454 # The whole point of this pseudo property is match tables.
7455 return 1 if $self == $perl;
7457 my $addr = do { no overloading; pack 'J', $self; };
7459 # Don't generate tables of code points that match the property values
7460 # of a string property. Such a list would most likely have many
7461 # property values, each with just one or very few code points mapping
7463 return 0 if $type{$addr} == $STRING;
7465 # Don't generate anything for unimplemented properties.
7466 return 0 if grep { $self->complete_name eq $_ }
7467 @unimplemented_properties;
7472 sub property_add_or_replace_non_nulls {
7473 # This adds the mappings in the property $other to $self. Non-null
7474 # mappings from $other override those in $self. It essentially merges
7475 # the two properties, with the second having priority except for null
7480 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7482 if (! $other->isa(__PACKAGE__)) {
7483 Carp::my_carp_bug("$other should be a "
7492 return $map{pack 'J', $self}->map_add_or_replace_non_nulls($map{pack 'J', $other});
7496 # Set the type of the property. Mostly this is figured out by the
7497 # data in the table. But this is used to set it explicitly. The
7498 # reason it is not a standard accessor is that when setting a binary
7499 # property, we need to make sure that all the true/false aliases are
7500 # present, as they were omitted in early Unicode releases.
7504 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7508 && $type != $FORCED_BINARY
7509 && $type != $STRING)
7511 Carp::my_carp("Unrecognized type '$type'. Type not set");
7515 { no overloading; $type{pack 'J', $self} = $type; }
7516 return if $type != $BINARY && $type != $FORCED_BINARY;
7518 my $yes = $self->table('Y');
7519 $yes = $self->table('Yes') if ! defined $yes;
7520 $yes = $self->add_match_table('Y', Full_Name => 'Yes')
7523 # Add aliases in order wanted, duplicates will be ignored. We use a
7524 # binary property present in all releases for its ordered lists of
7525 # true/false aliases. Note, that could run into problems in
7526 # outputting things in that we don't distinguish between the name and
7527 # full name of these. Hopefully, if the table was already created
7528 # before this code is executed, it was done with these set properly.
7529 my $bm = property_ref("Bidi_Mirrored");
7530 foreach my $alias ($bm->table("Y")->aliases) {
7531 $yes->add_alias($alias->name);
7533 my $no = $self->table('N');
7534 $no = $self->table('No') if ! defined $no;
7535 $no = $self->add_match_table('N', Full_Name => 'No') if ! defined $no;
7536 foreach my $alias ($bm->table("N")->aliases) {
7537 $no->add_alias($alias->name);
7544 # Add a map to the property's map table. This also keeps
7545 # track of the maps so that the property type can be determined from
7549 my $start = shift; # First code point in range
7550 my $end = shift; # Final code point in range
7551 my $map = shift; # What the range maps to.
7552 # Rest of parameters passed on.
7554 my $addr = do { no overloading; pack 'J', $self; };
7556 # If haven't the type of the property, gather information to figure it
7558 if ($type{$addr} == $UNKNOWN) {
7560 # If the map contains an interior blank or dash, or most other
7561 # nonword characters, it will be a string property. This
7562 # heuristic may actually miss some string properties. If so, they
7563 # may need to have explicit set_types called for them. This
7564 # happens in the Unihan properties.
7565 if ($map =~ / (?<= . ) [ -] (?= . ) /x
7566 || $map =~ / [^\w.\/\ -] /x)
7568 $self->set_type($STRING);
7570 # $unique_maps is used for disambiguating between ENUM and
7571 # BINARY later; since we know the property is not going to be
7572 # one of those, no point in keeping the data around
7573 undef $unique_maps{$addr};
7577 # Not necessarily a string. The final decision has to be
7578 # deferred until all the data are in. We keep track of if all
7579 # the values are code points for that eventual decision.
7580 $has_only_code_point_maps{$addr} &=
7581 $map =~ / ^ $code_point_re $/x;
7583 # For the purposes of disambiguating between binary and other
7584 # enumerations at the end, we keep track of the first three
7585 # distinct property values. Once we get to three, we know
7586 # it's not going to be binary, so no need to track more.
7587 if (scalar keys %{$unique_maps{$addr}} < 3) {
7588 $unique_maps{$addr}{main::standardize($map)} = 1;
7593 # Add the mapping by calling our map table's method
7594 return $map{$addr}->add_map($start, $end, $map, @_);
7598 # Compute the type of the property: $ENUM, $STRING, or $BINARY. This
7599 # should be called after the property is mostly filled with its maps.
7600 # We have been keeping track of what the property values have been,
7601 # and now have the necessary information to figure out the type.
7604 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
7606 my $addr = do { no overloading; pack 'J', $self; };
7608 my $type = $type{$addr};
7610 # If already have figured these out, no need to do so again, but we do
7611 # a double check on ENUMS to make sure that a string property hasn't
7612 # improperly been classified as an ENUM, so continue on with those.
7613 return if $type == $STRING
7615 || $type == $FORCED_BINARY;
7617 # If every map is to a code point, is a string property.
7618 if ($type == $UNKNOWN
7619 && ($has_only_code_point_maps{$addr}
7620 || (defined $map{$addr}->default_map
7621 && $map{$addr}->default_map eq "")))
7623 $self->set_type($STRING);
7627 # Otherwise, it is to some sort of enumeration. (The case where
7628 # it is a Unicode miscellaneous property, and treated like a
7629 # string in this program is handled in add_map()). Distinguish
7630 # between binary and some other enumeration type. Of course, if
7631 # there are more than two values, it's not binary. But more
7632 # subtle is the test that the default mapping is defined means it
7633 # isn't binary. This in fact may change in the future if Unicode
7634 # changes the way its data is structured. But so far, no binary
7635 # properties ever have @missing lines for them, so the default map
7636 # isn't defined for them. The few properties that are two-valued
7637 # and aren't considered binary have the default map defined
7638 # starting in Unicode 5.0, when the @missing lines appeared; and
7639 # this program has special code to put in a default map for them
7640 # for earlier than 5.0 releases.
7642 || scalar keys %{$unique_maps{$addr}} > 2
7643 || defined $self->default_map)
7645 my $tables = $self->tables;
7646 my $count = $self->count;
7647 if ($verbosity && $count > 500 && $tables/$count > .1) {
7648 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");
7650 $self->set_type($ENUM);
7653 $self->set_type($BINARY);
7656 undef $unique_maps{$addr}; # Garbage collect
7660 # Most of the accessors for a property actually apply to its map table.
7661 # Setup up accessor functions for those, referring to %map
7710 # 'property' above is for symmetry, so that one can take
7711 # the property of a property and get itself, and so don't
7712 # have to distinguish between properties and tables in
7720 return $map{pack 'J', $self}->$sub(@_);
7730 # Returns lines of the input joined together, so that they can be folded
7732 # This causes continuation lines to be joined together into one long line
7733 # for folding. A continuation line is any line that doesn't begin with a
7734 # space or "\b" (the latter is stripped from the output). This is so
7735 # lines can be be in a HERE document so as to fit nicely in the terminal
7736 # width, but be joined together in one long line, and then folded with
7737 # indents, '#' prefixes, etc, properly handled.
7738 # A blank separates the joined lines except if there is a break; an extra
7739 # blank is inserted after a period ending a line.
7741 # Initialize the return with the first line.
7742 my ($return, @lines) = split "\n", shift;
7744 # If the first line is null, it was an empty line, add the \n back in
7745 $return = "\n" if $return eq "";
7747 # Now join the remainder of the physical lines.
7748 for my $line (@lines) {
7750 # An empty line means wanted a blank line, so add two \n's to get that
7751 # effect, and go to the next line.
7752 if (length $line == 0) {
7757 # Look at the last character of what we have so far.
7758 my $previous_char = substr($return, -1, 1);
7760 # And at the next char to be output.
7761 my $next_char = substr($line, 0, 1);
7763 if ($previous_char ne "\n") {
7765 # Here didn't end wth a nl. If the next char a blank or \b, it
7766 # means that here there is a break anyway. So add a nl to the
7768 if ($next_char eq " " || $next_char eq "\b") {
7769 $previous_char = "\n";
7770 $return .= $previous_char;
7773 # Add an extra space after periods.
7774 $return .= " " if $previous_char eq '.';
7777 # Here $previous_char is still the latest character to be output. If
7778 # it isn't a nl, it means that the next line is to be a continuation
7779 # line, with a blank inserted between them.
7780 $return .= " " if $previous_char ne "\n";
7783 substr($line, 0, 1) = "" if $next_char eq "\b";
7785 # And append this next line.
7792 sub simple_fold($;$$$) {
7793 # Returns a string of the input (string or an array of strings) folded
7794 # into multiple-lines each of no more than $MAX_LINE_WIDTH characters plus
7796 # This is tailored for the kind of text written by this program,
7797 # especially the pod file, which can have very long names with
7798 # underscores in the middle, or words like AbcDefgHij.... We allow
7799 # breaking in the middle of such constructs if the line won't fit
7800 # otherwise. The break in such cases will come either just after an
7801 # underscore, or just before one of the Capital letters.
7803 local $to_trace = 0 if main::DEBUG;
7806 my $prefix = shift; # Optional string to prepend to each output
7808 $prefix = "" unless defined $prefix;
7810 my $hanging_indent = shift; # Optional number of spaces to indent
7811 # continuation lines
7812 $hanging_indent = 0 unless $hanging_indent;
7814 my $right_margin = shift; # Optional number of spaces to narrow the
7816 $right_margin = 0 unless defined $right_margin;
7818 # Call carp with the 'nofold' option to avoid it from trying to call us
7820 Carp::carp_extra_args(\@_, 'nofold') if main::DEBUG && @_;
7822 # The space available doesn't include what's automatically prepended
7823 # to each line, or what's reserved on the right.
7824 my $max = $MAX_LINE_WIDTH - length($prefix) - $right_margin;
7825 # XXX Instead of using the 'nofold' perhaps better to look up the stack
7827 if (DEBUG && $hanging_indent >= $max) {
7828 Carp::my_carp("Too large a hanging indent ($hanging_indent); must be < $max. Using 0", 'nofold');
7829 $hanging_indent = 0;
7832 # First, split into the current physical lines.
7834 if (ref $line) { # Better be an array, because not bothering to
7836 foreach my $line (@{$line}) {
7837 push @line, split /\n/, $line;
7841 @line = split /\n/, $line;
7844 #local $to_trace = 1 if main::DEBUG;
7845 trace "", join(" ", @line), "\n" if main::DEBUG && $to_trace;
7847 # Look at each current physical line.
7848 for (my $i = 0; $i < @line; $i++) {
7849 Carp::my_carp("Tabs don't work well.", 'nofold') if $line[$i] =~ /\t/;
7850 #local $to_trace = 1 if main::DEBUG;
7851 trace "i=$i: $line[$i]\n" if main::DEBUG && $to_trace;
7853 # Remove prefix, because will be added back anyway, don't want
7855 $line[$i] =~ s/^$prefix//;
7857 # Remove trailing space
7858 $line[$i] =~ s/\s+\Z//;
7860 # If the line is too long, fold it.
7861 if (length $line[$i] > $max) {
7864 # Here needs to fold. Save the leading space in the line for
7866 $line[$i] =~ /^ ( \s* )/x;
7867 my $leading_space = $1;
7868 trace "line length", length $line[$i], "; lead length", length($leading_space) if main::DEBUG && $to_trace;
7870 # If character at final permissible position is white space,
7871 # fold there, which will delete that white space
7872 if (substr($line[$i], $max - 1, 1) =~ /\s/) {
7873 $remainder = substr($line[$i], $max);
7874 $line[$i] = substr($line[$i], 0, $max - 1);
7878 # Otherwise fold at an acceptable break char closest to
7879 # the max length. Look at just the maximal initial
7880 # segment of the line
7881 my $segment = substr($line[$i], 0, $max - 1);
7883 /^ ( .{$hanging_indent} # Don't look before the
7885 \ * # Don't look in leading
7886 # blanks past the indent
7887 [^ ] .* # Find the right-most
7888 (?: # acceptable break:
7889 [ \s = ] # space or equal
7890 | - (?! [.0-9] ) # or non-unary minus.
7891 ) # $1 includes the character
7894 # Split into the initial part that fits, and remaining
7896 $remainder = substr($line[$i], length $1);
7898 trace $line[$i] if DEBUG && $to_trace;
7899 trace $remainder if DEBUG && $to_trace;
7902 # If didn't find a good breaking spot, see if there is a
7903 # not-so-good breaking spot. These are just after
7904 # underscores or where the case changes from lower to
7905 # upper. Use \a as a soft hyphen, but give up
7906 # and don't break the line if there is actually a \a
7907 # already in the input. We use an ascii character for the
7908 # soft-hyphen to avoid any attempt by miniperl to try to
7909 # access the files that this program is creating.
7910 elsif ($segment !~ /\a/
7911 && ($segment =~ s/_/_\a/g
7912 || $segment =~ s/ ( [a-z] ) (?= [A-Z] )/$1\a/xg))
7914 # Here were able to find at least one place to insert
7915 # our substitute soft hyphen. Find the right-most one
7916 # and replace it by a real hyphen.
7917 trace $segment if DEBUG && $to_trace;
7919 rindex($segment, "\a"),
7922 # Then remove the soft hyphen substitutes.
7923 $segment =~ s/\a//g;
7924 trace $segment if DEBUG && $to_trace;
7926 # And split into the initial part that fits, and
7927 # remainder of the line
7928 my $pos = rindex($segment, '-');
7929 $remainder = substr($line[$i], $pos);
7930 trace $remainder if DEBUG && $to_trace;
7931 $line[$i] = substr($segment, 0, $pos + 1);
7935 # Here we know if we can fold or not. If we can, $remainder
7936 # is what remains to be processed in the next iteration.
7937 if (defined $remainder) {
7938 trace "folded='$line[$i]'" if main::DEBUG && $to_trace;
7940 # Insert the folded remainder of the line as a new element
7941 # of the array. (It may still be too long, but we will
7942 # deal with that next time through the loop.) Omit any
7943 # leading space in the remainder.
7944 $remainder =~ s/^\s+//;
7945 trace "remainder='$remainder'" if main::DEBUG && $to_trace;
7947 # But then indent by whichever is larger of:
7948 # 1) the leading space on the input line;
7949 # 2) the hanging indent.
7950 # This preserves indentation in the original line.
7951 my $lead = ($leading_space)
7952 ? length $leading_space
7954 $lead = max($lead, $hanging_indent);
7955 splice @line, $i+1, 0, (" " x $lead) . $remainder;
7959 # Ready to output the line. Get rid of any trailing space
7960 # And prefix by the required $prefix passed in.
7961 $line[$i] =~ s/\s+$//;
7962 $line[$i] = "$prefix$line[$i]\n";
7963 } # End of looping through all the lines.
7965 return join "", @line;
7968 sub property_ref { # Returns a reference to a property object.
7969 return Property::property_ref(@_);
7972 sub force_unlink ($) {
7973 my $filename = shift;
7974 return unless file_exists($filename);
7975 return if CORE::unlink($filename);
7977 # We might need write permission
7978 chmod 0777, $filename;
7979 CORE::unlink($filename) or Carp::my_carp("Couldn't unlink $filename. Proceeding anyway: $!");
7984 # Given a filename and references to arrays of lines, write the lines of
7985 # each array to the file
7986 # Filename can be given as an arrayref of directory names
7988 return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3;
7991 my $use_utf8 = shift;
7993 # Get into a single string if an array, and get rid of, in Unix terms, any
7995 $file= File::Spec->join(@$file) if ref $file eq 'ARRAY';
7996 $file = File::Spec->canonpath($file);
7998 # If has directories, make sure that they all exist
7999 (undef, my $directories, undef) = File::Spec->splitpath($file);
8000 File::Path::mkpath($directories) if $directories && ! -d $directories;
8002 push @files_actually_output, $file;
8004 force_unlink ($file);
8007 if (not open $OUT, ">", $file) {
8008 Carp::my_carp("can't open $file for output. Skipping this file: $!");
8012 binmode $OUT, ":utf8" if $use_utf8;
8014 while (defined (my $lines_ref = shift)) {
8015 unless (@$lines_ref) {
8016 Carp::my_carp("An array of lines for writing to file '$file' is empty; writing it anyway;");
8019 print $OUT @$lines_ref or die Carp::my_carp("write to '$file' failed: $!");
8021 close $OUT or die Carp::my_carp("close '$file' failed: $!");
8023 print "$file written.\n" if $verbosity >= $VERBOSE;
8029 sub Standardize($) {
8030 # This converts the input name string into a standardized equivalent to
8034 unless (defined $name) {
8035 Carp::my_carp_bug("Standardize() called with undef. Returning undef.");
8039 # Remove any leading or trailing white space
8043 # Convert interior white space and hyphens into underscores.
8044 $name =~ s/ (?<= .) [ -]+ (.) /_$1/xg;
8046 # Capitalize the letter following an underscore, and convert a sequence of
8047 # multiple underscores to a single one
8048 $name =~ s/ (?<= .) _+ (.) /_\u$1/xg;
8050 # And capitalize the first letter, but not for the special cjk ones.
8051 $name = ucfirst($name) unless $name =~ /^k[A-Z]/;
8055 sub standardize ($) {
8056 # Returns a lower-cased standardized name, without underscores. This form
8057 # is chosen so that it can distinguish between any real versus superficial
8058 # Unicode name differences. It relies on the fact that Unicode doesn't
8059 # have interior underscores, white space, nor dashes in any
8060 # stricter-matched name. It should not be used on Unicode code point
8061 # names (the Name property), as they mostly, but not always follow these
8064 my $name = Standardize(shift);
8065 return if !defined $name;
8067 $name =~ s/ (?<= .) _ (?= . ) //xg;
8071 sub utf8_heavy_name ($$) {
8072 # Returns the name that utf8_heavy.pl will use to find a table. XXX
8073 # perhaps this function should be placed somewhere, like Heavy.pl so that
8074 # utf8_heavy can use it directly without duplicating code that can get
8079 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8081 my $property = $table->property;
8082 $property = ($property == $perl)
8083 ? "" # 'perl' is never explicitly stated
8084 : standardize($property->name) . '=';
8085 if ($alias->loose_match) {
8086 return $property . standardize($alias->name);
8089 return lc ($property . $alias->name);
8097 my $indent_increment = " " x 2;
8100 $main::simple_dumper_nesting = 0;
8103 # Like Simple Data::Dumper. Good enough for our needs. We can't use
8104 # the real thing as we have to run under miniperl.
8106 # It is designed so that on input it is at the beginning of a line,
8107 # and the final thing output in any call is a trailing ",\n".
8111 $indent = "" if ! defined $indent;
8113 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8115 # nesting level is localized, so that as the call stack pops, it goes
8116 # back to the prior value.
8117 local $main::simple_dumper_nesting = $main::simple_dumper_nesting;
8118 undef %already_output if $main::simple_dumper_nesting == 0;
8119 $main::simple_dumper_nesting++;
8120 #print STDERR __LINE__, ": $main::simple_dumper_nesting: $indent$item\n";
8122 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8124 # Determine the indent for recursive calls.
8125 my $next_indent = $indent . $indent_increment;
8130 # Dump of scalar: just output it in quotes if not a number. To do
8131 # so we must escape certain characters, and therefore need to
8132 # operate on a copy to avoid changing the original
8134 $copy = $UNDEF unless defined $copy;
8136 # Quote non-integers (integers also have optional leading '-')
8137 if ($copy eq "" || $copy !~ /^ -? \d+ $/x) {
8139 # Escape apostrophe and backslash
8140 $copy =~ s/ ( ['\\] ) /\\$1/xg;
8143 $output = "$indent$copy,\n";
8147 # Keep track of cycles in the input, and refuse to infinitely loop
8148 my $addr = do { no overloading; pack 'J', $item; };
8149 if (defined $already_output{$addr}) {
8150 return "${indent}ALREADY OUTPUT: $item\n";
8152 $already_output{$addr} = $item;
8154 if (ref $item eq 'ARRAY') {
8157 if ($main::simple_dumper_nesting > 1) {
8159 $using_brackets = 1;
8162 $using_brackets = 0;
8165 # If the array is empty, put the closing bracket on the same
8166 # line. Otherwise, recursively add each array element
8172 for (my $i = 0; $i < @$item; $i++) {
8174 # Indent array elements one level
8175 $output .= &simple_dumper($item->[$i], $next_indent);
8176 $output =~ s/\n$//; # Remove any trailing nl so
8177 $output .= " # [$i]\n"; # as to add a comment giving
8180 $output .= $indent; # Indent closing ']' to orig level
8182 $output .= ']' if $using_brackets;
8185 elsif (ref $item eq 'HASH') {
8190 # No surrounding braces at top level
8192 if ($main::simple_dumper_nesting > 1) {
8195 $body_indent = $next_indent;
8196 $next_indent .= $indent_increment;
8201 $body_indent = $indent;
8205 # Output hashes sorted alphabetically instead of apparently
8206 # random. Use caseless alphabetic sort
8207 foreach my $key (sort { lc $a cmp lc $b } keys %$item)
8209 if ($is_first_line) {
8213 $output .= "$body_indent";
8216 # The key must be a scalar, but this recursive call quotes
8218 $output .= &simple_dumper($key);
8220 # And change the trailing comma and nl to the hash fat
8221 # comma for clarity, and so the value can be on the same
8223 $output =~ s/,\n$/ => /;
8225 # Recursively call to get the value's dump.
8226 my $next = &simple_dumper($item->{$key}, $next_indent);
8228 # If the value is all on one line, remove its indent, so
8229 # will follow the => immediately. If it takes more than
8230 # one line, start it on a new line.
8231 if ($next !~ /\n.*\n/) {
8240 $output .= "$indent},\n" if $using_braces;
8242 elsif (ref $item eq 'CODE' || ref $item eq 'GLOB') {
8243 $output = $indent . ref($item) . "\n";
8244 # XXX see if blessed
8246 elsif ($item->can('dump')) {
8248 # By convention in this program, objects furnish a 'dump'
8249 # method. Since not doing any output at this level, just pass
8250 # on the input indent
8251 $output = $item->dump($indent);
8254 Carp::my_carp("Can't cope with dumping a " . ref($item) . ". Skipping.");
8261 sub dump_inside_out {
8262 # Dump inside-out hashes in an object's state by converting them to a
8263 # regular hash and then calling simple_dumper on that.
8266 my $fields_ref = shift;
8267 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8269 my $addr = do { no overloading; pack 'J', $object; };
8272 foreach my $key (keys %$fields_ref) {
8273 $hash{$key} = $fields_ref->{$key}{$addr};
8276 return simple_dumper(\%hash, @_);
8280 # Overloaded '.' method that is common to all packages. It uses the
8281 # package's stringify method.
8285 my $reversed = shift;
8286 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8288 $other = "" unless defined $other;
8290 foreach my $which (\$self, \$other) {
8291 next unless ref $$which;
8292 if ($$which->can('_operator_stringify')) {
8293 $$which = $$which->_operator_stringify;
8296 my $ref = ref $$which;
8297 my $addr = do { no overloading; pack 'J', $$which; };
8298 $$which = "$ref ($addr)";
8306 sub _operator_equal {
8307 # Generic overloaded '==' routine. To be equal, they must be the exact
8313 return 0 unless defined $other;
8314 return 0 unless ref $other;
8316 return $self == $other;
8319 sub _operator_not_equal {
8323 return ! _operator_equal($self, $other);
8326 sub process_PropertyAliases($) {
8327 # This reads in the PropertyAliases.txt file, which contains almost all
8328 # the character properties in Unicode and their equivalent aliases:
8329 # scf ; Simple_Case_Folding ; sfc
8331 # Field 0 is the preferred short name for the property.
8332 # Field 1 is the full name.
8333 # Any succeeding ones are other accepted names.
8336 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8338 # This whole file was non-existent in early releases, so use our own
8340 $file->insert_lines(get_old_property_aliases())
8341 if ! -e 'PropertyAliases.txt';
8343 # Add any cjk properties that may have been defined.
8344 $file->insert_lines(@cjk_properties);
8346 while ($file->next_line) {
8348 my @data = split /\s*;\s*/;
8350 my $full = $data[1];
8352 my $this = Property->new($data[0], Full_Name => $full);
8354 # Start looking for more aliases after these two.
8355 for my $i (2 .. @data - 1) {
8356 $this->add_alias($data[$i]);
8363 sub finish_property_setup {
8364 # Finishes setting up after PropertyAliases.
8367 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8369 # This entry was missing from this file in earlier Unicode versions
8370 if (-e 'Jamo.txt') {
8371 my $jsn = property_ref('JSN');
8372 if (! defined $jsn) {
8373 $jsn = Property->new('JSN', Full_Name => 'Jamo_Short_Name');
8377 # This entry is still missing as of 6.0, perhaps because no short name for
8379 if (-e 'NameAliases.txt') {
8380 my $aliases = property_ref('Name_Alias');
8381 if (! defined $aliases) {
8382 $aliases = Property->new('Name_Alias');
8386 # These are used so much, that we set globals for them.
8387 $gc = property_ref('General_Category');
8388 $block = property_ref('Block');
8389 $script = property_ref('Script');
8391 # Perl adds this alias.
8392 $gc->add_alias('Category');
8394 # For backwards compatibility, these property files have particular names.
8395 my $upper = property_ref('Uppercase_Mapping');
8396 $upper->set_core_access('uc()');
8397 $upper->set_file('Upper'); # This is what utf8.c calls it
8399 my $lower = property_ref('Lowercase_Mapping');
8400 $lower->set_core_access('lc()');
8401 $lower->set_file('Lower');
8403 my $title = property_ref('Titlecase_Mapping');
8404 $title->set_core_access('ucfirst()');
8405 $title->set_file('Title');
8407 my $fold = property_ref('Case_Folding');
8408 $fold->set_file('Fold') if defined $fold;
8410 # Unicode::Normalize expects this file with this name and directory.
8411 my $ccc = property_ref('Canonical_Combining_Class');
8413 $ccc->set_file('CombiningClass');
8414 $ccc->set_directory(File::Spec->curdir());
8417 # utf8.c has a different meaning for non range-size-1 for map properties
8418 # that this program doesn't currently handle; and even if it were changed
8419 # to do so, some other code may be using them expecting range size 1.
8420 foreach my $property (qw {
8427 property_ref($property)->set_range_size_1(1);
8430 # These two properties aren't actually used in the core, but unfortunately
8431 # the names just above that are in the core interfere with these, so
8432 # choose different names. These aren't a problem unless the map tables
8433 # for these files get written out.
8434 my $lowercase = property_ref('Lowercase');
8435 $lowercase->set_file('IsLower') if defined $lowercase;
8436 my $uppercase = property_ref('Uppercase');
8437 $uppercase->set_file('IsUpper') if defined $uppercase;
8439 # Set up the hard-coded default mappings, but only on properties defined
8441 foreach my $property (keys %default_mapping) {
8442 my $property_object = property_ref($property);
8443 next if ! defined $property_object;
8444 my $default_map = $default_mapping{$property};
8445 $property_object->set_default_map($default_map);
8447 # A map of <code point> implies the property is string.
8448 if ($property_object->type == $UNKNOWN
8449 && $default_map eq $CODE_POINT)
8451 $property_object->set_type($STRING);
8455 # The following use the Multi_Default class to create objects for
8458 # Bidi class has a complicated default, but the derived file takes care of
8459 # the complications, leaving just 'L'.
8460 if (file_exists("${EXTRACTED}DBidiClass.txt")) {
8461 property_ref('Bidi_Class')->set_default_map('L');
8466 # The derived file was introduced in 3.1.1. The values below are
8467 # taken from table 3-8, TUS 3.0
8469 'my $default = Range_List->new;
8470 $default->add_range(0x0590, 0x05FF);
8471 $default->add_range(0xFB1D, 0xFB4F);'
8474 # The defaults apply only to unassigned characters
8475 $default_R .= '$gc->table("Unassigned") & $default;';
8477 if ($v_version lt v3.0.0) {
8478 $default = Multi_Default->new(R => $default_R, 'L');
8482 # AL apparently not introduced until 3.0: TUS 2.x references are
8483 # not on-line to check it out
8485 'my $default = Range_List->new;
8486 $default->add_range(0x0600, 0x07BF);
8487 $default->add_range(0xFB50, 0xFDFF);
8488 $default->add_range(0xFE70, 0xFEFF);'
8491 # Non-character code points introduced in this release; aren't AL
8492 if ($v_version ge 3.1.0) {
8493 $default_AL .= '$default->delete_range(0xFDD0, 0xFDEF);';
8495 $default_AL .= '$gc->table("Unassigned") & $default';
8496 $default = Multi_Default->new(AL => $default_AL,
8500 property_ref('Bidi_Class')->set_default_map($default);
8503 # Joining type has a complicated default, but the derived file takes care
8504 # of the complications, leaving just 'U' (or Non_Joining), except the file
8506 if (file_exists("${EXTRACTED}DJoinType.txt") || -e 'ArabicShaping.txt') {
8507 if (file_exists("${EXTRACTED}DJoinType.txt") && $v_version ne 3.1.0) {
8508 property_ref('Joining_Type')->set_default_map('Non_Joining');
8512 # Otherwise, there are not one, but two possibilities for the
8513 # missing defaults: T and U.
8514 # The missing defaults that evaluate to T are given by:
8515 # T = Mn + Cf - ZWNJ - ZWJ
8516 # where Mn and Cf are the general category values. In other words,
8517 # any non-spacing mark or any format control character, except
8518 # U+200C ZERO WIDTH NON-JOINER (joining type U) and U+200D ZERO
8519 # WIDTH JOINER (joining type C).
8520 my $default = Multi_Default->new(
8521 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C - 0x200D',
8523 property_ref('Joining_Type')->set_default_map($default);
8527 # Line break has a complicated default in early releases. It is 'Unknown'
8528 # for non-assigned code points; 'AL' for assigned.
8529 if (file_exists("${EXTRACTED}DLineBreak.txt") || -e 'LineBreak.txt') {
8530 my $lb = property_ref('Line_Break');
8531 if ($v_version gt 3.2.0) {
8532 $lb->set_default_map('Unknown');
8535 my $default = Multi_Default->new( 'Unknown' => '$gc->table("Cn")',
8537 $lb->set_default_map($default);
8540 # If has the URS property, make sure that the standard aliases are in
8541 # it, since not in the input tables in some versions.
8542 my $urs = property_ref('Unicode_Radical_Stroke');
8544 $urs->add_alias('cjkRSUnicode');
8545 $urs->add_alias('kRSUnicode');
8551 sub get_old_property_aliases() {
8552 # Returns what would be in PropertyAliases.txt if it existed in very old
8553 # versions of Unicode. It was derived from the one in 3.2, and pared
8554 # down based on the data that was actually in the older releases.
8555 # An attempt was made to use the existence of files to mean inclusion or
8556 # not of various aliases, but if this was not sufficient, using version
8557 # numbers was resorted to.
8561 # These are to be used in all versions (though some are constructed by
8562 # this program if missing)
8563 push @return, split /\n/, <<'END';
8565 Bidi_M ; Bidi_Mirrored
8567 ccc ; Canonical_Combining_Class
8568 dm ; Decomposition_Mapping
8569 dt ; Decomposition_Type
8570 gc ; General_Category
8572 lc ; Lowercase_Mapping
8574 na1 ; Unicode_1_Name
8577 sfc ; Simple_Case_Folding
8578 slc ; Simple_Lowercase_Mapping
8579 stc ; Simple_Titlecase_Mapping
8580 suc ; Simple_Uppercase_Mapping
8581 tc ; Titlecase_Mapping
8582 uc ; Uppercase_Mapping
8585 if (-e 'Blocks.txt') {
8586 push @return, "blk ; Block\n";
8588 if (-e 'ArabicShaping.txt') {
8589 push @return, split /\n/, <<'END';
8594 if (-e 'PropList.txt') {
8596 # This first set is in the original old-style proplist.
8597 push @return, split /\n/, <<'END';
8599 Bidi_C ; Bidi_Control
8607 Join_C ; Join_Control
8609 QMark ; Quotation_Mark
8610 Term ; Terminal_Punctuation
8611 WSpace ; White_Space
8613 # The next sets were added later
8614 if ($v_version ge v3.0.0) {
8615 push @return, split /\n/, <<'END';
8620 if ($v_version ge v3.0.1) {
8621 push @return, split /\n/, <<'END';
8622 NChar ; Noncharacter_Code_Point
8625 # The next sets were added in the new-style
8626 if ($v_version ge v3.1.0) {
8627 push @return, split /\n/, <<'END';
8628 OAlpha ; Other_Alphabetic
8629 OLower ; Other_Lowercase
8631 OUpper ; Other_Uppercase
8634 if ($v_version ge v3.1.1) {
8635 push @return, "AHex ; ASCII_Hex_Digit\n";
8638 if (-e 'EastAsianWidth.txt') {
8639 push @return, "ea ; East_Asian_Width\n";
8641 if (-e 'CompositionExclusions.txt') {
8642 push @return, "CE ; Composition_Exclusion\n";
8644 if (-e 'LineBreak.txt') {
8645 push @return, "lb ; Line_Break\n";
8647 if (-e 'BidiMirroring.txt') {
8648 push @return, "bmg ; Bidi_Mirroring_Glyph\n";
8650 if (-e 'Scripts.txt') {
8651 push @return, "sc ; Script\n";
8653 if (-e 'DNormalizationProps.txt') {
8654 push @return, split /\n/, <<'END';
8655 Comp_Ex ; Full_Composition_Exclusion
8656 FC_NFKC ; FC_NFKC_Closure
8657 NFC_QC ; NFC_Quick_Check
8658 NFD_QC ; NFD_Quick_Check
8659 NFKC_QC ; NFKC_Quick_Check
8660 NFKD_QC ; NFKD_Quick_Check
8661 XO_NFC ; Expands_On_NFC
8662 XO_NFD ; Expands_On_NFD
8663 XO_NFKC ; Expands_On_NFKC
8664 XO_NFKD ; Expands_On_NFKD
8667 if (-e 'DCoreProperties.txt') {
8668 push @return, split /\n/, <<'END';
8673 # These can also appear in some versions of PropList.txt
8674 push @return, "Lower ; Lowercase\n"
8675 unless grep { $_ =~ /^Lower\b/} @return;
8676 push @return, "Upper ; Uppercase\n"
8677 unless grep { $_ =~ /^Upper\b/} @return;
8680 # This flag requires the DAge.txt file to be copied into the directory.
8681 if (DEBUG && $compare_versions) {
8682 push @return, 'age ; Age';
8688 sub process_PropValueAliases {
8689 # This file contains values that properties look like:
8690 # bc ; AL ; Arabic_Letter
8691 # blk; n/a ; Greek_And_Coptic ; Greek
8693 # Field 0 is the property.
8694 # Field 1 is the short name of a property value or 'n/a' if no
8695 # short name exists;
8696 # Field 2 is the full property value name;
8697 # Any other fields are more synonyms for the property value.
8698 # Purely numeric property values are omitted from the file; as are some
8699 # others, fewer and fewer in later releases
8701 # Entries for the ccc property have an extra field before the
8703 # ccc; 0; NR ; Not_Reordered
8704 # It is the numeric value that the names are synonyms for.
8706 # There are comment entries for values missing from this file:
8707 # # @missing: 0000..10FFFF; ISO_Comment; <none>
8708 # # @missing: 0000..10FFFF; Lowercase_Mapping; <code point>
8711 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
8713 # This whole file was non-existent in early releases, so use our own
8714 # internal one if necessary.
8715 if (! -e 'PropValueAliases.txt') {
8716 $file->insert_lines(get_old_property_value_aliases());
8719 # Add any explicit cjk values
8720 $file->insert_lines(@cjk_property_values);
8722 # This line is used only for testing the code that checks for name
8723 # conflicts. There is a script Inherited, and when this line is executed
8724 # it causes there to be a name conflict with the 'Inherited' that this
8725 # program generates for this block property value
8726 #$file->insert_lines('blk; n/a; Herited');
8729 # Process each line of the file ...
8730 while ($file->next_line) {
8732 my ($property, @data) = split /\s*;\s*/;
8734 # The ccc property has an extra field at the beginning, which is the
8735 # numeric value. Move it to be after the other two, mnemonic, fields,
8736 # so that those will be used as the property value's names, and the
8737 # number will be an extra alias. (Rightmost splice removes field 1-2,
8738 # returning them in a slice; left splice inserts that before anything,
8739 # thus shifting the former field 0 to after them.)
8740 splice (@data, 0, 0, splice(@data, 1, 2)) if $property eq 'ccc';
8742 # Field 0 is a short name unless "n/a"; field 1 is the full name. If
8743 # there is no short name, use the full one in element 1
8744 if ($data[0] eq "n/a") {
8745 $data[0] = $data[1];
8747 elsif ($data[0] ne $data[1]
8748 && standardize($data[0]) eq standardize($data[1])
8749 && $data[1] !~ /[[:upper:]]/)
8751 # Also, there is a bug in the file in which "n/a" is omitted, and
8752 # the two fields are identical except for case, and the full name
8753 # is all lower case. Copy the "short" name unto the full one to
8754 # give it some upper case.
8756 $data[1] = $data[0];
8759 # Earlier releases had the pseudo property 'qc' that should expand to
8760 # the ones that replace it below.
8761 if ($property eq 'qc') {
8762 if (lc $data[0] eq 'y') {
8763 $file->insert_lines('NFC_QC; Y ; Yes',
8769 elsif (lc $data[0] eq 'n') {
8770 $file->insert_lines('NFC_QC; N ; No',
8776 elsif (lc $data[0] eq 'm') {
8777 $file->insert_lines('NFC_QC; M ; Maybe',
8778 'NFKC_QC; M ; Maybe',
8782 $file->carp_bad_line("qc followed by unexpected '$data[0]");
8787 # The first field is the short name, 2nd is the full one.
8788 my $property_object = property_ref($property);
8789 my $table = $property_object->add_match_table($data[0],
8790 Full_Name => $data[1]);
8792 # Start looking for more aliases after these two.
8793 for my $i (2 .. @data - 1) {
8794 $table->add_alias($data[$i]);
8796 } # End of looping through the file
8798 # As noted in the comments early in the program, it generates tables for
8799 # the default values for all releases, even those for which the concept
8800 # didn't exist at the time. Here we add those if missing.
8801 my $age = property_ref('age');
8802 if (defined $age && ! defined $age->table('Unassigned')) {
8803 $age->add_match_table('Unassigned');
8805 $block->add_match_table('No_Block') if -e 'Blocks.txt'
8806 && ! defined $block->table('No_Block');
8809 # Now set the default mappings of the properties from the file. This is
8810 # done after the loop because a number of properties have only @missings
8811 # entries in the file, and may not show up until the end.
8812 my @defaults = $file->get_missings;
8813 foreach my $default_ref (@defaults) {
8814 my $default = $default_ref->[0];
8815 my $property = property_ref($default_ref->[1]);
8816 $property->set_default_map($default);
8821 sub get_old_property_value_aliases () {
8822 # Returns what would be in PropValueAliases.txt if it existed in very old
8823 # versions of Unicode. It was derived from the one in 3.2, and pared
8824 # down. An attempt was made to use the existence of files to mean
8825 # inclusion or not of various aliases, but if this was not sufficient,
8826 # using version numbers was resorted to.
8828 my @return = split /\n/, <<'END';
8829 bc ; AN ; Arabic_Number
8830 bc ; B ; Paragraph_Separator
8831 bc ; CS ; Common_Separator
8832 bc ; EN ; European_Number
8833 bc ; ES ; European_Separator
8834 bc ; ET ; European_Terminator
8835 bc ; L ; Left_To_Right
8836 bc ; ON ; Other_Neutral
8837 bc ; R ; Right_To_Left
8838 bc ; WS ; White_Space
8840 # The standard combining classes are very much different in v1, so only use
8841 # ones that look right (not checked thoroughly)
8842 ccc; 0; NR ; Not_Reordered
8843 ccc; 1; OV ; Overlay
8845 ccc; 8; KV ; Kana_Voicing
8847 ccc; 202; ATBL ; Attached_Below_Left
8848 ccc; 216; ATAR ; Attached_Above_Right
8849 ccc; 218; BL ; Below_Left
8851 ccc; 222; BR ; Below_Right
8853 ccc; 228; AL ; Above_Left
8855 ccc; 232; AR ; Above_Right
8856 ccc; 234; DA ; Double_Above
8858 dt ; can ; canonical
8872 gc ; C ; Other # Cc | Cf | Cn | Co | Cs
8874 gc ; Cn ; Unassigned
8875 gc ; Co ; Private_Use
8876 gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu
8877 gc ; LC ; Cased_Letter # Ll | Lt | Lu
8878 gc ; Ll ; Lowercase_Letter
8879 gc ; Lm ; Modifier_Letter
8880 gc ; Lo ; Other_Letter
8881 gc ; Lu ; Uppercase_Letter
8882 gc ; M ; Mark # Mc | Me | Mn
8883 gc ; Mc ; Spacing_Mark
8884 gc ; Mn ; Nonspacing_Mark
8885 gc ; N ; Number # Nd | Nl | No
8886 gc ; Nd ; Decimal_Number
8887 gc ; No ; Other_Number
8888 gc ; P ; Punctuation # Pc | Pd | Pe | Pf | Pi | Po | Ps
8889 gc ; Pd ; Dash_Punctuation
8890 gc ; Pe ; Close_Punctuation
8891 gc ; Po ; Other_Punctuation
8892 gc ; Ps ; Open_Punctuation
8893 gc ; S ; Symbol # Sc | Sk | Sm | So
8894 gc ; Sc ; Currency_Symbol
8895 gc ; Sm ; Math_Symbol
8896 gc ; So ; Other_Symbol
8897 gc ; Z ; Separator # Zl | Zp | Zs
8898 gc ; Zl ; Line_Separator
8899 gc ; Zp ; Paragraph_Separator
8900 gc ; Zs ; Space_Separator
8908 if (-e 'ArabicShaping.txt') {
8909 push @return, split /\n/, <<'END';
8916 jg ; n/a ; NO_JOINING_GROUP
8924 jt ; C ; Join_Causing
8925 jt ; D ; Dual_Joining
8926 jt ; L ; Left_Joining
8927 jt ; R ; Right_Joining
8928 jt ; U ; Non_Joining
8929 jt ; T ; Transparent
8931 if ($v_version ge v3.0.0) {
8932 push @return, split /\n/, <<'END';
8936 jg ; n/a ; DALATH_RISH
8939 jg ; n/a ; FINAL_SEMKATH
8942 jg ; n/a ; HAMZA_ON_HEH_GOAL
8949 jg ; n/a ; KNOTTED_HEH
8956 jg ; n/a ; REVERSED_PE
8960 jg ; n/a ; SWASH_KAF
8962 jg ; n/a ; TEH_MARBUTA
8965 jg ; n/a ; YEH_BARREE
8966 jg ; n/a ; YEH_WITH_TAIL
8975 if (-e 'EastAsianWidth.txt') {
8976 push @return, split /\n/, <<'END';
8986 if (-e 'LineBreak.txt') {
8987 push @return, split /\n/, <<'END';
8989 lb ; AL ; Alphabetic
8990 lb ; B2 ; Break_Both
8991 lb ; BA ; Break_After
8992 lb ; BB ; Break_Before
8993 lb ; BK ; Mandatory_Break
8994 lb ; CB ; Contingent_Break
8995 lb ; CL ; Close_Punctuation
8996 lb ; CM ; Combining_Mark
8997 lb ; CR ; Carriage_Return
8998 lb ; EX ; Exclamation
9001 lb ; ID ; Ideographic
9002 lb ; IN ; Inseperable
9003 lb ; IS ; Infix_Numeric
9005 lb ; NS ; Nonstarter
9007 lb ; OP ; Open_Punctuation
9008 lb ; PO ; Postfix_Numeric
9009 lb ; PR ; Prefix_Numeric
9011 lb ; SA ; Complex_Context
9014 lb ; SY ; Break_Symbols
9020 if (-e 'DNormalizationProps.txt') {
9021 push @return, split /\n/, <<'END';
9028 if (-e 'Scripts.txt') {
9029 push @return, split /\n/, <<'END';
9031 sc ; Armn ; Armenian
9033 sc ; Bopo ; Bopomofo
9034 sc ; Cans ; Canadian_Aboriginal
9035 sc ; Cher ; Cherokee
9036 sc ; Cyrl ; Cyrillic
9037 sc ; Deva ; Devanagari
9039 sc ; Ethi ; Ethiopic
9040 sc ; Geor ; Georgian
9043 sc ; Gujr ; Gujarati
9044 sc ; Guru ; Gurmukhi
9048 sc ; Hira ; Hiragana
9049 sc ; Ital ; Old_Italic
9050 sc ; Kana ; Katakana
9055 sc ; Mlym ; Malayalam
9056 sc ; Mong ; Mongolian
9060 sc ; Qaai ; Inherited
9074 if ($v_version ge v2.0.0) {
9075 push @return, split /\n/, <<'END';
9079 dt ; vert ; vertical
9084 gc ; Lt ; Titlecase_Letter
9085 gc ; Me ; Enclosing_Mark
9086 gc ; Nl ; Letter_Number
9087 gc ; Pc ; Connector_Punctuation
9088 gc ; Sk ; Modifier_Symbol
9091 if ($v_version ge v2.1.2) {
9092 push @return, "bc ; S ; Segment_Separator\n";
9094 if ($v_version ge v2.1.5) {
9095 push @return, split /\n/, <<'END';
9096 gc ; Pf ; Final_Punctuation
9097 gc ; Pi ; Initial_Punctuation
9100 if ($v_version ge v2.1.8) {
9101 push @return, "ccc; 240; IS ; Iota_Subscript\n";
9104 if ($v_version ge v3.0.0) {
9105 push @return, split /\n/, <<'END';
9106 bc ; AL ; Arabic_Letter
9107 bc ; BN ; Boundary_Neutral
9108 bc ; LRE ; Left_To_Right_Embedding
9109 bc ; LRO ; Left_To_Right_Override
9110 bc ; NSM ; Nonspacing_Mark
9111 bc ; PDF ; Pop_Directional_Format
9112 bc ; RLE ; Right_To_Left_Embedding
9113 bc ; RLO ; Right_To_Left_Override
9115 ccc; 233; DB ; Double_Below
9119 if ($v_version ge v3.1.0) {
9120 push @return, "ccc; 226; R ; Right\n";
9126 sub output_perl_charnames_line ($$) {
9128 # Output the entries in Perl_charnames specially, using 5 digits instead
9129 # of four. This makes the entries a constant length, and simplifies
9130 # charnames.pm which this table is for. Unicode can have 6 digit
9131 # ordinals, but they are all private use or noncharacters which do not
9132 # have names, so won't be in this table.
9134 return sprintf "%05X\t%s\n", $_[0], $_[1];
9138 # This is used to store the range list of all the code points usable when
9139 # the little used $compare_versions feature is enabled.
9140 my $compare_versions_range_list;
9142 # These are constants to the $property_info hash in this subroutine, to
9143 # avoid using a quoted-string which might have a typo.
9145 my $DEFAULT_MAP = 'default_map';
9146 my $DEFAULT_TABLE = 'default_table';
9147 my $PSEUDO_MAP_TYPE = 'pseudo_map_type';
9148 my $MISSINGS = 'missings';
9150 sub process_generic_property_file {
9151 # This processes a file containing property mappings and puts them
9152 # into internal map tables. It should be used to handle any property
9153 # files that have mappings from a code point or range thereof to
9154 # something else. This means almost all the UCD .txt files.
9155 # each_line_handlers() should be set to adjust the lines of these
9156 # files, if necessary, to what this routine understands:
9161 # the fields are: "codepoint-range ; property; map"
9163 # meaning the codepoints in the range all have the value 'map' under
9165 # Beginning and trailing white space in each field are not significant.
9166 # Note there is not a trailing semi-colon in the above. A trailing
9167 # semi-colon means the map is a null-string. An omitted map, as
9168 # opposed to a null-string, is assumed to be 'Y', based on Unicode
9169 # table syntax. (This could have been hidden from this routine by
9170 # doing it in the $file object, but that would require parsing of the
9171 # line there, so would have to parse it twice, or change the interface
9172 # to pass this an array. So not done.)
9174 # The map field may begin with a sequence of commands that apply to
9175 # this range. Each such command begins and ends with $CMD_DELIM.
9176 # These are used to indicate, for example, that the mapping for a
9177 # range has a non-default type.
9179 # This loops through the file, calling it's next_line() method, and
9180 # then taking the map and adding it to the property's table.
9181 # Complications arise because any number of properties can be in the
9182 # file, in any order, interspersed in any way. The first time a
9183 # property is seen, it gets information about that property and
9184 # caches it for quick retrieval later. It also normalizes the maps
9185 # so that only one of many synonyms is stored. The Unicode input
9186 # files do use some multiple synonyms.
9189 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9191 my %property_info; # To keep track of what properties
9192 # have already had entries in the
9193 # current file, and info about each,
9194 # so don't have to recompute.
9195 my $property_name; # property currently being worked on
9196 my $property_type; # and its type
9197 my $previous_property_name = ""; # name from last time through loop
9198 my $property_object; # pointer to the current property's
9200 my $property_addr; # the address of that object
9201 my $default_map; # the string that code points missing
9202 # from the file map to
9203 my $default_table; # For non-string properties, a
9204 # reference to the match table that
9205 # will contain the list of code
9206 # points that map to $default_map.
9208 # Get the next real non-comment line
9210 while ($file->next_line) {
9212 # Default replacement type; means that if parts of the range have
9213 # already been stored in our tables, the new map overrides them if
9214 # they differ more than cosmetically
9215 my $replace = $IF_NOT_EQUIVALENT;
9216 my $map_type; # Default type for the map of this range
9218 #local $to_trace = 1 if main::DEBUG;
9219 trace $_ if main::DEBUG && $to_trace;
9221 # Split the line into components
9222 my ($range, $property_name, $map, @remainder)
9223 = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
9225 # If more or less on the line than we are expecting, warn and skip
9228 $file->carp_bad_line('Extra fields');
9231 elsif ( ! defined $property_name) {
9232 $file->carp_bad_line('Missing property');
9236 # Examine the range.
9237 if ($range !~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x)
9239 $file->carp_bad_line("Range '$range' not of the form 'CP1' or 'CP1..CP2' (where CP1,2 are code points in hex)");
9243 my $high = (defined $2) ? hex $2 : $low;
9245 # For the very specialized case of comparing two Unicode
9247 if (DEBUG && $compare_versions) {
9248 if ($property_name eq 'Age') {
9250 # Only allow code points at least as old as the version
9252 my $age = pack "C*", split(/\./, $map); # v string
9253 next LINE if $age gt $compare_versions;
9257 # Again, we throw out code points younger than those of
9258 # the specified version. By now, the Age property is
9259 # populated. We use the intersection of each input range
9260 # with this property to find what code points in it are
9261 # valid. To do the intersection, we have to convert the
9262 # Age property map to a Range_list. We only have to do
9264 if (! defined $compare_versions_range_list) {
9265 my $age = property_ref('Age');
9266 if (! -e 'DAge.txt') {
9267 croak "Need to have 'DAge.txt' file to do version comparison";
9269 elsif ($age->count == 0) {
9270 croak "The 'Age' table is empty, but its file exists";
9272 $compare_versions_range_list
9273 = Range_List->new(Initialize => $age);
9276 # An undefined map is always 'Y'
9277 $map = 'Y' if ! defined $map;
9279 # Calculate the intersection of the input range with the
9280 # code points that are known in the specified version
9281 my @ranges = ($compare_versions_range_list
9282 & Range->new($low, $high))->ranges;
9284 # If the intersection is empty, throw away this range
9285 next LINE unless @ranges;
9287 # Only examine the first range this time through the loop.
9288 my $this_range = shift @ranges;
9290 # Put any remaining ranges in the queue to be processed
9291 # later. Note that there is unnecessary work here, as we
9292 # will do the intersection again for each of these ranges
9293 # during some future iteration of the LINE loop, but this
9294 # code is not used in production. The later intersections
9295 # are guaranteed to not splinter, so this will not become
9297 my $line = join ';', $property_name, $map;
9298 foreach my $range (@ranges) {
9299 $file->insert_adjusted_lines(sprintf("%04X..%04X; %s",
9305 # And process the first range, like any other.
9306 $low = $this_range->start;
9307 $high = $this_range->end;
9309 } # End of $compare_versions
9311 # If changing to a new property, get the things constant per
9313 if ($previous_property_name ne $property_name) {
9315 $property_object = property_ref($property_name);
9316 if (! defined $property_object) {
9317 $file->carp_bad_line("Unexpected property '$property_name'. Skipped");
9320 { no overloading; $property_addr = pack 'J', $property_object; }
9322 # Defer changing names until have a line that is acceptable
9323 # (the 'next' statement above means is unacceptable)
9324 $previous_property_name = $property_name;
9326 # If not the first time for this property, retrieve info about
9328 if (defined ($property_info{$property_addr}{$TYPE})) {
9329 $property_type = $property_info{$property_addr}{$TYPE};
9330 $default_map = $property_info{$property_addr}{$DEFAULT_MAP};
9332 = $property_info{$property_addr}{$PSEUDO_MAP_TYPE};
9334 = $property_info{$property_addr}{$DEFAULT_TABLE};
9338 # Here, is the first time for this property. Set up the
9340 $property_type = $property_info{$property_addr}{$TYPE}
9341 = $property_object->type;
9343 = $property_info{$property_addr}{$PSEUDO_MAP_TYPE}
9344 = $property_object->pseudo_map_type;
9346 # The Unicode files are set up so that if the map is not
9347 # defined, it is a binary property
9348 if (! defined $map && $property_type != $BINARY) {
9349 if ($property_type != $UNKNOWN
9350 && $property_type != $NON_STRING)
9352 $file->carp_bad_line("No mapping defined on a non-binary property. Using 'Y' for the map");
9355 $property_object->set_type($BINARY);
9357 = $property_info{$property_addr}{$TYPE}
9362 # Get any @missings default for this property. This
9363 # should precede the first entry for the property in the
9364 # input file, and is located in a comment that has been
9365 # stored by the Input_file class until we access it here.
9366 # It's possible that there is more than one such line
9367 # waiting for us; collect them all, and parse
9368 my @missings_list = $file->get_missings
9369 if $file->has_missings_defaults;
9370 foreach my $default_ref (@missings_list) {
9371 my $default = $default_ref->[0];
9372 my $addr = do { no overloading; pack 'J', property_ref($default_ref->[1]); };
9374 # For string properties, the default is just what the
9375 # file says, but non-string properties should already
9376 # have set up a table for the default property value;
9377 # use the table for these, so can resolve synonyms
9378 # later to a single standard one.
9379 if ($property_type == $STRING
9380 || $property_type == $UNKNOWN)
9382 $property_info{$addr}{$MISSINGS} = $default;
9385 $property_info{$addr}{$MISSINGS}
9386 = $property_object->table($default);
9390 # Finished storing all the @missings defaults in the input
9391 # file so far. Get the one for the current property.
9392 my $missings = $property_info{$property_addr}{$MISSINGS};
9394 # But we likely have separately stored what the default
9395 # should be. (This is to accommodate versions of the
9396 # standard where the @missings lines are absent or
9397 # incomplete.) Hopefully the two will match. But check
9399 $default_map = $property_object->default_map;
9401 # If the map is a ref, it means that the default won't be
9402 # processed until later, so undef it, so next few lines
9403 # will redefine it to something that nothing will match
9404 undef $default_map if ref $default_map;
9406 # Create a $default_map if don't have one; maybe a dummy
9407 # that won't match anything.
9408 if (! defined $default_map) {
9410 # Use any @missings line in the file.
9411 if (defined $missings) {
9412 if (ref $missings) {
9413 $default_map = $missings->full_name;
9414 $default_table = $missings;
9417 $default_map = $missings;
9420 # And store it with the property for outside use.
9421 $property_object->set_default_map($default_map);
9425 # Neither an @missings nor a default map. Create
9426 # a dummy one, so won't have to test definedness
9428 $default_map = '_Perl This will never be in a file
9433 # Here, we have $default_map defined, possibly in terms of
9434 # $missings, but maybe not, and possibly is a dummy one.
9435 if (defined $missings) {
9437 # Make sure there is no conflict between the two.
9438 # $missings has priority.
9439 if (ref $missings) {
9441 = $property_object->table($default_map);
9442 if (! defined $default_table
9443 || $default_table != $missings)
9445 if (! defined $default_table) {
9446 $default_table = $UNDEF;
9448 $file->carp_bad_line(<<END
9449 The \@missings line for $property_name in $file says that missings default to
9450 $missings, but we expect it to be $default_table. $missings used.
9453 $default_table = $missings;
9454 $default_map = $missings->full_name;
9456 $property_info{$property_addr}{$DEFAULT_TABLE}
9459 elsif ($default_map ne $missings) {
9460 $file->carp_bad_line(<<END
9461 The \@missings line for $property_name in $file says that missings default to
9462 $missings, but we expect it to be $default_map. $missings used.
9465 $default_map = $missings;
9469 $property_info{$property_addr}{$DEFAULT_MAP}
9472 # If haven't done so already, find the table corresponding
9473 # to this map for non-string properties.
9474 if (! defined $default_table
9475 && $property_type != $STRING
9476 && $property_type != $UNKNOWN)
9478 $default_table = $property_info{$property_addr}
9480 = $property_object->table($default_map);
9482 } # End of is first time for this property
9483 } # End of switching properties.
9485 # Ready to process the line.
9486 # The Unicode files are set up so that if the map is not defined,
9487 # it is a binary property with value 'Y'
9488 if (! defined $map) {
9493 # If the map begins with a special command to us (enclosed in
9494 # delimiters), extract the command(s).
9495 while ($map =~ s/ ^ $CMD_DELIM (.*?) $CMD_DELIM //x) {
9497 if ($command =~ / ^ $REPLACE_CMD= (.*) /x) {
9500 elsif ($command =~ / ^ $MAP_TYPE_CMD= (.*) /x) {
9504 $file->carp_bad_line("Unknown command line: '$1'");
9510 if ($default_map eq $CODE_POINT && $map =~ / ^ $code_point_re $/x)
9513 # Here, we have a map to a particular code point, and the
9514 # default map is to a code point itself. If the range
9515 # includes the particular code point, change that portion of
9516 # the range to the default. This makes sure that in the final
9517 # table only the non-defaults are listed.
9518 my $decimal_map = hex $map;
9519 if ($low <= $decimal_map && $decimal_map <= $high) {
9521 # If the range includes stuff before or after the map
9522 # we're changing, split it and process the split-off parts
9524 if ($low < $decimal_map) {
9525 $file->insert_adjusted_lines(
9526 sprintf("%04X..%04X; %s; %s",
9532 if ($high > $decimal_map) {
9533 $file->insert_adjusted_lines(
9534 sprintf("%04X..%04X; %s; %s",
9540 $low = $high = $decimal_map;
9545 # If we can tell that this is a synonym for the default map, use
9546 # the default one instead.
9547 if ($property_type != $STRING
9548 && $property_type != $UNKNOWN)
9550 my $table = $property_object->table($map);
9551 if (defined $table && $table == $default_table) {
9552 $map = $default_map;
9556 # And figure out the map type if not known.
9557 if (! defined $map_type || $map_type == $COMPUTE_NO_MULTI_CP) {
9558 if ($map eq "") { # Nulls are always $NULL map type
9560 } # Otherwise, non-strings, and those that don't allow
9561 # $MULTI_CP, and those that aren't multiple code points are
9564 (($property_type != $STRING && $property_type != $UNKNOWN)
9565 || (defined $map_type && $map_type == $COMPUTE_NO_MULTI_CP)
9566 || $map !~ /^ $code_point_re ( \ $code_point_re )+ $ /x)
9571 $map_type = $MULTI_CP;
9575 $property_object->add_map($low, $high,
9578 Replace => $replace);
9579 } # End of loop through file's lines
9585 { # Closure for UnicodeData.txt handling
9587 # This file was the first one in the UCD; its design leads to some
9588 # awkwardness in processing. Here is a sample line:
9589 # 0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061;
9590 # The fields in order are:
9591 my $i = 0; # The code point is in field 0, and is shifted off.
9592 my $CHARNAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A")
9593 my $CATEGORY = $i++; # category (e.g. "Lu")
9594 my $CCC = $i++; # Canonical combining class (e.g. "230")
9595 my $BIDI = $i++; # directional class (e.g. "L")
9596 my $PERL_DECOMPOSITION = $i++; # decomposition mapping
9597 my $PERL_DECIMAL_DIGIT = $i++; # decimal digit value
9598 my $NUMERIC_TYPE_OTHER_DIGIT = $i++; # digit value, like a superscript
9599 # Dual-use in this program; see below
9600 my $NUMERIC = $i++; # numeric value
9601 my $MIRRORED = $i++; # ? mirrored
9602 my $UNICODE_1_NAME = $i++; # name in Unicode 1.0
9603 my $COMMENT = $i++; # iso comment
9604 my $UPPER = $i++; # simple uppercase mapping
9605 my $LOWER = $i++; # simple lowercase mapping
9606 my $TITLE = $i++; # simple titlecase mapping
9607 my $input_field_count = $i;
9609 # This routine in addition outputs these extra fields:
9610 my $DECOMP_TYPE = $i++; # Decomposition type
9612 # These fields are modifications of ones above, and are usually
9613 # suppressed; they must come last, as for speed, the loop upper bound is
9614 # normally set to ignore them
9615 my $NAME = $i++; # This is the strict name field, not the one that
9617 my $DECOMP_MAP = $i++; # Strict decomposition mapping; not the one used
9618 # by Unicode::Normalize
9619 my $last_field = $i - 1;
9621 # All these are read into an array for each line, with the indices defined
9622 # above. The empty fields in the example line above indicate that the
9623 # value is defaulted. The handler called for each line of the input
9624 # changes these to their defaults.
9626 # Here are the official names of the properties, in a parallel array:
9628 $field_names[$BIDI] = 'Bidi_Class';
9629 $field_names[$CATEGORY] = 'General_Category';
9630 $field_names[$CCC] = 'Canonical_Combining_Class';
9631 $field_names[$CHARNAME] = 'Perl_Charnames';
9632 $field_names[$COMMENT] = 'ISO_Comment';
9633 $field_names[$DECOMP_MAP] = 'Decomposition_Mapping';
9634 $field_names[$DECOMP_TYPE] = 'Decomposition_Type';
9635 $field_names[$LOWER] = 'Lowercase_Mapping';
9636 $field_names[$MIRRORED] = 'Bidi_Mirrored';
9637 $field_names[$NAME] = 'Name';
9638 $field_names[$NUMERIC] = 'Numeric_Value';
9639 $field_names[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric_Type';
9640 $field_names[$PERL_DECIMAL_DIGIT] = 'Perl_Decimal_Digit';
9641 $field_names[$PERL_DECOMPOSITION] = 'Perl_Decomposition_Mapping';
9642 $field_names[$TITLE] = 'Titlecase_Mapping';
9643 $field_names[$UNICODE_1_NAME] = 'Unicode_1_Name';
9644 $field_names[$UPPER] = 'Uppercase_Mapping';
9646 # Some of these need a little more explanation:
9647 # The $PERL_DECIMAL_DIGIT field does not lead to an official Unicode
9648 # property, but is used in calculating the Numeric_Type. Perl however,
9649 # creates a file from this field, so a Perl property is created from it.
9650 # Similarly, the Other_Digit field is used only for calculating the
9651 # Numeric_Type, and so it can be safely re-used as the place to store
9652 # the value for Numeric_Type; hence it is referred to as
9653 # $NUMERIC_TYPE_OTHER_DIGIT.
9654 # The input field named $PERL_DECOMPOSITION is a combination of both the
9655 # decomposition mapping and its type. Perl creates a file containing
9656 # exactly this field, so it is used for that. The two properties are
9657 # separated into two extra output fields, $DECOMP_MAP and $DECOMP_TYPE.
9658 # $DECOMP_MAP is usually suppressed (unless the lists are changed to
9659 # output it), as Perl doesn't use it directly.
9660 # The input field named here $CHARNAME is used to construct the
9661 # Perl_Charnames property, which is a combination of the Name property
9662 # (which the input field contains), and the Unicode_1_Name property, and
9663 # others from other files. Since, the strict Name property is not used
9664 # by Perl, this field is used for the table that Perl does use. The
9665 # strict Name property table is usually suppressed (unless the lists are
9666 # changed to output it), so it is accumulated in a separate field,
9667 # $NAME, which to save time is discarded unless the table is actually to
9670 # This file is processed like most in this program. Control is passed to
9671 # process_generic_property_file() which calls filter_UnicodeData_line()
9672 # for each input line. This filter converts the input into line(s) that
9673 # process_generic_property_file() understands. There is also a setup
9674 # routine called before any of the file is processed, and a handler for
9675 # EOF processing, all in this closure.
9677 # A huge speed-up occurred at the cost of some added complexity when these
9678 # routines were altered to buffer the outputs into ranges. Almost all the
9679 # lines of the input file apply to just one code point, and for most
9680 # properties, the map for the next code point up is the same as the
9681 # current one. So instead of creating a line for each property for each
9682 # input line, filter_UnicodeData_line() remembers what the previous map
9683 # of a property was, and doesn't generate a line to pass on until it has
9684 # to, as when the map changes; and that passed-on line encompasses the
9685 # whole contiguous range of code points that have the same map for that
9686 # property. This means a slight amount of extra setup, and having to
9687 # flush these buffers on EOF, testing if the maps have changed, plus
9688 # remembering state information in the closure. But it means a lot less
9689 # real time in not having to change the data base for each property on
9692 # Another complication is that there are already a few ranges designated
9693 # in the input. There are two lines for each, with the same maps except
9694 # the code point and name on each line. This was actually the hardest
9695 # thing to design around. The code points in those ranges may actually
9696 # have real maps not given by these two lines. These maps will either
9697 # be algorithmically determinable, or in the extracted files furnished
9698 # with the UCD. In the event of conflicts between these extracted files,
9699 # and this one, Unicode says that this one prevails. But it shouldn't
9700 # prevail for conflicts that occur in these ranges. The data from the
9701 # extracted files prevails in those cases. So, this program is structured
9702 # so that those files are processed first, storing maps. Then the other
9703 # files are processed, generally overwriting what the extracted files
9704 # stored. But just the range lines in this input file are processed
9705 # without overwriting. This is accomplished by adding a special string to
9706 # the lines output to tell process_generic_property_file() to turn off the
9707 # overwriting for just this one line.
9708 # A similar mechanism is used to tell it that the map is of a non-default
9711 sub setup_UnicodeData { # Called before any lines of the input are read
9713 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9715 # Create a new property specially located that is a combination of the
9716 # various Name properties: Name, Unicode_1_Name, Named Sequences, and
9717 # Name_Alias properties. (The final duplicates elements of the
9718 # first.) A comment for it will later be constructed based on the
9719 # actual properties present and used
9720 $perl_charname = Property->new('Perl_Charnames',
9721 Core_Access => '\N{...} and "use charnames"',
9723 Directory => File::Spec->curdir(),
9726 Perl_Extension => 1,
9727 Range_Size_1 => \&output_perl_charnames_line,
9731 my $Perl_decomp = Property->new('Perl_Decomposition_Mapping',
9732 Directory => File::Spec->curdir(),
9733 File => 'Decomposition',
9734 Format => $DECOMP_STRING_FORMAT,
9736 Perl_Extension => 1,
9737 Default_Map => $CODE_POINT,
9739 # normalize.pm can't cope with these
9740 Output_Range_Counts => 0,
9742 # This is a specially formatted table
9743 # explicitly for normalize.pm, which
9744 # is expecting a particular format,
9745 # which means that mappings containing
9746 # multiple code points are in the main
9748 Map_Type => $COMPUTE_NO_MULTI_CP,
9751 $Perl_decomp->add_comment(join_lines(<<END
9752 This mapping is a combination of the Unicode 'Decomposition_Type' and
9753 'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is
9754 identical to the official Unicode 'Decomposition_Mapping' property except for
9756 1) It omits the algorithmically determinable Hangul syllable decompositions,
9757 which normalize.pm handles algorithmically.
9758 2) It contains the decomposition type as well. Non-canonical decompositions
9759 begin with a word in angle brackets, like <super>, which denotes the
9760 compatible decomposition type. If the map does not begin with the <angle
9761 brackets>, the decomposition is canonical.
9765 my $Decimal_Digit = Property->new("Perl_Decimal_Digit",
9767 Perl_Extension => 1,
9768 File => 'Digit', # Trad. location
9769 Directory => $map_directory,
9773 $Decimal_Digit->add_comment(join_lines(<<END
9774 This file gives the mapping of all code points which represent a single
9775 decimal digit [0-9] to their respective digits. For example, the code point
9776 U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those
9777 that have Numeric_Type=Decimal; not special things, like subscripts nor Roman
9782 # These properties are not used for generating anything else, and are
9783 # usually not output. By making them last in the list, we can just
9784 # change the high end of the loop downwards to avoid the work of
9785 # generating a table(s) that is/are just going to get thrown away.
9786 if (! property_ref('Decomposition_Mapping')->to_output_map
9787 && ! property_ref('Name')->to_output_map)
9789 $last_field = min($NAME, $DECOMP_MAP) - 1;
9790 } elsif (property_ref('Decomposition_Mapping')->to_output_map) {
9791 $last_field = $DECOMP_MAP;
9792 } elsif (property_ref('Name')->to_output_map) {
9793 $last_field = $NAME;
9798 my $first_time = 1; # ? Is this the first line of the file
9799 my $in_range = 0; # ? Are we in one of the file's ranges
9800 my $previous_cp; # hex code point of previous line
9801 my $decimal_previous_cp = -1; # And its decimal equivalent
9802 my @start; # For each field, the current starting
9803 # code point in hex for the range
9804 # being accumulated.
9805 my @fields; # The input fields;
9806 my @previous_fields; # And those from the previous call
9808 sub filter_UnicodeData_line {
9809 # Handle a single input line from UnicodeData.txt; see comments above
9810 # Conceptually this takes a single line from the file containing N
9811 # properties, and converts it into N lines with one property per line,
9812 # which is what the final handler expects. But there are
9813 # complications due to the quirkiness of the input file, and to save
9814 # time, it accumulates ranges where the property values don't change
9815 # and only emits lines when necessary. This is about an order of
9816 # magnitude fewer lines emitted.
9819 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
9821 # $_ contains the input line.
9822 # -1 in split means retain trailing null fields
9823 (my $cp, @fields) = split /\s*;\s*/, $_, -1;
9825 #local $to_trace = 1 if main::DEBUG;
9826 trace $cp, @fields , $input_field_count if main::DEBUG && $to_trace;
9827 if (@fields > $input_field_count) {
9828 $file->carp_bad_line('Extra fields');
9833 my $decimal_cp = hex $cp;
9835 # We have to output all the buffered ranges when the next code point
9836 # is not exactly one after the previous one, which means there is a
9837 # gap in the ranges.
9838 my $force_output = ($decimal_cp != $decimal_previous_cp + 1);
9840 # The decomposition mapping field requires special handling. It looks
9843 # <compat> 0032 0020
9846 # The decomposition type is enclosed in <brackets>; if missing, it
9847 # means the type is canonical. There are two decomposition mapping
9848 # tables: the one for use by Perl's normalize.pm has a special format
9849 # which is this field intact; the other, for general use is of
9850 # standard format. In either case we have to find the decomposition
9851 # type. Empty fields have None as their type, and map to the code
9853 if ($fields[$PERL_DECOMPOSITION] eq "") {
9854 $fields[$DECOMP_TYPE] = 'None';
9855 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION] = $CODE_POINT;
9858 ($fields[$DECOMP_TYPE], my $map) = $fields[$PERL_DECOMPOSITION]
9859 =~ / < ( .+? ) > \s* ( .+ ) /x;
9860 if (! defined $fields[$DECOMP_TYPE]) {
9861 $fields[$DECOMP_TYPE] = 'Canonical';
9862 $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION];
9865 $fields[$DECOMP_MAP] = $map;
9869 # The 3 numeric fields also require special handling. The 2 digit
9870 # fields must be either empty or match the number field. This means
9871 # that if it is empty, they must be as well, and the numeric type is
9872 # None, and the numeric value is 'Nan'.
9873 # The decimal digit field must be empty or match the other digit
9874 # field. If the decimal digit field is non-empty, the code point is
9875 # a decimal digit, and the other two fields will have the same value.
9876 # If it is empty, but the other digit field is non-empty, the code
9877 # point is an 'other digit', and the number field will have the same
9878 # value as the other digit field. If the other digit field is empty,
9879 # but the number field is non-empty, the code point is a generic
9881 if ($fields[$NUMERIC] eq "") {
9882 if ($fields[$PERL_DECIMAL_DIGIT] ne ""
9883 || $fields[$NUMERIC_TYPE_OTHER_DIGIT] ne ""
9885 $file->carp_bad_line("Numeric values inconsistent. Trying to process anyway");
9887 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'None';
9888 $fields[$NUMERIC] = 'NaN';
9891 $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;
9892 if ($fields[$PERL_DECIMAL_DIGIT] ne "") {
9893 $file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$PERL_DECIMAL_DIGIT] != $fields[$NUMERIC];
9894 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Decimal';
9896 elsif ($fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "") {
9897 $file->carp_bad_line("$fields[$NUMERIC_TYPE_OTHER_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$NUMERIC_TYPE_OTHER_DIGIT] != $fields[$NUMERIC];
9898 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Digit';
9901 $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric';
9903 # Rationals require extra effort.
9904 register_fraction($fields[$NUMERIC])
9905 if $fields[$NUMERIC] =~ qr{/};
9909 # For the properties that have empty fields in the file, and which
9910 # mean something different from empty, change them to that default.
9911 # Certain fields just haven't been empty so far in any Unicode
9912 # version, so don't look at those, namely $MIRRORED, $BIDI, $CCC,
9913 # $CATEGORY. This leaves just the two fields, and so we hard-code in
9914 # the defaults; which are very unlikely to ever change.
9915 $fields[$UPPER] = $CODE_POINT if $fields[$UPPER] eq "";
9916 $fields[$LOWER] = $CODE_POINT if $fields[$LOWER] eq "";
9918 # UAX44 says that if title is empty, it is the same as whatever upper
9920 $fields[$TITLE] = $fields[$UPPER] if $fields[$TITLE] eq "";
9922 # There are a few pairs of lines like:
9923 # AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
9924 # D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
9925 # that define ranges. These should be processed after the fields are
9926 # adjusted above, as they may override some of them; but mostly what
9927 # is left is to possibly adjust the $CHARNAME field. The names of all the
9928 # paired lines start with a '<', but this is also true of '<control>,
9929 # which isn't one of these special ones.
9930 if ($fields[$CHARNAME] eq '<control>') {
9932 # Some code points in this file have the pseudo-name
9933 # '<control>', but the official name for such ones is the null
9934 # string. For charnames.pm, we use the Unicode version 1 name
9935 $fields[$NAME] = "";
9936 $fields[$CHARNAME] = $fields[$UNICODE_1_NAME];
9938 # We had better not be in between range lines.
9940 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9944 elsif (substr($fields[$CHARNAME], 0, 1) ne '<') {
9946 # Here is a non-range line. We had better not be in between range
9949 $file->carp_bad_line("Expecting a closing range line, not a $fields[$CHARNAME]'. Trying anyway");
9952 if ($fields[$CHARNAME] =~ s/- $cp $//x) {
9954 # These are code points whose names end in their code points,
9955 # which means the names are algorithmically derivable from the
9956 # code points. To shorten the output Name file, the algorithm
9957 # for deriving these is placed in the file instead of each
9958 # code point, so they have map type $CP_IN_NAME
9959 $fields[$CHARNAME] = $CMD_DELIM
9964 . $fields[$CHARNAME];
9966 $fields[$NAME] = $fields[$CHARNAME];
9968 elsif ($fields[$CHARNAME] =~ /^<(.+), First>$/) {
9969 $fields[$CHARNAME] = $fields[$NAME] = $1;
9971 # Here we are at the beginning of a range pair.
9973 $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$CHARNAME]'. Trying anyway");
9977 # Because the properties in the range do not overwrite any already
9978 # in the db, we must flush the buffers of what's already there, so
9979 # they get handled in the normal scheme.
9983 elsif ($fields[$CHARNAME] !~ s/^<(.+), Last>$/$1/) {
9984 $file->carp_bad_line("Unexpected name starting with '<' $fields[$CHARNAME]. Ignoring this line.");
9988 else { # Here, we are at the last line of a range pair.
9991 $file->carp_bad_line("Unexpected end of range $fields[$CHARNAME] when not in one. Ignoring this line.");
9997 $fields[$NAME] = $fields[$CHARNAME];
9999 # Check that the input is valid: that the closing of the range is
10000 # the same as the beginning.
10001 foreach my $i (0 .. $last_field) {
10002 next if $fields[$i] eq $previous_fields[$i];
10003 $file->carp_bad_line("Expecting '$fields[$i]' to be the same as '$previous_fields[$i]'. Bad News. Trying anyway");
10006 # The processing differs depending on the type of range,
10007 # determined by its $CHARNAME
10008 if ($fields[$CHARNAME] =~ /^Hangul Syllable/) {
10010 # Check that the data looks right.
10011 if ($decimal_previous_cp != $SBase) {
10012 $file->carp_bad_line("Unexpected Hangul syllable start = $previous_cp. Bad News. Results will be wrong");
10014 if ($decimal_cp != $SBase + $SCount - 1) {
10015 $file->carp_bad_line("Unexpected Hangul syllable end = $cp. Bad News. Results will be wrong");
10018 # The Hangul syllable range has a somewhat complicated name
10019 # generation algorithm. Each code point in it has a canonical
10020 # decomposition also computable by an algorithm. The
10021 # perl decomposition map table built from these is used only
10022 # by normalize.pm, which has the algorithm built in it, so the
10023 # decomposition maps are not needed, and are large, so are
10024 # omitted from it. If the full decomposition map table is to
10025 # be output, the decompositions are generated for it, in the
10026 # EOF handling code for this input file.
10028 $previous_fields[$DECOMP_TYPE] = 'Canonical';
10030 # This range is stored in our internal structure with its
10031 # own map type, different from all others.
10032 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
10038 . $fields[$CHARNAME];
10040 elsif ($fields[$CHARNAME] =~ /^CJK/) {
10042 # The name for these contains the code point itself, and all
10043 # are defined to have the same base name, regardless of what
10044 # is in the file. They are stored in our internal structure
10045 # with a map type of $CP_IN_NAME
10046 $previous_fields[$CHARNAME] = $previous_fields[$NAME]
10052 . 'CJK UNIFIED IDEOGRAPH';
10055 elsif ($fields[$CATEGORY] eq 'Co'
10056 || $fields[$CATEGORY] eq 'Cs')
10058 # The names of all the code points in these ranges are set to
10059 # null, as there are no names for the private use and
10060 # surrogate code points.
10062 $previous_fields[$CHARNAME] = $previous_fields[$NAME] = "";
10065 $file->carp_bad_line("Unexpected code point range $fields[$CHARNAME] because category is $fields[$CATEGORY]. Attempting to process it.");
10068 # The first line of the range caused everything else to be output,
10069 # and then its values were stored as the beginning values for the
10070 # next set of ranges, which this one ends. Now, for each value,
10071 # add a command to tell the handler that these values should not
10072 # replace any existing ones in our database.
10073 foreach my $i (0 .. $last_field) {
10074 $previous_fields[$i] = $CMD_DELIM
10079 . $previous_fields[$i];
10082 # And change things so it looks like the entire range has been
10083 # gone through with this being the final part of it. Adding the
10084 # command above to each field will cause this range to be flushed
10085 # during the next iteration, as it guaranteed that the stored
10086 # field won't match whatever value the next one has.
10087 $previous_cp = $cp;
10088 $decimal_previous_cp = $decimal_cp;
10090 # We are now set up for the next iteration; so skip the remaining
10091 # code in this subroutine that does the same thing, but doesn't
10092 # know about these ranges.
10098 # On the very first line, we fake it so the code below thinks there is
10099 # nothing to output, and initialize so that when it does get output it
10100 # uses the first line's values for the lowest part of the range.
10101 # (One could avoid this by using peek(), but then one would need to
10102 # know the adjustments done above and do the same ones in the setup
10103 # routine; not worth it)
10106 @previous_fields = @fields;
10107 @start = ($cp) x scalar @fields;
10108 $decimal_previous_cp = $decimal_cp - 1;
10111 # For each field, output the stored up ranges that this code point
10112 # doesn't fit in. Earlier we figured out if all ranges should be
10113 # terminated because of changing the replace or map type styles, or if
10114 # there is a gap between this new code point and the previous one, and
10115 # that is stored in $force_output. But even if those aren't true, we
10116 # need to output the range if this new code point's value for the
10117 # given property doesn't match the stored range's.
10118 #local $to_trace = 1 if main::DEBUG;
10119 foreach my $i (0 .. $last_field) {
10120 my $field = $fields[$i];
10121 if ($force_output || $field ne $previous_fields[$i]) {
10123 # Flush the buffer of stored values.
10124 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
10126 # Start a new range with this code point and its value
10128 $previous_fields[$i] = $field;
10132 # Set the values for the next time.
10133 $previous_cp = $cp;
10134 $decimal_previous_cp = $decimal_cp;
10136 # The input line has generated whatever adjusted lines are needed, and
10137 # should not be looked at further.
10142 sub EOF_UnicodeData {
10143 # Called upon EOF to flush the buffers, and create the Hangul
10144 # decomposition mappings if needed.
10147 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10149 # Flush the buffers.
10150 foreach my $i (1 .. $last_field) {
10151 $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]");
10154 if (-e 'Jamo.txt') {
10156 # The algorithm is published by Unicode, based on values in
10157 # Jamo.txt, (which should have been processed before this
10158 # subroutine), and the results left in %Jamo
10160 Carp::my_carp_bug("Jamo.txt should be processed before Unicode.txt. Hangul syllables not generated.");
10164 # If the full decomposition map table is being output, insert
10165 # into it the Hangul syllable mappings. This is to avoid having
10166 # to publish a subroutine in it to compute them. (which would
10167 # essentially be this code.) This uses the algorithm published by
10169 if (property_ref('Decomposition_Mapping')->to_output_map) {
10170 for (my $S = $SBase; $S < $SBase + $SCount; $S++) {
10172 my $SIndex = $S - $SBase;
10173 my $L = $LBase + $SIndex / $NCount;
10174 my $V = $VBase + ($SIndex % $NCount) / $TCount;
10175 my $T = $TBase + $SIndex % $TCount;
10177 trace "L=$L, V=$V, T=$T" if main::DEBUG && $to_trace;
10178 my $decomposition = sprintf("%04X %04X", $L, $V);
10179 $decomposition .= sprintf(" %04X", $T) if $T != $TBase;
10180 $file->insert_adjusted_lines(
10181 sprintf("%04X; Decomposition_Mapping; %s",
10191 sub filter_v1_ucd {
10192 # Fix UCD lines in version 1. This is probably overkill, but this
10193 # fixes some glaring errors in Version 1 UnicodeData.txt. That file:
10194 # 1) had many Hangul (U+3400 - U+4DFF) code points that were later
10195 # removed. This program retains them
10196 # 2) didn't include ranges, which it should have, and which are now
10197 # added in @corrected_lines below. It was hand populated by
10198 # taking the data from Version 2, verified by analyzing
10200 # 3) There is a syntax error in the entry for U+09F8 which could
10201 # cause problems for utf8_heavy, and so is changed. It's
10202 # numeric value was simply a minus sign, without any number.
10203 # (Eventually Unicode changed the code point to non-numeric.)
10204 # 4) The decomposition types often don't match later versions
10205 # exactly, and the whole syntax of that field is different; so
10206 # the syntax is changed as well as the types to their later
10207 # terminology. Otherwise normalize.pm would be very unhappy
10208 # 5) Many ccc classes are different. These are left intact.
10209 # 6) U+FF10 - U+FF19 are missing their numeric values in all three
10210 # fields. These are unchanged because it doesn't really cause
10211 # problems for Perl.
10212 # 7) A number of code points, such as controls, don't have their
10213 # Unicode Version 1 Names in this file. These are unchanged.
10215 my @corrected_lines = split /\n/, <<'END';
10216 4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
10217 9FA5;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
10218 E000;<Private Use, First>;Co;0;L;;;;;N;;;;;
10219 F8FF;<Private Use, Last>;Co;0;L;;;;;N;;;;;
10220 F900;<CJK Compatibility Ideograph, First>;Lo;0;L;;;;;N;;;;;
10221 FA2D;<CJK Compatibility Ideograph, Last>;Lo;0;L;;;;;N;;;;;
10225 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10227 #local $to_trace = 1 if main::DEBUG;
10228 trace $_ if main::DEBUG && $to_trace;
10230 # -1 => retain trailing null fields
10231 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10233 # At the first place that is wrong in the input, insert all the
10234 # corrections, replacing the wrong line.
10235 if ($code_point eq '4E00') {
10236 my @copy = @corrected_lines;
10238 ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10240 $file->insert_lines(@copy);
10244 if ($fields[$NUMERIC] eq '-') {
10245 $fields[$NUMERIC] = '-1'; # This is what 2.0 made it.
10248 if ($fields[$PERL_DECOMPOSITION] ne "") {
10250 # Several entries have this change to superscript 2 or 3 in the
10251 # middle. Convert these to the modern version, which is to use
10252 # the actual U+00B2 and U+00B3 (the superscript forms) instead.
10253 # So 'HHHH HHHH <+sup> 0033 <-sup> HHHH' becomes
10254 # 'HHHH HHHH 00B3 HHHH'.
10255 # It turns out that all of these that don't have another
10256 # decomposition defined at the beginning of the line have the
10257 # <square> decomposition in later releases.
10258 if ($code_point ne '00B2' && $code_point ne '00B3') {
10259 if ($fields[$PERL_DECOMPOSITION]
10260 =~ s/<\+sup> 003([23]) <-sup>/00B$1/)
10262 if (substr($fields[$PERL_DECOMPOSITION], 0, 1) ne '<') {
10263 $fields[$PERL_DECOMPOSITION] = '<square> '
10264 . $fields[$PERL_DECOMPOSITION];
10269 # If is like '<+circled> 0052 <-circled>', convert to
10271 $fields[$PERL_DECOMPOSITION] =~
10272 s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/x;
10274 # Convert '<join> HHHH HHHH <join>' to '<medial> HHHH HHHH', etc.
10275 $fields[$PERL_DECOMPOSITION] =~
10276 s/ <join> \s* (.*?) \s* <no-join> /<final> $1/x
10277 or $fields[$PERL_DECOMPOSITION] =~
10278 s/ <join> \s* (.*?) \s* <join> /<medial> $1/x
10279 or $fields[$PERL_DECOMPOSITION] =~
10280 s/ <no-join> \s* (.*?) \s* <join> /<initial> $1/x
10281 or $fields[$PERL_DECOMPOSITION] =~
10282 s/ <no-join> \s* (.*?) \s* <no-join> /<isolated> $1/x;
10284 # Convert '<break> HHHH HHHH <break>' to '<break> HHHH', etc.
10285 $fields[$PERL_DECOMPOSITION] =~
10286 s/ <(break|no-break)> \s* (.*?) \s* <\1> /<$1> $2/x;
10288 # Change names to modern form.
10289 $fields[$PERL_DECOMPOSITION] =~ s/<font variant>/<font>/g;
10290 $fields[$PERL_DECOMPOSITION] =~ s/<no-break>/<noBreak>/g;
10291 $fields[$PERL_DECOMPOSITION] =~ s/<circled>/<circle>/g;
10292 $fields[$PERL_DECOMPOSITION] =~ s/<break>/<fraction>/g;
10294 # One entry has weird braces
10295 $fields[$PERL_DECOMPOSITION] =~ s/[{}]//g;
10298 $_ = join ';', $code_point, @fields;
10299 trace $_ if main::DEBUG && $to_trace;
10303 sub filter_v2_1_5_ucd {
10304 # A dozen entries in this 2.1.5 file had the mirrored and numeric
10305 # columns swapped; These all had mirrored be 'N'. So if the numeric
10306 # column appears to be N, swap it back.
10308 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10309 if ($fields[$NUMERIC] eq 'N') {
10310 $fields[$NUMERIC] = $fields[$MIRRORED];
10311 $fields[$MIRRORED] = 'N';
10312 $_ = join ';', $code_point, @fields;
10317 sub filter_v6_ucd {
10319 # Unicode 6.0 co-opted the name BELL for U+1F514, but we haven't
10320 # accepted that yet to allow for some deprecation cycles.
10322 return if $_ !~ /^(?:0007|1F514|070F);/;
10324 my ($code_point, @fields) = split /\s*;\s*/, $_, -1;
10325 if ($code_point eq '0007') {
10326 $fields[$CHARNAME] = "";
10328 elsif ($code_point eq '070F') { # Unicode Corrigendum #8; see
10329 # http://www.unicode.org/versions/corrigendum8.html
10330 $fields[$BIDI] = "AL";
10332 elsif ($^V lt v5.17.0) { # For 5.18 will convert to use Unicode's name
10333 $fields[$CHARNAME] = "";
10336 $_ = join ';', $code_point, @fields;
10340 } # End closure for UnicodeData
10342 sub process_GCB_test {
10345 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10347 while ($file->next_line) {
10348 push @backslash_X_tests, $_;
10354 sub process_NamedSequences {
10355 # NamedSequences.txt entries are just added to an array. Because these
10356 # don't look like the other tables, they have their own handler.
10358 # LATIN CAPITAL LETTER A WITH MACRON AND GRAVE;0100 0300
10360 # This just adds the sequence to an array for later handling
10363 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10365 while ($file->next_line) {
10366 my ($name, $sequence, @remainder) = split /\s*;\s*/, $_, -1;
10368 $file->carp_bad_line(
10369 "Doesn't look like 'KHMER VOWEL SIGN OM;17BB 17C6'");
10373 # Note single \t in keeping with special output format of
10374 # Perl_charnames. But it turns out that the code points don't have to
10375 # be 5 digits long, like the rest, based on the internal workings of
10376 # charnames.pm. This could be easily changed for consistency.
10377 push @named_sequences, "$sequence\t$name";
10386 sub filter_early_ea_lb {
10387 # Fixes early EastAsianWidth.txt and LineBreak.txt files. These had a
10388 # third field be the name of the code point, which can be ignored in
10389 # most cases. But it can be meaningful if it marks a range:
10390 # 33FE;W;IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY THIRTY-ONE
10391 # 3400;W;<CJK Ideograph Extension A, First>
10393 # We need to see the First in the example above to know it's a range.
10394 # They did not use the later range syntaxes. This routine changes it
10395 # to use the modern syntax.
10396 # $1 is the Input_file object.
10398 my @fields = split /\s*;\s*/;
10399 if ($fields[2] =~ /^<.*, First>/) {
10400 $first_range = $fields[0];
10403 elsif ($fields[2] =~ /^<.*, Last>/) {
10404 $_ = $_ = "$first_range..$fields[0]; $fields[1]";
10407 undef $first_range;
10408 $_ = "$fields[0]; $fields[1]";
10415 sub filter_old_style_arabic_shaping {
10416 # Early versions used a different term for the later one.
10418 my @fields = split /\s*;\s*/;
10419 $fields[3] =~ s/<no shaping>/No_Joining_Group/;
10420 $fields[3] =~ s/\s+/_/g; # Change spaces to underscores
10421 $_ = join ';', @fields;
10425 sub filter_arabic_shaping_line {
10426 # ArabicShaping.txt has entries that look like:
10427 # 062A; TEH; D; BEH
10428 # The field containing 'TEH' is not used. The next field is Joining_Type
10429 # and the last is Joining_Group
10430 # This generates two lines to pass on, one for each property on the input
10434 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10436 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10439 $file->carp_bad_line('Extra fields');
10444 $file->insert_adjusted_lines("$fields[0]; Joining_Group; $fields[3]");
10445 $_ = "$fields[0]; Joining_Type; $fields[2]";
10451 my $lc; # Table for lowercase mapping
10455 sub setup_special_casing {
10456 # SpecialCasing.txt contains the non-simple case change mappings. The
10457 # simple ones are in UnicodeData.txt, which should already have been
10458 # read in to the full property data structures, so as to initialize
10459 # these with the simple ones. Then the SpecialCasing.txt entries
10460 # overwrite the ones which have different full mappings.
10462 # This routine sees if the simple mappings are to be output, and if
10463 # so, copies what has already been put into the full mapping tables,
10464 # while they still contain only the simple mappings.
10466 # The reason it is done this way is that the simple mappings are
10467 # probably not going to be output, so it saves work to initialize the
10468 # full tables with the simple mappings, and then overwrite those
10469 # relatively few entries in them that have different full mappings,
10470 # and thus skip the simple mapping tables altogether.
10472 # New tables with just the simple mappings that are overridden by the
10473 # full ones are constructed. These are for Unicode::UCD, which
10474 # requires the simple mappings. The Case_Folding table is a combined
10475 # table of both the simple and full mappings, with the full ones being
10476 # in the hash, and the simple ones, even those overridden by the hash,
10477 # being in the base table. That same mechanism could have been
10478 # employed here, except that the docs have said that the generated
10479 # files are usuable directly by programs, so we dare not change the
10480 # format in any way.
10483 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10485 $lc = property_ref('lc');
10486 $tc = property_ref('tc');
10487 $uc = property_ref('uc');
10489 # For each of the case change mappings...
10490 foreach my $case_table ($lc, $tc, $uc) {
10491 my $case = $case_table->name;
10492 my $full = property_ref($case);
10493 unless (defined $full && ! $full->is_empty) {
10494 Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated.");
10497 # The simple version's name in each mapping merely has an 's' in
10498 # front of the full one's
10499 my $simple = property_ref('s' . $case);
10500 $simple->initialize($full) if $simple->to_output_map();
10502 my $simple_only = Property->new("_s$case",
10504 Default_Map => $CODE_POINT,
10505 Perl_Extension => 1,
10506 Internal_Only => 1,
10507 Description => "The simple mappings for $case for code points that have full mappings as well");
10508 $simple_only->set_to_output_map($INTERNAL_MAP);
10509 $simple_only->add_comment(join_lines( <<END
10510 This file is for UCD.pm so that it can construct simple mappings that would
10511 otherwise be lost because they are overridden by full mappings.
10519 sub filter_special_casing_line {
10520 # Change the format of $_ from SpecialCasing.txt into something that
10521 # the generic handler understands. Each input line contains three
10522 # case mappings. This will generate three lines to pass to the
10523 # generic handler for each of those.
10525 # The input syntax (after stripping comments and trailing white space
10526 # is like one of the following (with the final two being entries that
10528 # 00DF; 00DF; 0053 0073; 0053 0053; # LATIN SMALL LETTER SHARP S
10529 # 03A3; 03C2; 03A3; 03A3; Final_Sigma;
10530 # 0307; ; 0307; 0307; tr After_I; # COMBINING DOT ABOVE
10531 # Note the trailing semi-colon, unlike many of the input files. That
10532 # means that there will be an extra null field generated by the split
10535 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10537 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null
10540 # field #4 is when this mapping is conditional. If any of these get
10541 # implemented, it would be by hard-coding in the casing functions in
10542 # the Perl core, not through tables. But if there is a new condition
10543 # we don't know about, output a warning. We know about all the
10544 # conditions through 6.0
10545 if ($fields[4] ne "") {
10546 my @conditions = split ' ', $fields[4];
10547 if ($conditions[0] ne 'tr' # We know that these languages have
10548 # conditions, and some are multiple
10549 && $conditions[0] ne 'az'
10550 && $conditions[0] ne 'lt'
10552 # And, we know about a single condition Final_Sigma, but
10554 && ($v_version gt v5.2.0
10555 && (@conditions > 1 || $conditions[0] ne 'Final_Sigma')))
10557 $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");
10559 elsif ($conditions[0] ne 'Final_Sigma') {
10561 # Don't print out a message for Final_Sigma, because we
10562 # have hard-coded handling for it. (But the standard
10563 # could change what the rule should be, but it wouldn't
10564 # show up here anyway.
10566 print "# SKIPPING Special Casing: $_\n"
10567 if $verbosity >= $VERBOSE;
10572 elsif (@fields > 6 || (@fields == 6 && $fields[5] ne "" )) {
10573 $file->carp_bad_line('Extra fields');
10578 $_ = "$fields[0]; lc; $fields[1]";
10579 $file->insert_adjusted_lines("$fields[0]; tc; $fields[2]");
10580 $file->insert_adjusted_lines("$fields[0]; uc; $fields[3]");
10582 # Copy any simple case change to the special tables constructed if
10583 # being overridden by a multi-character case change.
10584 if ($fields[1] ne $fields[0]
10585 && (my $value = $lc->value_of(hex $fields[0])) ne $CODE_POINT)
10587 $file->insert_adjusted_lines("$fields[0]; _slc; $value");
10589 if ($fields[2] ne $fields[0]
10590 && (my $value = $tc->value_of(hex $fields[0])) ne $CODE_POINT)
10592 $file->insert_adjusted_lines("$fields[0]; _stc; $value");
10594 if ($fields[3] ne $fields[0]
10595 && (my $value = $uc->value_of(hex $fields[0])) ne $CODE_POINT)
10597 $file->insert_adjusted_lines("$fields[0]; _suc; $value");
10604 sub filter_old_style_case_folding {
10605 # This transforms $_ containing the case folding style of 3.0.1, to 3.1
10606 # and later style. Different letters were used in the earlier.
10609 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10611 my @fields = split /\s*;\s*/;
10612 if ($fields[0] =~ /^ 013 [01] $/x) { # The two turkish fields
10615 elsif ($fields[1] eq 'L') {
10616 $fields[1] = 'C'; # L => C always
10618 elsif ($fields[1] eq 'E') {
10619 if ($fields[2] =~ / /) { # E => C if one code point; F otherwise
10627 $file->carp_bad_line("Expecting L or E in second field");
10631 $_ = join("; ", @fields) . ';';
10635 { # Closure for case folding
10637 # Create the map for simple only if are going to output it, for otherwise
10638 # it takes no part in anything we do.
10639 my $to_output_simple;
10641 sub setup_case_folding($) {
10642 # Read in the case foldings in CaseFolding.txt. This handles both
10643 # simple and full case folding.
10646 = property_ref('Simple_Case_Folding')->to_output_map;
10648 # If we ever wanted to show that these tables were combined, a new
10649 # property method could be created, like set_combined_props()
10650 property_ref('Case_Folding')->add_comment(join_lines( <<END
10651 This file includes both the simple and full case folding maps. The simple
10652 ones are in the main body of the table below, and the full ones adding to or
10653 overriding them are in the hash.
10659 sub filter_case_folding_line {
10660 # Called for each line in CaseFolding.txt
10661 # Input lines look like:
10662 # 0041; C; 0061; # LATIN CAPITAL LETTER A
10663 # 00DF; F; 0073 0073; # LATIN SMALL LETTER SHARP S
10664 # 1E9E; S; 00DF; # LATIN CAPITAL LETTER SHARP S
10666 # 'C' means that folding is the same for both simple and full
10667 # 'F' that it is only for full folding
10668 # 'S' that it is only for simple folding
10669 # 'T' is locale-dependent, and ignored
10670 # 'I' is a type of 'F' used in some early releases.
10671 # Note the trailing semi-colon, unlike many of the input files. That
10672 # means that there will be an extra null field generated by the split
10673 # below, which we ignore and hence is not an error.
10676 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10678 my ($range, $type, $map, @remainder) = split /\s*;\s*/, $_, -1;
10679 if (@remainder > 1 || (@remainder == 1 && $remainder[0] ne "" )) {
10680 $file->carp_bad_line('Extra fields');
10685 if ($type eq 'T') { # Skip Turkic case folding, is locale dependent
10690 # C: complete, F: full, or I: dotted uppercase I -> dotless lowercase
10691 # I are all full foldings; S is single-char. For S, there is always
10692 # an F entry, so we must allow multiple values for the same code
10693 # point. Fortunately this table doesn't need further manipulation
10694 # which would preclude using multiple-values. The S is now included
10695 # so that _swash_inversion_hash() is able to construct closures
10696 # without having to worry about F mappings.
10697 if ($type eq 'C' || $type eq 'F' || $type eq 'I' || $type eq 'S') {
10698 $_ = "$range; Case_Folding; $CMD_DELIM$REPLACE_CMD=$MULTIPLE$CMD_DELIM$map";
10702 $file->carp_bad_line('Expecting C F I S or T in second field');
10705 # C and S are simple foldings, but simple case folding is not needed
10706 # unless we explicitly want its map table output.
10707 if ($to_output_simple && $type eq 'C' || $type eq 'S') {
10708 $file->insert_adjusted_lines("$range; Simple_Case_Folding; $map");
10714 } # End case fold closure
10716 sub filter_jamo_line {
10717 # Filter Jamo.txt lines. This routine mainly is used to populate hashes
10718 # from this file that is used in generating the Name property for Jamo
10719 # code points. But, it also is used to convert early versions' syntax
10720 # into the modern form. Here are two examples:
10721 # 1100; G # HANGUL CHOSEONG KIYEOK # Modern syntax
10722 # U+1100; G; HANGUL CHOSEONG KIYEOK # 2.0 syntax
10724 # The input is $_, the output is $_ filtered.
10726 my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields
10728 # Let the caller handle unexpected input. In earlier versions, there was
10729 # a third field which is supposed to be a comment, but did not have a '#'
10731 return if @fields > (($v_version gt v3.0.0) ? 2 : 3);
10733 $fields[0] =~ s/^U\+//; # Also, early versions had this extraneous
10736 # Some 2.1 versions had this wrong. Causes havoc with the algorithm.
10737 $fields[1] = 'R' if $fields[0] eq '1105';
10739 # Add to structure so can generate Names from it.
10740 my $cp = hex $fields[0];
10741 my $short_name = $fields[1];
10742 $Jamo{$cp} = $short_name;
10743 if ($cp <= $LBase + $LCount) {
10744 $Jamo_L{$short_name} = $cp - $LBase;
10746 elsif ($cp <= $VBase + $VCount) {
10747 $Jamo_V{$short_name} = $cp - $VBase;
10749 elsif ($cp <= $TBase + $TCount) {
10750 $Jamo_T{$short_name} = $cp - $TBase;
10753 Carp::my_carp_bug("Unexpected Jamo code point in $_");
10757 # Reassemble using just the first two fields to look like a typical
10758 # property file line
10759 $_ = "$fields[0]; $fields[1]";
10764 sub register_fraction($) {
10765 # This registers the input rational number so that it can be passed on to
10766 # utf8_heavy.pl, both in rational and floating forms.
10768 my $rational = shift;
10770 my $float = eval $rational;
10771 $nv_floating_to_rational{$float} = $rational;
10775 sub filter_numeric_value_line {
10776 # DNumValues contains lines of a different syntax than the typical
10778 # 0F33 ; -0.5 ; ; -1/2 # No TIBETAN DIGIT HALF ZERO
10780 # This routine transforms $_ containing the anomalous syntax to the
10781 # typical, by filtering out the extra columns, and convert early version
10782 # decimal numbers to strings that look like rational numbers.
10785 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10787 # Starting in 5.1, there is a rational field. Just use that, omitting the
10788 # extra columns. Otherwise convert the decimal number in the second field
10789 # to a rational, and omit extraneous columns.
10790 my @fields = split /\s*;\s*/, $_, -1;
10793 if ($v_version ge v5.1.0) {
10794 if (@fields != 4) {
10795 $file->carp_bad_line('Not 4 semi-colon separated fields');
10799 $rational = $fields[3];
10800 $_ = join '; ', @fields[ 0, 3 ];
10804 # Here, is an older Unicode file, which has decimal numbers instead of
10805 # rationals in it. Use the fraction to calculate the denominator and
10806 # convert to rational.
10808 if (@fields != 2 && @fields != 3) {
10809 $file->carp_bad_line('Not 2 or 3 semi-colon separated fields');
10814 my $codepoints = $fields[0];
10815 my $decimal = $fields[1];
10816 if ($decimal =~ s/\.0+$//) {
10818 # Anything ending with a decimal followed by nothing but 0's is an
10820 $_ = "$codepoints; $decimal";
10821 $rational = $decimal;
10826 if ($decimal =~ /\.50*$/) {
10830 # Here have the hardcoded repeating decimals in the fraction, and
10831 # the denominator they imply. There were only a few denominators
10832 # in the older Unicode versions of this file which this code
10833 # handles, so it is easy to convert them.
10835 # The 4 is because of a round-off error in the Unicode 3.2 files
10836 elsif ($decimal =~ /\.33*[34]$/ || $decimal =~ /\.6+7$/) {
10839 elsif ($decimal =~ /\.[27]50*$/) {
10842 elsif ($decimal =~ /\.[2468]0*$/) {
10845 elsif ($decimal =~ /\.16+7$/ || $decimal =~ /\.83+$/) {
10848 elsif ($decimal =~ /\.(12|37|62|87)50*$/) {
10851 if ($denominator) {
10852 my $sign = ($decimal < 0) ? "-" : "";
10853 my $numerator = int((abs($decimal) * $denominator) + .5);
10854 $rational = "$sign$numerator/$denominator";
10855 $_ = "$codepoints; $rational";
10858 $file->carp_bad_line("Can't cope with number '$decimal'.");
10865 register_fraction($rational) if $rational =~ qr{/};
10870 my %unihan_properties;
10873 # Do any special setup for Unihan properties.
10875 # This property gives the wrong computed type, so override.
10876 my $usource = property_ref('kIRG_USource');
10877 $usource->set_type($STRING) if defined $usource;
10879 # This property is to be considered binary (it says so in
10880 # http://www.unicode.org/reports/tr38/)
10881 my $iicore = property_ref('kIICore');
10882 if (defined $iicore) {
10883 $iicore->set_type($FORCED_BINARY);
10884 $iicore->table("Y")->add_note("Forced to a binary property as per unicode.org UAX #38.");
10886 # Unicode doesn't include the maps for this property, so don't
10887 # warn that they are missing.
10888 $iicore->set_pre_declared_maps(0);
10889 $iicore->add_comment(join_lines( <<END
10890 This property contains enum values, but Unicode UAX #38 says it should be
10891 interpreted as binary, so Perl creates tables for both 1) its enum values,
10892 plus 2) true/false tables in which it is considered true for all code points
10893 that have a non-null value
10901 sub filter_unihan_line {
10902 # Change unihan db lines to look like the others in the db. Here is
10904 # U+341C kCangjie IEKN
10906 # Tabs are used instead of semi-colons to separate fields; therefore
10907 # they may have semi-colons embedded in them. Change these to periods
10908 # so won't screw up the rest of the code.
10911 # Remove lines that don't look like ones we accept.
10912 if ($_ !~ /^ [^\t]* \t ( [^\t]* ) /x) {
10917 # Extract the property, and save a reference to its object.
10919 if (! exists $unihan_properties{$property}) {
10920 $unihan_properties{$property} = property_ref($property);
10923 # Don't do anything unless the property is one we're handling, which
10924 # we determine by seeing if there is an object defined for it or not
10925 if (! defined $unihan_properties{$property}) {
10930 # Convert the tab separators to our standard semi-colons, and convert
10931 # the U+HHHH notation to the rest of the standard's HHHH
10933 s/\b U \+ (?= $code_point_re )//xg;
10935 #local $to_trace = 1 if main::DEBUG;
10936 trace $_ if main::DEBUG && $to_trace;
10942 sub filter_blocks_lines {
10943 # In the Blocks.txt file, the names of the blocks don't quite match the
10944 # names given in PropertyValueAliases.txt, so this changes them so they
10945 # do match: Blanks and hyphens are changed into underscores. Also makes
10946 # early release versions look like later ones
10948 # $_ is transformed to the correct value.
10951 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
10953 if ($v_version lt v3.2.0) {
10954 if (/FEFF.*Specials/) { # Bug in old versions: line wrongly inserted
10959 # Old versions used a different syntax to mark the range.
10960 $_ =~ s/;\s+/../ if $v_version lt v3.1.0;
10963 my @fields = split /\s*;\s*/, $_, -1;
10964 if (@fields != 2) {
10965 $file->carp_bad_line("Expecting exactly two fields");
10970 # Change hyphens and blanks in the block name field only
10971 $fields[1] =~ s/[ -]/_/g;
10972 $fields[1] =~ s/_ ( [a-z] ) /_\u$1/g; # Capitalize first letter of word
10974 $_ = join("; ", @fields);
10979 my $current_property;
10981 sub filter_old_style_proplist {
10982 # PropList.txt has been in Unicode since version 2.0. Until 3.1, it
10983 # was in a completely different syntax. Ken Whistler of Unicode says
10984 # that it was something he used as an aid for his own purposes, but
10985 # was never an official part of the standard. However, comments in
10986 # DAge.txt indicate that non-character code points were available in
10987 # the UCD as of 3.1. It is unclear to me (khw) how they could be
10988 # there except through this file (but on the other hand, they first
10989 # appeared there in 3.0.1), so maybe it was part of the UCD, and maybe
10990 # not. But the claim is that it was published as an aid to others who
10991 # might want some more information than was given in the official UCD
10992 # of the time. Many of the properties in it were incorporated into
10993 # the later PropList.txt, but some were not. This program uses this
10994 # early file to generate property tables that are otherwise not
10995 # accessible in the early UCD's, and most were probably not really
10996 # official at that time, so one could argue that it should be ignored,
10997 # and you can easily modify things to skip this. And there are bugs
10998 # in this file in various versions. (For example, the 2.1.9 version
10999 # removes from Alphabetic the CJK range starting at 4E00, and they
11000 # weren't added back in until 3.1.0.) Many of this file's properties
11001 # were later sanctioned, so this code generates tables for those
11002 # properties that aren't otherwise in the UCD of the time but
11003 # eventually did become official, and throws away the rest. Here is a
11004 # list of all the ones that are thrown away:
11005 # Bidi=* duplicates UnicodeData.txt
11006 # Combining never made into official property;
11008 # Composite never made into official property.
11009 # Currency Symbol duplicates UnicodeData.txt: gc=sc
11010 # Decimal Digit duplicates UnicodeData.txt: gc=nd
11011 # Delimiter never made into official property;
11013 # Format Control never made into official property;
11015 # High Surrogate duplicates Blocks.txt
11016 # Ignorable Control never made into official property;
11018 # ISO Control duplicates UnicodeData.txt: gc=cc
11019 # Left of Pair never made into official property;
11020 # Line Separator duplicates UnicodeData.txt: gc=zl
11021 # Low Surrogate duplicates Blocks.txt
11022 # Non-break was actually listed as a property
11023 # in 3.2, but without any code
11024 # points. Unicode denies that this
11025 # was ever an official property
11026 # Non-spacing duplicate UnicodeData.txt: gc=mn
11027 # Numeric duplicates UnicodeData.txt: gc=cc
11028 # Paired Punctuation never made into official property;
11029 # appears to be gc=ps + gc=pe
11030 # Paragraph Separator duplicates UnicodeData.txt: gc=cc
11031 # Private Use duplicates UnicodeData.txt: gc=co
11032 # Private Use High Surrogate duplicates Blocks.txt
11033 # Punctuation duplicates UnicodeData.txt: gc=p
11034 # Space different definition than eventual
11036 # Titlecase duplicates UnicodeData.txt: gc=lt
11037 # Unassigned Code Value duplicates UnicodeData.txt: gc=cc
11038 # Zero-width never made into official property;
11040 # Most of the properties have the same names in this file as in later
11041 # versions, but a couple do not.
11043 # This subroutine filters $_, converting it from the old style into
11044 # the new style. Here's a sample of the old-style
11046 # *******************************************
11048 # Property dump for: 0x100000A0 (Join Control)
11050 # 200C..200D (2 chars)
11052 # In the example, the property is "Join Control". It is kept in this
11053 # closure between calls to the subroutine. The numbers beginning with
11054 # 0x were internal to Ken's program that generated this file.
11056 # If this line contains the property name, extract it.
11057 if (/^Property dump for: [^(]*\((.*)\)/) {
11060 # Convert white space to underscores.
11063 # Convert the few properties that don't have the same name as
11064 # their modern counterparts
11065 s/Identifier_Part/ID_Continue/
11066 or s/Not_a_Character/NChar/;
11068 # If the name matches an existing property, use it.
11069 if (defined property_ref($_)) {
11070 trace "new property=", $_ if main::DEBUG && $to_trace;
11071 $current_property = $_;
11073 else { # Otherwise discard it
11074 trace "rejected property=", $_ if main::DEBUG && $to_trace;
11075 undef $current_property;
11077 $_ = ""; # The property is saved for the next lines of the
11078 # file, but this defining line is of no further use,
11079 # so clear it so that the caller won't process it
11082 elsif (! defined $current_property || $_ !~ /^$code_point_re/) {
11084 # Here, the input line isn't a header defining a property for the
11085 # following section, and either we aren't in such a section, or
11086 # the line doesn't look like one that defines the code points in
11087 # such a section. Ignore this line.
11092 # Here, we have a line defining the code points for the current
11093 # stashed property. Anything starting with the first blank is
11094 # extraneous. Otherwise, it should look like a normal range to
11095 # the caller. Append the property name so that it looks just like
11096 # a modern PropList entry.
11099 $_ .= "; $current_property";
11101 trace $_ if main::DEBUG && $to_trace;
11104 } # End closure for old style proplist
11106 sub filter_old_style_normalization_lines {
11107 # For early releases of Unicode, the lines were like:
11108 # 74..2A76 ; NFKD_NO
11109 # For later releases this became:
11110 # 74..2A76 ; NFKD_QC; N
11111 # Filter $_ to look like those in later releases.
11112 # Similarly for MAYBEs
11114 s/ _NO \b /_QC; N/x || s/ _MAYBE \b /_QC; M/x;
11116 # Also, the property FC_NFKC was abbreviated to FNC
11121 sub setup_script_extensions {
11122 # The Script_Extensions property starts out with a clone of the Script
11125 my $sc = property_ref("Script");
11126 my $scx = Property->new("scx", Full_Name => "Script_Extensions",
11128 Default_Map => $sc->default_map,
11129 Pre_Declared_Maps => 0,
11130 Format => $STRING_WHITE_SPACE_LIST,
11132 $scx->add_comment(join_lines( <<END
11133 The values for code points that appear in one script are just the same as for
11134 the 'Script' property. Likewise the values for those that appear in many
11135 scripts are either 'Common' or 'Inherited', same as with 'Script'. But the
11136 values of code points that appear in a few scripts are a space separated list
11141 # Make the scx's tables and aliases for them the same as sc's
11142 foreach my $table ($sc->tables) {
11143 my $scx_table = $scx->add_match_table($table->name,
11144 Full_Name => $table->full_name);
11145 foreach my $alias ($table->aliases) {
11146 $scx_table->add_alias($alias->name);
11151 sub filter_script_extensions_line {
11152 # The Scripts file comes with the full name for the scripts; the
11153 # ScriptExtensions, with the short name. The final mapping file is a
11154 # combination of these, and without adjustment, would have inconsistent
11155 # entries. This filters the latter file to convert to full names.
11156 # Entries look like this:
11157 # 064B..0655 ; Arab Syrc # Mn [11] ARABIC FATHATAN..ARABIC HAMZA BELOW
11159 my @fields = split /\s*;\s*/;
11161 foreach my $short_name (split " ", $fields[1]) {
11162 push @full_names, $script->table($short_name)->full_name;
11164 $fields[1] = join " ", @full_names;
11165 $_ = join "; ", @fields;
11170 sub setup_v6_name_alias {
11171 property_ref('Name_Alias')->add_map(7, 7, "ALERT");
11174 sub finish_Unicode() {
11175 # This routine should be called after all the Unicode files have been read
11177 # 1) Adds the mappings for code points missing from the files which have
11178 # defaults specified for them.
11179 # 2) At this this point all mappings are known, so it computes the type of
11180 # each property whose type hasn't been determined yet.
11181 # 3) Calculates all the regular expression match tables based on the
11183 # 3) Calculates and adds the tables which are defined by Unicode, but
11184 # which aren't derived by them
11186 # For each property, fill in any missing mappings, and calculate the re
11187 # match tables. If a property has more than one missing mapping, the
11188 # default is a reference to a data structure, and requires data from other
11189 # properties to resolve. The sort is used to cause these to be processed
11190 # last, after all the other properties have been calculated.
11191 # (Fortunately, the missing properties so far don't depend on each other.)
11192 foreach my $property
11193 (sort { (defined $a->default_map && ref $a->default_map) ? 1 : -1 }
11196 # $perl has been defined, but isn't one of the Unicode properties that
11197 # need to be finished up.
11198 next if $property == $perl;
11200 # Handle the properties that have more than one possible default
11201 if (ref $property->default_map) {
11202 my $default_map = $property->default_map;
11204 # These properties have stored in the default_map:
11206 # 1) A default map which applies to all code points in a
11208 # 2) an expression which will evaluate to the list of code
11209 # points in that class
11211 # 3) the default map which applies to every other missing code
11214 # Go through each list.
11215 while (my ($default, $eval) = $default_map->get_next_defaults) {
11217 # Get the class list, and intersect it with all the so-far
11218 # unspecified code points yielding all the code points
11219 # in the class that haven't been specified.
11220 my $list = eval $eval;
11222 Carp::my_carp("Can't set some defaults for missing code points for $property because eval '$eval' failed with '$@'");
11226 # Narrow down the list to just those code points we don't have
11228 $list = $list & $property->inverse_list;
11230 # Add mappings to the property for each code point in the list
11231 foreach my $range ($list->ranges) {
11232 $property->add_map($range->start, $range->end, $default,
11233 Replace => $CROAK);
11237 # All remaining code points have the other mapping. Set that up
11238 # so the normal single-default mapping code will work on them
11239 $property->set_default_map($default_map->other_default);
11241 # And fall through to do that
11244 # We should have enough data now to compute the type of the property.
11245 $property->compute_type;
11246 my $property_type = $property->type;
11248 next if ! $property->to_create_match_tables;
11250 # Here want to create match tables for this property
11252 # The Unicode db always (so far, and they claim into the future) have
11253 # the default for missing entries in binary properties be 'N' (unless
11254 # there is a '@missing' line that specifies otherwise)
11255 if ($property_type == $BINARY && ! defined $property->default_map) {
11256 $property->set_default_map('N');
11259 # Add any remaining code points to the mapping, using the default for
11260 # missing code points.
11262 if (defined (my $default_map = $property->default_map)) {
11264 # Make sure there is a match table for the default
11265 if (! defined ($default_table = $property->table($default_map))) {
11266 $default_table = $property->add_match_table($default_map);
11269 # And, if the property is binary, the default table will just
11270 # be the complement of the other table.
11271 if ($property_type == $BINARY) {
11272 my $non_default_table;
11274 # Find the non-default table.
11275 for my $table ($property->tables) {
11276 next if $table == $default_table;
11277 $non_default_table = $table;
11279 $default_table->set_complement($non_default_table);
11283 # This fills in any missing values with the default. It's not
11284 # necessary to do this with binary properties, as the default
11285 # is defined completely in terms of the Y table.
11286 $property->add_map(0, $MAX_UNICODE_CODEPOINT,
11287 $default_map, Replace => $NO);
11291 # Have all we need to populate the match tables.
11292 my $property_name = $property->name;
11293 my $maps_should_be_defined = $property->pre_declared_maps;
11294 foreach my $range ($property->ranges) {
11295 my $map = $range->value;
11296 my $table = $property->table($map);
11297 if (! defined $table) {
11299 # Integral and rational property values are not necessarily
11300 # defined in PropValueAliases, but whether all the other ones
11301 # should be depends on the property.
11302 if ($maps_should_be_defined
11303 && $map !~ /^ -? \d+ ( \/ \d+ )? $/x)
11305 Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.")
11307 $table = $property->add_match_table($map);
11310 next if $table->complement != 0; # Don't need to populate these
11311 $table->add_range($range->start, $range->end);
11314 # A forced binary property has additional true/false tables which
11315 # should have been set up when it was forced into binary. The false
11316 # table matches exactly the same set as the property's default table.
11317 # The true table matches the complement of that. The false table is
11318 # not the same as an additional set of aliases on top of the default
11319 # table, so use 'set_equivalent_to'. If it were implemented as
11320 # additional aliases, various things would have to be adjusted, but
11321 # especially, if the user wants to get a list of names for the table
11322 # using Unicode::UCD::prop_value_aliases(), s/he should get a
11323 # different set depending on whether they want the default table or
11325 if ($property_type == $FORCED_BINARY) {
11326 $property->table('N')->set_equivalent_to($default_table,
11328 $property->table('Y')->set_complement($default_table);
11331 # For Perl 5.6 compatibility, all properties matchable in regexes can
11332 # have an optional 'Is_' prefix. This is now done in utf8_heavy.pl.
11333 # But warn if this creates a conflict with a (new) Unicode property
11334 # name, although it appears that Unicode has made a decision never to
11335 # begin a property name with 'Is_', so this shouldn't happen.
11336 foreach my $alias ($property->aliases) {
11337 my $Is_name = 'Is_' . $alias->name;
11338 if (defined (my $pre_existing = property_ref($Is_name))) {
11339 Carp::my_carp(<<END
11340 There is already an alias named $Is_name (from " . $pre_existing . "), so
11341 creating one for $property won't work. This is bad news. If it is not too
11342 late, get Unicode to back off. Otherwise go back to the old scheme (findable
11343 from the git blame log for this area of the code that suppressed individual
11344 aliases that conflict with the new Unicode names. Proceeding anyway.
11348 } # End of loop through aliases for this property
11349 } # End of loop through all Unicode properties.
11351 # Fill in the mappings that Unicode doesn't completely furnish. First the
11352 # single letter major general categories. If Unicode were to start
11353 # delivering the values, this would be redundant, but better that than to
11354 # try to figure out if should skip and not get it right. Ths could happen
11355 # if a new major category were to be introduced, and the hard-coded test
11356 # wouldn't know about it.
11357 # This routine depends on the standard names for the general categories
11358 # being what it thinks they are, like 'Cn'. The major categories are the
11359 # union of all the general category tables which have the same first
11360 # letters. eg. L = Lu + Lt + Ll + Lo + Lm
11361 foreach my $minor_table ($gc->tables) {
11362 my $minor_name = $minor_table->name;
11363 next if length $minor_name == 1;
11364 if (length $minor_name != 2) {
11365 Carp::my_carp_bug("Unexpected general category '$minor_name'. Skipped.");
11369 my $major_name = uc(substr($minor_name, 0, 1));
11370 my $major_table = $gc->table($major_name);
11371 $major_table += $minor_table;
11374 # LC is Ll, Lu, and Lt. (used to be L& or L_, but PropValueAliases.txt
11375 # defines it as LC)
11376 my $LC = $gc->table('LC');
11377 $LC->add_alias('L_', Status => $DISCOURAGED); # For backwards...
11378 $LC->add_alias('L&', Status => $DISCOURAGED); # compatibility.
11381 if ($LC->is_empty) { # Assume if not empty that Unicode has started to
11382 # deliver the correct values in it
11383 $LC->initialize($gc->table('Ll') + $gc->table('Lu'));
11385 # Lt not in release 1.
11386 if (defined $gc->table('Lt')) {
11387 $LC += $gc->table('Lt');
11388 $gc->table('Lt')->set_caseless_equivalent($LC);
11391 $LC->add_description('[\p{Ll}\p{Lu}\p{Lt}]');
11393 $gc->table('Ll')->set_caseless_equivalent($LC);
11394 $gc->table('Lu')->set_caseless_equivalent($LC);
11396 my $Cs = $gc->table('Cs');
11399 # Folding information was introduced later into Unicode data. To get
11400 # Perl's case ignore (/i) to work at all in releases that don't have
11401 # folding, use the best available alternative, which is lower casing.
11402 my $fold = property_ref('Simple_Case_Folding');
11403 if ($fold->is_empty) {
11404 $fold->initialize(property_ref('Simple_Lowercase_Mapping'));
11405 $fold->add_note(join_lines(<<END
11406 WARNING: This table uses lower case as a substitute for missing fold
11412 # Multiple-character mapping was introduced later into Unicode data. If
11413 # missing, use the single-characters maps as best available alternative
11414 foreach my $map (qw { Uppercase_Mapping
11419 my $full = property_ref($map);
11420 if ($full->is_empty) {
11421 my $simple = property_ref('Simple_' . $map);
11422 $full->initialize($simple);
11423 $full->add_comment($simple->comment) if ($simple->comment);
11424 $full->add_note(join_lines(<<END
11425 WARNING: This table uses simple mapping (single-character only) as a
11426 substitute for missing multiple-character information
11432 # The Script_Extensions property started out as a clone of the Script
11433 # property. But processing its data file caused some elements to be
11434 # replaced with different data. (These elements were for the Common and
11435 # Inherited properties.) This data is a qw() list of all the scripts that
11436 # the code points in the given range are in. An example line is:
11437 # 060C ; Arab Syrc Thaa # Po ARABIC COMMA
11439 # The code above has created a new match table named "Arab Syrc Thaa"
11440 # which contains 060C. (The cloned table started out with this code point
11441 # mapping to "Common".) Now we add 060C to each of the Arab, Syrc, and
11442 # Thaa match tables. Then we delete the now spurious "Arab Syrc Thaa"
11443 # match table. This is repeated for all these tables and ranges. The map
11444 # data is retained in the map table for reference, but the spurious match
11445 # tables are deleted.
11447 my $scx = property_ref("Script_Extensions");
11448 if (defined $scx) {
11449 foreach my $table ($scx->tables) {
11450 next unless $table->name =~ /\s/; # All the new and only the new
11451 # tables have a space in their
11453 my @scripts = split /\s+/, $table->name;
11454 foreach my $script (@scripts) {
11455 my $script_table = $scx->table($script);
11456 $script_table += $table;
11458 $scx->delete_match_table($table);
11465 sub compile_perl() {
11466 # Create perl-defined tables. Almost all are part of the pseudo-property
11467 # named 'perl' internally to this program. Many of these are recommended
11468 # in UTS#18 "Unicode Regular Expressions", and their derivations are based
11469 # on those found there.
11470 # Almost all of these are equivalent to some Unicode property.
11471 # A number of these properties have equivalents restricted to the ASCII
11472 # range, with their names prefaced by 'Posix', to signify that these match
11473 # what the Posix standard says they should match. A couple are
11474 # effectively this, but the name doesn't have 'Posix' in it because there
11475 # just isn't any Posix equivalent. 'XPosix' are the Posix tables extended
11476 # to the full Unicode range, by our guesses as to what is appropriate.
11478 # 'Any' is all code points. As an error check, instead of just setting it
11479 # to be that, construct it to be the union of all the major categories
11480 $Any = $perl->add_match_table('Any',
11481 Description => "[\\x{0000}-\\x{$MAX_UNICODE_CODEPOINT_STRING}]",
11484 foreach my $major_table ($gc->tables) {
11486 # Major categories are the ones with single letter names.
11487 next if length($major_table->name) != 1;
11489 $Any += $major_table;
11492 if ($Any->max != $MAX_UNICODE_CODEPOINT) {
11493 Carp::my_carp_bug("Generated highest code point ("
11494 . sprintf("%X", $Any->max)
11495 . ") doesn't match expected value $MAX_UNICODE_CODEPOINT_STRING.")
11497 if ($Any->range_count != 1 || $Any->min != 0) {
11498 Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.")
11501 $Any->add_alias('All');
11503 # Assigned is the opposite of gc=unassigned
11504 my $Assigned = $perl->add_match_table('Assigned',
11505 Description => "All assigned code points",
11506 Initialize => ~ $gc->table('Unassigned'),
11509 # Our internal-only property should be treated as more than just a
11510 # synonym; grandfather it in to the pod.
11511 $perl->add_match_table('_CombAbove', Pod_Entry => 1)
11512 ->set_equivalent_to(property_ref('ccc')->table('Above'),
11515 my $ASCII = $perl->add_match_table('ASCII', Description => '[[:ASCII:]]');
11516 if (defined $block) { # This is equivalent to the block if have it.
11517 my $Unicode_ASCII = $block->table('Basic_Latin');
11518 if (defined $Unicode_ASCII && ! $Unicode_ASCII->is_empty) {
11519 $ASCII->set_equivalent_to($Unicode_ASCII, Related => 1);
11523 # Very early releases didn't have blocks, so initialize ASCII ourselves if
11525 if ($ASCII->is_empty) {
11526 $ASCII->initialize([ 0..127 ]);
11529 # Get the best available case definitions. Early Unicode versions didn't
11530 # have Uppercase and Lowercase defined, so use the general category
11531 # instead for them.
11532 my $Lower = $perl->add_match_table('Lower');
11533 my $Unicode_Lower = property_ref('Lowercase');
11534 if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) {
11535 $Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1);
11536 $Unicode_Lower->table('Y')->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11537 $Unicode_Lower->table('N')->set_caseless_equivalent(property_ref('Cased')->table('N'));
11538 $Lower->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11542 $Lower->set_equivalent_to($gc->table('Lowercase_Letter'),
11545 $Lower->add_alias('XPosixLower');
11546 my $Posix_Lower = $perl->add_match_table("PosixLower",
11547 Description => "[a-z]",
11548 Initialize => $Lower & $ASCII,
11551 my $Upper = $perl->add_match_table('Upper');
11552 my $Unicode_Upper = property_ref('Uppercase');
11553 if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) {
11554 $Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1);
11555 $Unicode_Upper->table('Y')->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11556 $Unicode_Upper->table('N')->set_caseless_equivalent(property_ref('Cased')->table('N'));
11557 $Upper->set_caseless_equivalent(property_ref('Cased')->table('Y'));
11560 $Upper->set_equivalent_to($gc->table('Uppercase_Letter'),
11563 $Upper->add_alias('XPosixUpper');
11564 my $Posix_Upper = $perl->add_match_table("PosixUpper",
11565 Description => "[A-Z]",
11566 Initialize => $Upper & $ASCII,
11569 # Earliest releases didn't have title case. Initialize it to empty if not
11570 # otherwise present
11571 my $Title = $perl->add_match_table('Title', Full_Name => 'Titlecase',
11572 Description => '(= \p{Gc=Lt})');
11573 my $lt = $gc->table('Lt');
11575 # Earlier versions of mktables had this related to $lt since they have
11576 # identical code points, but their caseless equivalents are not the same,
11577 # one being 'Cased' and the other being 'LC', and so now must be kept as
11578 # separate entities.
11579 $Title += $lt if defined $lt;
11581 # If this Unicode version doesn't have Cased, set up our own. From
11582 # Unicode 5.1: Definition D120: A character C is defined to be cased if
11583 # and only if C has the Lowercase or Uppercase property or has a
11584 # General_Category value of Titlecase_Letter.
11585 my $Unicode_Cased = property_ref('Cased');
11586 unless (defined $Unicode_Cased) {
11587 my $cased = $perl->add_match_table('Cased',
11588 Initialize => $Lower + $Upper + $Title,
11589 Description => 'Uppercase or Lowercase or Titlecase',
11591 $Unicode_Cased = $cased;
11593 $Title->set_caseless_equivalent($Unicode_Cased->table('Y'));
11595 # Similarly, set up our own Case_Ignorable property if this Unicode
11596 # version doesn't have it. From Unicode 5.1: Definition D121: A character
11597 # C is defined to be case-ignorable if C has the value MidLetter or the
11598 # value MidNumLet for the Word_Break property or its General_Category is
11599 # one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf),
11600 # Modifier_Letter (Lm), or Modifier_Symbol (Sk).
11602 # Perl has long had an internal-only alias for this property; grandfather
11603 # it in to the pod, but discourage its use.
11604 my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable',
11606 my $case_ignorable = property_ref('Case_Ignorable');
11607 if (defined $case_ignorable && ! $case_ignorable->is_empty) {
11608 $perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'),
11613 $perl_case_ignorable->initialize($gc->table('Mn') + $gc->table('Lm'));
11615 # The following three properties are not in early releases
11616 $perl_case_ignorable += $gc->table('Me') if defined $gc->table('Me');
11617 $perl_case_ignorable += $gc->table('Cf') if defined $gc->table('Cf');
11618 $perl_case_ignorable += $gc->table('Sk') if defined $gc->table('Sk');
11620 # For versions 4.1 - 5.0, there is no MidNumLet property, and
11621 # correspondingly the case-ignorable definition lacks that one. For
11622 # 4.0, it appears that it was meant to be the same definition, but was
11623 # inadvertently omitted from the standard's text, so add it if the
11624 # property actually is there
11625 my $wb = property_ref('Word_Break');
11627 my $midlet = $wb->table('MidLetter');
11628 $perl_case_ignorable += $midlet if defined $midlet;
11629 my $midnumlet = $wb->table('MidNumLet');
11630 $perl_case_ignorable += $midnumlet if defined $midnumlet;
11634 # In earlier versions of the standard, instead of the above two
11635 # properties , just the following characters were used:
11636 $perl_case_ignorable += 0x0027 # APOSTROPHE
11637 + 0x00AD # SOFT HYPHEN (SHY)
11638 + 0x2019; # RIGHT SINGLE QUOTATION MARK
11642 # The remaining perl defined tables are mostly based on Unicode TR 18,
11643 # "Annex C: Compatibility Properties". All of these have two versions,
11644 # one whose name generally begins with Posix that is posix-compliant, and
11645 # one that matches Unicode characters beyond the Posix, ASCII range
11647 my $Alpha = $perl->add_match_table('Alpha');
11649 # Alphabetic was not present in early releases
11650 my $Alphabetic = property_ref('Alphabetic');
11651 if (defined $Alphabetic && ! $Alphabetic->is_empty) {
11652 $Alpha->set_equivalent_to($Alphabetic->table('Y'), Related => 1);
11656 # For early releases, we don't get it exactly right. The below
11657 # includes more than it should, which in 5.2 terms is: L + Nl +
11658 # Other_Alphabetic. Other_Alphabetic contains many characters from
11659 # Mn and Mc. It's better to match more than we should, than less than
11661 $Alpha->initialize($gc->table('Letter')
11663 + $gc->table('Mc'));
11664 $Alpha += $gc->table('Nl') if defined $gc->table('Nl');
11665 $Alpha->add_description('Alphabetic');
11667 $Alpha->add_alias('XPosixAlpha');
11668 my $Posix_Alpha = $perl->add_match_table("PosixAlpha",
11669 Description => "[A-Za-z]",
11670 Initialize => $Alpha & $ASCII,
11672 $Posix_Upper->set_caseless_equivalent($Posix_Alpha);
11673 $Posix_Lower->set_caseless_equivalent($Posix_Alpha);
11675 my $Alnum = $perl->add_match_table('Alnum',
11676 Description => 'Alphabetic and (Decimal) Numeric',
11677 Initialize => $Alpha + $gc->table('Decimal_Number'),
11679 $Alnum->add_alias('XPosixAlnum');
11680 $perl->add_match_table("PosixAlnum",
11681 Description => "[A-Za-z0-9]",
11682 Initialize => $Alnum & $ASCII,
11685 my $Word = $perl->add_match_table('Word',
11686 Description => '\w, including beyond ASCII;'
11687 . ' = \p{Alnum} + \pM + \p{Pc}',
11688 Initialize => $Alnum + $gc->table('Mark'),
11690 $Word->add_alias('XPosixWord');
11691 my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1
11692 $Word += $Pc if defined $Pc;
11694 # This is a Perl extension, so the name doesn't begin with Posix.
11695 my $PerlWord = $perl->add_match_table('PerlWord',
11696 Description => '\w, restricted to ASCII = [A-Za-z0-9_]',
11697 Initialize => $Word & $ASCII,
11699 $PerlWord->add_alias('PosixWord');
11701 my $Blank = $perl->add_match_table('Blank',
11702 Description => '\h, Horizontal white space',
11704 # 200B is Zero Width Space which is for line
11705 # break control, and was listed as
11706 # Space_Separator in early releases
11707 Initialize => $gc->table('Space_Separator')
11711 $Blank->add_alias('HorizSpace'); # Another name for it.
11712 $Blank->add_alias('XPosixBlank');
11713 $perl->add_match_table("PosixBlank",
11714 Description => "\\t and ' '",
11715 Initialize => $Blank & $ASCII,
11718 my $VertSpace = $perl->add_match_table('VertSpace',
11719 Description => '\v',
11720 Initialize => $gc->table('Line_Separator')
11721 + $gc->table('Paragraph_Separator')
11722 + 0x000A # LINE FEED
11723 + 0x000B # VERTICAL TAB
11724 + 0x000C # FORM FEED
11725 + 0x000D # CARRIAGE RETURN
11728 # No Posix equivalent for vertical space
11730 my $Space = $perl->add_match_table('Space',
11731 Description => '\s including beyond ASCII plus vertical tab',
11732 Initialize => $Blank + $VertSpace,
11734 $Space->add_alias('XPosixSpace');
11735 $perl->add_match_table("PosixSpace",
11736 Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)",
11737 Initialize => $Space & $ASCII,
11740 # Perl's traditional space doesn't include Vertical Tab
11741 my $XPerlSpace = $perl->add_match_table('XPerlSpace',
11742 Description => '\s, including beyond ASCII',
11743 Initialize => $Space - 0x000B,
11745 $XPerlSpace->add_alias('SpacePerl'); # A pre-existing synonym
11746 my $PerlSpace = $perl->add_match_table('PerlSpace',
11747 Description => '\s, restricted to ASCII = [ \f\n\r\t]',
11748 Initialize => $XPerlSpace & $ASCII,
11752 my $Cntrl = $perl->add_match_table('Cntrl',
11753 Description => 'Control characters');
11754 $Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1);
11755 $Cntrl->add_alias('XPosixCntrl');
11756 $perl->add_match_table("PosixCntrl",
11757 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",
11758 Initialize => $Cntrl & $ASCII,
11761 # $controls is a temporary used to construct Graph.
11762 my $controls = Range_List->new(Initialize => $gc->table('Unassigned')
11763 + $gc->table('Control'));
11764 # Cs not in release 1
11765 $controls += $gc->table('Surrogate') if defined $gc->table('Surrogate');
11767 # Graph is ~space & ~(Cc|Cs|Cn) = ~(space + $controls)
11768 my $Graph = $perl->add_match_table('Graph',
11769 Description => 'Characters that are graphical',
11770 Initialize => ~ ($Space + $controls),
11772 $Graph->add_alias('XPosixGraph');
11773 $perl->add_match_table("PosixGraph",
11775 '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~0-9A-Za-z]',
11776 Initialize => $Graph & $ASCII,
11779 $print = $perl->add_match_table('Print',
11780 Description => 'Characters that are graphical plus space characters (but no controls)',
11781 Initialize => $Blank + $Graph - $gc->table('Control'),
11783 $print->add_alias('XPosixPrint');
11784 $perl->add_match_table("PosixPrint",
11786 '[- 0-9A-Za-z!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11787 Initialize => $print & $ASCII,
11790 my $Punct = $perl->add_match_table('Punct');
11791 $Punct->set_equivalent_to($gc->table('Punctuation'), Related => 1);
11793 # \p{punct} doesn't include the symbols, which posix does
11794 my $XPosixPunct = $perl->add_match_table('XPosixPunct',
11795 Description => '\p{Punct} + ASCII-range \p{Symbol}',
11796 Initialize => $gc->table('Punctuation')
11797 + ($ASCII & $gc->table('Symbol')),
11798 Perl_Extension => 1
11800 $perl->add_match_table('PosixPunct', Perl_Extension => 1,
11801 Description => '[-!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
11802 Initialize => $ASCII & $XPosixPunct,
11805 my $Digit = $perl->add_match_table('Digit',
11806 Description => '[0-9] + all other decimal digits');
11807 $Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1);
11808 $Digit->add_alias('XPosixDigit');
11809 my $PosixDigit = $perl->add_match_table("PosixDigit",
11810 Description => '[0-9]',
11811 Initialize => $Digit & $ASCII,
11814 # Hex_Digit was not present in first release
11815 my $Xdigit = $perl->add_match_table('XDigit');
11816 $Xdigit->add_alias('XPosixXDigit');
11817 my $Hex = property_ref('Hex_Digit');
11818 if (defined $Hex && ! $Hex->is_empty) {
11819 $Xdigit->set_equivalent_to($Hex->table('Y'), Related => 1);
11822 # (Have to use hex instead of e.g. '0', because could be running on an
11823 # non-ASCII machine, and we want the Unicode (ASCII) values)
11824 $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66,
11825 0xFF10..0xFF19, 0xFF21..0xFF26, 0xFF41..0xFF46]);
11826 $Xdigit->add_description('[0-9A-Fa-f] and corresponding fullwidth versions, like U+FF10: FULLWIDTH DIGIT ZERO');
11829 # AHex was not present in early releases
11830 my $PosixXDigit = $perl->add_match_table('PosixXDigit');
11831 my $AHex = property_ref('ASCII_Hex_Digit');
11832 if (defined $AHex && ! $AHex->is_empty) {
11833 $PosixXDigit->set_equivalent_to($AHex->table('Y'), Related => 1);
11836 $PosixXDigit->initialize($Xdigit & $ASCII);
11838 $PosixXDigit->add_description('[0-9A-Fa-f]');
11840 my $dt = property_ref('Decomposition_Type');
11841 $dt->add_match_table('Non_Canon', Full_Name => 'Non_Canonical',
11842 Initialize => ~ ($dt->table('None') + $dt->table('Canonical')),
11843 Perl_Extension => 1,
11844 Note => 'Union of all non-canonical decompositions',
11847 # _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier
11848 # than SD appeared, construct it ourselves, based on the first release SD
11849 # was in. A pod entry is grandfathered in for it
11850 my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ', Pod_Entry => 1,
11851 Perl_Extension => 1, Internal_Only => 1);
11852 my $soft_dotted = property_ref('Soft_Dotted');
11853 if (defined $soft_dotted && ! $soft_dotted->is_empty) {
11854 $CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1);
11858 # This list came from 3.2 Soft_Dotted.
11859 $CanonDCIJ->initialize([ 0x0069,
11868 $CanonDCIJ = $CanonDCIJ & $Assigned;
11871 # These are used in Unicode's definition of \X
11872 my $begin = $perl->add_match_table('_X_Begin', Perl_Extension => 1,
11873 Internal_Only => 1);
11874 my $extend = $perl->add_match_table('_X_Extend', Perl_Extension => 1,
11875 Internal_Only => 1);
11877 # For backward compatibility, Perl has its own definition for IDStart
11878 # First, we include the underscore, and then the regular XID_Start also
11880 $perl->add_match_table('_Perl_IDStart',
11881 Perl_Extension => 1,
11882 Internal_Only => 1,
11885 + (property_ref('XID_Start')->table('Y') & $Word)
11888 my $gcb = property_ref('Grapheme_Cluster_Break');
11890 # The 'extended' grapheme cluster came in 5.1. The non-extended
11891 # definition differs too much from the traditional Perl one to use.
11892 if (defined $gcb && defined $gcb->table('SpacingMark')) {
11894 # Note that assumes HST is defined; it came in an earlier release than
11895 # GCB. In the line below, two negatives means: yes hangul
11896 $begin += ~ property_ref('Hangul_Syllable_Type')
11897 ->table('Not_Applicable')
11898 + ~ ($gcb->table('Control')
11899 + $gcb->table('CR')
11900 + $gcb->table('LF'));
11901 $begin->add_comment('For use in \X; matches: Hangul_Syllable | ! Control');
11903 $extend += $gcb->table('Extend') + $gcb->table('SpacingMark');
11904 $extend->add_comment('For use in \X; matches: Extend | SpacingMark');
11906 else { # Old definition, used on early releases.
11907 $extend += $gc->table('Mark')
11910 $begin += ~ $extend;
11912 # Here we may have a release that has the regular grapheme cluster
11913 # defined, or a release that doesn't have anything defined.
11914 # We set things up so the Perl core degrades gracefully, possibly with
11915 # placeholders that match nothing.
11917 if (! defined $gcb) {
11918 $gcb = Property->new('GCB', Status => $PLACEHOLDER);
11920 my $hst = property_ref('HST');
11921 if (!defined $hst) {
11922 $hst = Property->new('HST', Status => $PLACEHOLDER);
11923 $hst->add_match_table('Not_Applicable',
11924 Initialize => $Any,
11928 # On some releases, here we may not have the needed tables for the
11929 # perl core, in some releases we may.
11930 foreach my $name (qw{ L LV LVT T V prepend }) {
11931 my $table = $gcb->table($name);
11932 if (! defined $table) {
11933 $table = $gcb->add_match_table($name);
11934 push @tables_that_may_be_empty, $table->complete_name;
11937 # The HST property predates the GCB one, and has identical tables
11938 # for some of them, so use it if we can.
11939 if ($table->is_empty
11941 && defined $hst->table($name))
11943 $table += $hst->table($name);
11948 # More GCB. If we found some hangul syllables, populate a combined
11950 my $lv_lvt_v = $perl->add_match_table('_X_LV_LVT_V', Perl_Extension => 1, Internal_Only => 1);
11951 my $LV = $gcb->table('LV');
11952 if ($LV->is_empty) {
11953 push @tables_that_may_be_empty, $lv_lvt_v->complete_name;
11955 $lv_lvt_v += $LV + $gcb->table('LVT') + $gcb->table('V');
11956 $lv_lvt_v->add_comment('For use in \X; matches: HST=LV | HST=LVT | HST=V');
11959 # Was previously constructed to contain both Name and Unicode_1_Name
11960 my @composition = ('Name', 'Unicode_1_Name');
11962 if (@named_sequences) {
11963 push @composition, 'Named_Sequence';
11964 foreach my $sequence (@named_sequences) {
11965 $perl_charname->add_anomalous_entry($sequence);
11969 my $alias_sentence = "";
11970 my $alias = property_ref('Name_Alias');
11971 if (defined $alias) {
11972 push @composition, 'Name_Alias';
11973 $alias->reset_each_range;
11974 while (my ($range) = $alias->each_range) {
11975 next if $range->value eq "";
11976 if ($range->start != $range->end) {
11977 Carp::my_carp("Expecting only one code point in the range $range. Just to keep going, using just the first code point;");
11979 $perl_charname->add_duplicate($range->start, $range->value);
11981 $alias_sentence = <<END;
11982 The Name_Alias property adds duplicate code point entries with a corrected
11983 name. The original (less correct, but still valid) name will be physically
11988 if (@composition <= 2) { # Always at least 2
11989 $comment = join " and ", @composition;
11992 $comment = join ", ", @composition[0 .. scalar @composition - 2];
11993 $comment .= ", and $composition[-1]";
11996 $perl_charname->add_comment(join_lines( <<END
11997 This file is for charnames.pm. It is the union of the $comment properties.
11998 Unicode_1_Name entries are used only for otherwise nameless code
12001 This file doesn't include the algorithmically determinable names. For those,
12002 use 'unicore/Name.pm'
12005 property_ref('Name')->add_comment(join_lines( <<END
12006 This file doesn't include the algorithmically determinable names. For those,
12007 use 'unicore/Name.pm'
12011 # Construct the Present_In property from the Age property.
12012 if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) {
12013 my $default_map = $age->default_map;
12014 my $in = Property->new('In',
12015 Default_Map => $default_map,
12016 Full_Name => "Present_In",
12017 Perl_Extension => 1,
12019 Initialize => $age,
12021 $in->add_comment(join_lines(<<END
12022 THIS FILE SHOULD NOT BE USED FOR ANY PURPOSE. The values in this file are the
12023 same as for $age, and not for what $in really means. This is because anything
12024 defined in a given release should have multiple values: that release and all
12025 higher ones. But only one value per code point can be represented in a table
12030 # The Age tables are named like 1.5, 2.0, 2.1, .... Sort so that the
12031 # lowest numbered (earliest) come first, with the non-numeric one
12033 my ($first_age, @rest_ages) = sort { ($a->name !~ /^[\d.]*$/)
12035 : ($b->name !~ /^[\d.]*$/)
12037 : $a->name <=> $b->name
12040 # The Present_In property is the cumulative age properties. The first
12041 # one hence is identical to the first age one.
12042 my $previous_in = $in->add_match_table($first_age->name);
12043 $previous_in->set_equivalent_to($first_age, Related => 1);
12045 my $description_start = "Code point's usage introduced in version ";
12046 $first_age->add_description($description_start . $first_age->name);
12048 # To construct the accumulated values, for each of the age tables
12049 # starting with the 2nd earliest, merge the earliest with it, to get
12050 # all those code points existing in the 2nd earliest. Repeat merging
12051 # the new 2nd earliest with the 3rd earliest to get all those existing
12052 # in the 3rd earliest, and so on.
12053 foreach my $current_age (@rest_ages) {
12054 next if $current_age->name !~ /^[\d.]*$/; # Skip the non-numeric
12056 my $current_in = $in->add_match_table(
12057 $current_age->name,
12058 Initialize => $current_age + $previous_in,
12059 Description => $description_start
12060 . $current_age->name
12063 $previous_in = $current_in;
12065 # Add clarifying material for the corresponding age file. This is
12066 # in part because of the confusing and contradictory information
12067 # given in the Standard's documentation itself, as of 5.2.
12068 $current_age->add_description(
12069 "Code point's usage was introduced in version "
12070 . $current_age->name);
12071 $current_age->add_note("See also $in");
12075 # And finally the code points whose usages have yet to be decided are
12076 # the same in both properties. Note that permanently unassigned code
12077 # points actually have their usage assigned (as being permanently
12078 # unassigned), so that these tables are not the same as gc=cn.
12079 my $unassigned = $in->add_match_table($default_map);
12080 my $age_default = $age->table($default_map);
12081 $age_default->add_description(<<END
12082 Code point's usage has not been assigned in any Unicode release thus far.
12085 $unassigned->set_equivalent_to($age_default, Related => 1);
12089 # Finished creating all the perl properties. All non-internal non-string
12090 # ones have a synonym of 'Is_' prefixed. (Internal properties begin with
12091 # an underscore.) These do not get a separate entry in the pod file
12092 foreach my $table ($perl->tables) {
12093 foreach my $alias ($table->aliases) {
12094 next if $alias->name =~ /^_/;
12095 $table->add_alias('Is_' . $alias->name,
12097 Status => $alias->status,
12098 Externally_Ok => 0);
12102 # Here done with all the basic stuff. Ready to populate the information
12103 # about each character if annotating them.
12106 # See comments at its declaration
12107 $annotate_ranges = Range_Map->new;
12109 # This separates out the non-characters from the other unassigneds, so
12110 # can give different annotations for each.
12111 $unassigned_sans_noncharacters = Range_List->new(
12112 Initialize => $gc->table('Unassigned')
12113 & property_ref('Noncharacter_Code_Point')->table('N'));
12115 for (my $i = 0; $i <= $MAX_UNICODE_CODEPOINT; $i++ ) {
12116 $i = populate_char_info($i); # Note sets $i so may cause skips
12123 sub add_perl_synonyms() {
12124 # A number of Unicode tables have Perl synonyms that are expressed in
12125 # the single-form, \p{name}. These are:
12126 # All the binary property Y tables, so that \p{Name=Y} gets \p{Name} and
12127 # \p{Is_Name} as synonyms
12128 # \p{Script=Value} gets \p{Value}, \p{Is_Value} as synonyms
12129 # \p{General_Category=Value} gets \p{Value}, \p{Is_Value} as synonyms
12130 # \p{Block=Value} gets \p{In_Value} as a synonym, and, if there is no
12131 # conflict, \p{Value} and \p{Is_Value} as well
12133 # This routine generates these synonyms, warning of any unexpected
12136 # Construct the list of tables to get synonyms for. Start with all the
12137 # binary and the General_Category ones.
12138 my @tables = grep { $_->type == $BINARY || $_->type == $FORCED_BINARY }
12140 push @tables, $gc->tables;
12142 # If the version of Unicode includes the Script property, add its tables
12143 push @tables, $script->tables if defined $script;
12145 # The Block tables are kept separate because they are treated differently.
12146 # And the earliest versions of Unicode didn't include them, so add only if
12149 push @blocks, $block->tables if defined $block;
12151 # Here, have the lists of tables constructed. Process blocks last so that
12152 # if there are name collisions with them, blocks have lowest priority.
12153 # Should there ever be other collisions, manual intervention would be
12154 # required. See the comments at the beginning of the program for a
12155 # possible way to handle those semi-automatically.
12156 foreach my $table (@tables, @blocks) {
12158 # For non-binary properties, the synonym is just the name of the
12159 # table, like Greek, but for binary properties the synonym is the name
12160 # of the property, and means the code points in its 'Y' table.
12161 my $nominal = $table;
12162 my $nominal_property = $nominal->property;
12164 if (! $nominal->isa('Property')) {
12169 # Here is a binary property. Use the 'Y' table. Verify that is
12171 my $yes = $nominal->table('Y');
12172 unless (defined $yes) { # Must be defined, but is permissible to
12174 Carp::my_carp_bug("Undefined $nominal, 'Y'. Skipping.");
12180 foreach my $alias ($nominal->aliases) {
12182 # Attempt to create a table in the perl directory for the
12183 # candidate table, using whatever aliases in it that don't
12184 # conflict. Also add non-conflicting aliases for all these
12185 # prefixed by 'Is_' (and/or 'In_' for Block property tables)
12187 foreach my $prefix ("", 'Is_', 'In_') {
12189 # Only Block properties can have added 'In_' aliases.
12190 next if $prefix eq 'In_' and $nominal_property != $block;
12192 my $proposed_name = $prefix . $alias->name;
12194 # No Is_Is, In_In, nor combinations thereof
12195 trace "$proposed_name is a no-no" if main::DEBUG && $to_trace && $proposed_name =~ /^ I [ns] _I [ns] _/x;
12196 next if $proposed_name =~ /^ I [ns] _I [ns] _/x;
12198 trace "Seeing if can add alias or table: 'perl=$proposed_name' based on $nominal" if main::DEBUG && $to_trace;
12200 # Get a reference to any existing table in the perl
12201 # directory with the desired name.
12202 my $pre_existing = $perl->table($proposed_name);
12204 if (! defined $pre_existing) {
12206 # No name collision, so ok to add the perl synonym.
12208 my $make_pod_entry;
12210 my $status = $alias->status;
12211 if ($nominal_property == $block) {
12213 # For block properties, the 'In' form is preferred for
12214 # external use; the pod file contains wild cards for
12215 # this and the 'Is' form so no entries for those; and
12216 # we don't want people using the name without the
12217 # 'In', so discourage that.
12218 if ($prefix eq "") {
12219 $make_pod_entry = 1;
12220 $status = $status || $DISCOURAGED;
12221 $externally_ok = 0;
12223 elsif ($prefix eq 'In_') {
12224 $make_pod_entry = 0;
12225 $status = $status || $NORMAL;
12226 $externally_ok = 1;
12229 $make_pod_entry = 0;
12230 $status = $status || $DISCOURAGED;
12231 $externally_ok = 0;
12234 elsif ($prefix ne "") {
12236 # The 'Is' prefix is handled in the pod by a wild
12237 # card, and we won't use it for an external name
12238 $make_pod_entry = 0;
12239 $status = $status || $NORMAL;
12240 $externally_ok = 0;
12244 # Here, is an empty prefix, non block. This gets its
12245 # own pod entry and can be used for an external name.
12246 $make_pod_entry = 1;
12247 $status = $status || $NORMAL;
12248 $externally_ok = 1;
12251 # Here, there isn't a perl pre-existing table with the
12252 # name. Look through the list of equivalents of this
12253 # table to see if one is a perl table.
12254 foreach my $equivalent ($actual->leader->equivalents) {
12255 next if $equivalent->property != $perl;
12257 # Here, have found a table for $perl. Add this alias
12258 # to it, and are done with this prefix.
12259 $equivalent->add_alias($proposed_name,
12260 Pod_Entry => $make_pod_entry,
12262 Externally_Ok => $externally_ok);
12263 trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace;
12267 # Here, $perl doesn't already have a table that is a
12268 # synonym for this property, add one.
12269 my $added_table = $perl->add_match_table($proposed_name,
12270 Pod_Entry => $make_pod_entry,
12272 Externally_Ok => $externally_ok);
12273 # And it will be related to the actual table, since it is
12275 $added_table->set_equivalent_to($actual, Related => 1);
12276 trace "added ", $perl->table($proposed_name) if main::DEBUG && $to_trace;
12278 } # End of no pre-existing.
12280 # Here, there is a pre-existing table that has the proposed
12281 # name. We could be in trouble, but not if this is just a
12282 # synonym for another table that we have already made a child
12283 # of the pre-existing one.
12284 if ($pre_existing->is_set_equivalent_to($actual)) {
12285 trace "$pre_existing is already equivalent to $actual; adding alias perl=$proposed_name to it" if main::DEBUG && $to_trace;
12286 $pre_existing->add_alias($proposed_name);
12290 # Here, there is a name collision, but it still could be ok if
12291 # the tables match the identical set of code points, in which
12292 # case, we can combine the names. Compare each table's code
12293 # point list to see if they are identical.
12294 trace "Potential name conflict with $pre_existing having ", $pre_existing->count, " code points" if main::DEBUG && $to_trace;
12295 if ($pre_existing->matches_identically_to($actual)) {
12297 # Here, they do match identically. Not a real conflict.
12298 # Make the perl version a child of the Unicode one, except
12299 # in the non-obvious case of where the perl name is
12300 # already a synonym of another Unicode property. (This is
12301 # excluded by the test for it being its own parent.) The
12302 # reason for this exclusion is that then the two Unicode
12303 # properties become related; and we don't really know if
12304 # they are or not. We generate documentation based on
12305 # relatedness, and this would be misleading. Code
12306 # later executed in the process will cause the tables to
12307 # be represented by a single file anyway, without making
12308 # it look in the pod like they are necessarily related.
12309 if ($pre_existing->parent == $pre_existing
12310 && ($pre_existing->property == $perl
12311 || $actual->property == $perl))
12313 trace "Setting $pre_existing equivalent to $actual since one is \$perl, and match identical sets" if main::DEBUG && $to_trace;
12314 $pre_existing->set_equivalent_to($actual, Related => 1);
12316 elsif (main::DEBUG && $to_trace) {
12317 trace "$pre_existing is equivalent to $actual since match identical sets, but not setting them equivalent, to preserve the separateness of the perl aliases";
12318 trace $pre_existing->parent;
12323 # Here they didn't match identically, there is a real conflict
12324 # between our new name and a pre-existing property.
12325 $actual->add_conflicting($proposed_name, 'p', $pre_existing);
12326 $pre_existing->add_conflicting($nominal->full_name,
12330 # Don't output a warning for aliases for the block
12331 # properties (unless they start with 'In_') as it is
12332 # expected that there will be conflicts and the block
12334 if ($verbosity >= $NORMAL_VERBOSITY
12335 && ($actual->property != $block || $prefix eq 'In_'))
12337 print simple_fold(join_lines(<<END
12338 There is already an alias named $proposed_name (from " . $pre_existing . "),
12339 so not creating this alias for " . $actual
12344 # Keep track for documentation purposes.
12345 $has_In_conflicts++ if $prefix eq 'In_';
12346 $has_Is_conflicts++ if $prefix eq 'Is_';
12351 # There are some properties which have No and Yes (and N and Y) as
12352 # property values, but aren't binary, and could possibly be confused with
12353 # binary ones. So create caveats for them. There are tables that are
12354 # named 'No', and tables that are named 'N', but confusion is not likely
12355 # unless they are the same table. For example, N meaning Number or
12356 # Neutral is not likely to cause confusion, so don't add caveats to things
12358 foreach my $property (grep { $_->type != $BINARY
12359 && $_->type != $FORCED_BINARY }
12362 my $yes = $property->table('Yes');
12363 if (defined $yes) {
12364 my $y = $property->table('Y');
12365 if (defined $y && $yes == $y) {
12366 foreach my $alias ($property->aliases) {
12367 $yes->add_conflicting($alias->name);
12371 my $no = $property->table('No');
12373 my $n = $property->table('N');
12374 if (defined $n && $no == $n) {
12375 foreach my $alias ($property->aliases) {
12376 $no->add_conflicting($alias->name, 'P');
12385 sub register_file_for_name($$$) {
12386 # Given info about a table and a datafile that it should be associated
12387 # with, register that association
12390 my $directory_ref = shift; # Array of the directory path for the file
12391 my $file = shift; # The file name in the final directory.
12392 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12394 trace "table=$table, file=$file, directory=@$directory_ref" if main::DEBUG && $to_trace;
12396 if ($table->isa('Property')) {
12397 $table->set_file_path(@$directory_ref, $file);
12398 push @map_properties, $table
12399 if $directory_ref->[0] eq $map_directory;
12403 # Do all of the work for all equivalent tables when called with the leader
12404 # table, so skip if isn't the leader.
12405 return if $table->leader != $table;
12407 # If this is a complement of another file, use that other file instead,
12408 # with a ! prepended to it.
12410 if (($complement = $table->complement) != 0) {
12411 my @directories = $complement->file_path;
12413 # This assumes that the 0th element is something like 'lib',
12414 # the 1th element the property name (in its own directory), like
12415 # 'AHex', and the 2th element the file like 'Y' which will have a .pl
12416 # appended to it later.
12417 $directories[1] =~ s/^/!/;
12418 $file = pop @directories;
12419 $directory_ref =\@directories;
12422 # Join all the file path components together, using slashes.
12423 my $full_filename = join('/', @$directory_ref, $file);
12425 # All go in the same subdirectory of unicore
12426 if ($directory_ref->[0] ne $matches_directory) {
12427 Carp::my_carp("Unexpected directory in "
12428 . join('/', @{$directory_ref}, $file));
12431 # For this table and all its equivalents ...
12432 foreach my $table ($table, $table->equivalents) {
12434 # Associate it with its file internally. Don't include the
12435 # $matches_directory first component
12436 $table->set_file_path(@$directory_ref, $file);
12437 my $sub_filename = join('/', $directory_ref->[1, -1], $file);
12439 my $property = $table->property;
12440 $property = ($property == $perl)
12441 ? "" # 'perl' is never explicitly stated
12442 : standardize($property->name) . '=';
12444 my $deprecated = ($table->status eq $DEPRECATED)
12445 ? $table->status_info
12447 my $caseless_equivalent = $table->caseless_equivalent;
12449 # And for each of the table's aliases... This inner loop eventually
12450 # goes through all aliases in the UCD that we generate regex match
12452 foreach my $alias ($table->aliases) {
12453 my $standard = utf8_heavy_name($table, $alias);
12455 # Generate an entry in either the loose or strict hashes, which
12456 # will translate the property and alias names combination into the
12457 # file where the table for them is stored.
12458 if ($alias->loose_match) {
12459 if (exists $loose_to_file_of{$standard}) {
12460 Carp::my_carp("Can't change file registered to $loose_to_file_of{$standard} to '$sub_filename'.");
12463 $loose_to_file_of{$standard} = $sub_filename;
12467 if (exists $stricter_to_file_of{$standard}) {
12468 Carp::my_carp("Can't change file registered to $stricter_to_file_of{$standard} to '$sub_filename'.");
12471 $stricter_to_file_of{$standard} = $sub_filename;
12473 # Tightly coupled with how utf8_heavy.pl works, for a
12474 # floating point number that is a whole number, get rid of
12475 # the trailing decimal point and 0's, so that utf8_heavy
12476 # will work. Also note that this assumes that such a
12477 # number is matched strictly; so if that were to change,
12478 # this would be wrong.
12479 if ((my $integer_name = $alias->name)
12480 =~ s/^ ( -? \d+ ) \.0+ $ /$1/x)
12482 $stricter_to_file_of{$property . $integer_name}
12488 # Keep a list of the deprecated properties and their filenames
12489 if ($deprecated && $complement == 0) {
12490 $utf8::why_deprecated{$sub_filename} = $deprecated;
12493 # And a substitute table, if any, for case-insensitive matching
12494 if ($caseless_equivalent != 0) {
12495 $caseless_equivalent_to{$standard} = $caseless_equivalent;
12504 my %base_names; # Names already used for avoiding DOS 8.3 filesystem
12506 my %full_dir_name_of; # Full length names of directories used.
12508 sub construct_filename($$$) {
12509 # Return a file name for a table, based on the table name, but perhaps
12510 # changed to get rid of non-portable characters in it, and to make
12511 # sure that it is unique on a file system that allows the names before
12512 # any period to be at most 8 characters (DOS). While we're at it
12513 # check and complain if there are any directory conflicts.
12515 my $name = shift; # The name to start with
12516 my $mutable = shift; # Boolean: can it be changed? If no, but
12517 # yet it must be to work properly, a warning
12519 my $directories_ref = shift; # A reference to an array containing the
12520 # path to the file, with each element one path
12521 # component. This is used because the same
12522 # name can be used in different directories.
12523 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12525 my $warn = ! defined wantarray; # If true, then if the name is
12526 # changed, a warning is issued as well.
12528 if (! defined $name) {
12529 Carp::my_carp("Undefined name in directory "
12530 . File::Spec->join(@$directories_ref)
12535 # Make sure that no directory names conflict with each other. Look at
12536 # each directory in the input file's path. If it is already in use,
12537 # assume it is correct, and is merely being re-used, but if we
12538 # truncate it to 8 characters, and find that there are two directories
12539 # that are the same for the first 8 characters, but differ after that,
12540 # then that is a problem.
12541 foreach my $directory (@$directories_ref) {
12542 my $short_dir = substr($directory, 0, 8);
12543 if (defined $full_dir_name_of{$short_dir}) {
12544 next if $full_dir_name_of{$short_dir} eq $directory;
12545 Carp::my_carp("$directory conflicts with $full_dir_name_of{$short_dir}. Bad News. Continuing anyway");
12548 $full_dir_name_of{$short_dir} = $directory;
12552 my $path = join '/', @$directories_ref;
12553 $path .= '/' if $path;
12555 # Remove interior underscores.
12556 (my $filename = $name) =~ s/ (?<=.) _ (?=.) //xg;
12558 # Change any non-word character into an underscore, and truncate to 8.
12559 $filename =~ s/\W+/_/g; # eg., "L&" -> "L_"
12560 substr($filename, 8) = "" if length($filename) > 8;
12562 # Make sure the basename doesn't conflict with something we
12563 # might have already written. If we have, say,
12570 while (my $num = $base_names{$path}{lc $filename}++) {
12571 $num++; # so basenames with numbers start with '2', which
12572 # just looks more natural.
12574 # Want to append $num, but if it'll make the basename longer
12575 # than 8 characters, pre-truncate $filename so that the result
12577 my $delta = length($filename) + length($num) - 8;
12579 substr($filename, -$delta) = $num;
12584 if ($warn && ! $warned) {
12586 Carp::my_carp("'$path$name' conflicts with another name on a filesystem with 8 significant characters (like DOS). Proceeding anyway.");
12590 return $filename if $mutable;
12592 # If not changeable, must return the input name, but warn if needed to
12593 # change it beyond shortening it.
12594 if ($name ne $filename
12595 && substr($name, 0, length($filename)) ne $filename) {
12596 Carp::my_carp("'$path$name' had to be changed into '$filename'. Bad News. Proceeding anyway.");
12602 # The pod file contains a very large table. Many of the lines in that table
12603 # would exceed a typical output window's size, and so need to be wrapped with
12604 # a hanging indent to make them look good. The pod language is really
12605 # insufficient here. There is no general construct to do that in pod, so it
12606 # is done here by beginning each such line with a space to cause the result to
12607 # be output without formatting, and doing all the formatting here. This leads
12608 # to the result that if the eventual display window is too narrow it won't
12609 # look good, and if the window is too wide, no advantage is taken of that
12610 # extra width. A further complication is that the output may be indented by
12611 # the formatter so that there is less space than expected. What I (khw) have
12612 # done is to assume that that indent is a particular number of spaces based on
12613 # what it is in my Linux system; people can always resize their windows if
12614 # necessary, but this is obviously less than desirable, but the best that can
12616 my $automatic_pod_indent = 8;
12618 # Try to format so that uses fewest lines, but few long left column entries
12619 # slide into the right column. An experiment on 5.1 data yielded the
12620 # following percentages that didn't cut into the other side along with the
12621 # associated first-column widths
12623 # 80% not too bad except for a few blocks
12624 # 90% = 33; # , cuts 353/3053 lines from 37 = 12%
12626 my $indent_info_column = 27; # 75% of lines didn't have overlap
12628 my $FILLER = 3; # Length of initial boiler-plate columns in a pod line
12629 # The 3 is because of:
12630 # 1 for the leading space to tell the pod formatter to
12633 # 1 for the space between the flag and the main data
12635 sub format_pod_line ($$$;$$) {
12636 # Take a pod line and return it, formatted properly
12638 my $first_column_width = shift;
12639 my $entry = shift; # Contents of left column
12640 my $info = shift; # Contents of right column
12642 my $status = shift || ""; # Any flag
12644 my $loose_match = shift; # Boolean.
12645 $loose_match = 1 unless defined $loose_match;
12647 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12650 $flags .= $STRICTER if ! $loose_match;
12652 $flags .= $status if $status;
12654 # There is a blank in the left column to cause the pod formatter to
12655 # output the line as-is.
12656 return sprintf " %-*s%-*s %s\n",
12657 # The first * in the format is replaced by this, the -1 is
12658 # to account for the leading blank. There isn't a
12659 # hard-coded blank after this to separate the flags from
12660 # the rest of the line, so that in the unlikely event that
12661 # multiple flags are shown on the same line, they both
12662 # will get displayed at the expense of that separation,
12663 # but since they are left justified, a blank will be
12664 # inserted in the normal case.
12668 # The other * in the format is replaced by this number to
12669 # cause the first main column to right fill with blanks.
12670 # The -1 is for the guaranteed blank following it.
12671 $first_column_width - $FILLER - 1,
12676 my @zero_match_tables; # List of tables that have no matches in this release
12678 sub make_table_pod_entries($) {
12679 # This generates the entries for the pod file for a given table.
12680 # Also done at this time are any children tables. The output looks like:
12681 # \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178)
12683 my $input_table = shift; # Table the entry is for
12684 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
12686 # Generate parent and all its children at the same time.
12687 return if $input_table->parent != $input_table;
12689 my $property = $input_table->property;
12690 my $type = $property->type;
12691 my $full_name = $property->full_name;
12693 my $count = $input_table->count;
12694 my $string_count = clarify_number($count);
12695 my $status = $input_table->status;
12696 my $status_info = $input_table->status_info;
12697 my $caseless_equivalent = $input_table->caseless_equivalent;
12699 my $entry_for_first_table; # The entry for the first table output.
12700 # Almost certainly, it is the parent.
12702 # For each related table (including itself), we will generate a pod entry
12703 # for each name each table goes by
12704 foreach my $table ($input_table, $input_table->children) {
12706 # utf8_heavy.pl cannot deal with null string property values, so skip
12707 # any tables that have no non-null names.
12708 next if ! grep { $_->name ne "" } $table->aliases;
12710 # First, gather all the info that applies to this table as a whole.
12712 push @zero_match_tables, $table if $count == 0;
12714 my $table_property = $table->property;
12716 # The short name has all the underscores removed, while the full name
12717 # retains them. Later, we decide whether to output a short synonym
12718 # for the full one, we need to compare apples to apples, so we use the
12719 # short name's length including underscores.
12720 my $table_property_short_name_length;
12721 my $table_property_short_name
12722 = $table_property->short_name(\$table_property_short_name_length);
12723 my $table_property_full_name = $table_property->full_name;
12725 # Get how much savings there is in the short name over the full one
12726 # (delta will always be <= 0)
12727 my $table_property_short_delta = $table_property_short_name_length
12728 - length($table_property_full_name);
12729 my @table_description = $table->description;
12730 my @table_note = $table->note;
12732 # Generate an entry for each alias in this table.
12733 my $entry_for_first_alias; # saves the first one encountered.
12734 foreach my $alias ($table->aliases) {
12736 # Skip if not to go in pod.
12737 next unless $alias->make_pod_entry;
12739 # Start gathering all the components for the entry
12740 my $name = $alias->name;
12742 # Skip if name is empty, as can't be accessed by regexes.
12743 next if $name eq "";
12745 my $entry; # Holds the left column, may include extras
12746 my $entry_ref; # To refer to the left column's contents from
12747 # another entry; has no extras
12749 # First the left column of the pod entry. Tables for the $perl
12750 # property always use the single form.
12751 if ($table_property == $perl) {
12752 $entry = "\\p{$name}";
12753 $entry_ref = "\\p{$name}";
12755 else { # Compound form.
12757 # Only generate one entry for all the aliases that mean true
12758 # or false in binary properties. Append a '*' to indicate
12759 # some are missing. (The heading comment notes this.)
12761 if ($type == $BINARY) {
12762 next if $name ne 'N' && $name ne 'Y';
12765 elsif ($type != $FORCED_BINARY) {
12770 # Forced binary properties require special handling. It
12771 # has two sets of tables, one set is true/false; and the
12772 # other set is everything else. Entries are generated for
12773 # each set. Use the Bidi_Mirrored property (which appears
12774 # in all Unicode versions) to get a list of the aliases
12775 # for the true/false tables. Of these, only output the N
12776 # and Y ones, the same as, a regular binary property. And
12777 # output all the rest, same as a non-binary property.
12778 my $bm = property_ref("Bidi_Mirrored");
12779 if ($name eq 'N' || $name eq 'Y') {
12781 } elsif (grep { $name eq $_->name } $bm->table("Y")->aliases,
12782 $bm->table("N")->aliases)
12791 # Colon-space is used to give a little more space to be easier
12794 . $table_property_full_name
12797 # But for the reference to this entry, which will go in the
12798 # right column, where space is at a premium, use equals
12800 $entry_ref = "\\p{" . $table_property_full_name . "=$name}";
12803 # Then the right (info) column. This is stored as components of
12804 # an array for the moment, then joined into a string later. For
12805 # non-internal only properties, begin the info with the entry for
12806 # the first table we encountered (if any), as things are ordered
12807 # so that that one is the most descriptive. This leads to the
12808 # info column of an entry being a more descriptive version of the
12811 if ($name =~ /^_/) {
12813 '(For internal use by Perl, not necessarily stable)';
12815 elsif ($entry_for_first_alias) {
12816 push @info, $entry_for_first_alias;
12819 # If this entry is equivalent to another, add that to the info,
12820 # using the first such table we encountered
12821 if ($entry_for_first_table) {
12823 push @info, "(= $entry_for_first_table)";
12826 push @info, $entry_for_first_table;
12830 # If the name is a large integer, add an equivalent with an
12831 # exponent for better readability
12832 if ($name =~ /^[+-]?[\d]+$/ && $name >= 10_000) {
12833 push @info, sprintf "(= %.1e)", $name
12836 my $parenthesized = "";
12837 if (! $entry_for_first_alias) {
12839 # This is the first alias for the current table. The alias
12840 # array is ordered so that this is the fullest, most
12841 # descriptive alias, so it gets the fullest info. The other
12842 # aliases are mostly merely pointers to this one, using the
12843 # information already added above.
12845 # Display any status message, but only on the parent table
12846 if ($status && ! $entry_for_first_table) {
12847 push @info, $status_info;
12850 # Put out any descriptive info
12851 if (@table_description || @table_note) {
12852 push @info, join "; ", @table_description, @table_note;
12855 # Look to see if there is a shorter name we can point people
12857 my $standard_name = standardize($name);
12859 my $proposed_short = $table->short_name;
12860 if (defined $proposed_short) {
12861 my $standard_short = standardize($proposed_short);
12863 # If the short name is shorter than the standard one, or
12864 # even it it's not, but the combination of it and its
12865 # short property name (as in \p{prop=short} ($perl doesn't
12866 # have this form)) saves at least two characters, then,
12867 # cause it to be listed as a shorter synonym.
12868 if (length $standard_short < length $standard_name
12869 || ($table_property != $perl
12870 && (length($standard_short)
12871 - length($standard_name)
12872 + $table_property_short_delta) # (<= 0)
12875 $short_name = $proposed_short;
12876 if ($table_property != $perl) {
12877 $short_name = $table_property_short_name
12880 $short_name = "\\p{$short_name}";
12884 # And if this is a compound form name, see if there is a
12885 # single form equivalent
12887 if ($table_property != $perl) {
12889 # Special case the binary N tables, so that will print
12890 # \P{single}, but use the Y table values to populate
12891 # 'single', as we haven't likewise populated the N table.
12892 # For forced binary tables, we can't just look at the N
12893 # table, but must see if this table is equivalent to the N
12894 # one, as there are two equivalent beasts in these
12898 if ( ($type == $BINARY
12899 && $input_table == $property->table('No'))
12900 || ($type == $FORCED_BINARY
12901 && $property->table('No')->
12902 is_set_equivalent_to($input_table)))
12904 $test_table = $property->table('Yes');
12908 $test_table = $input_table;
12912 # Look for a single form amongst all the children.
12913 foreach my $table ($test_table->children) {
12914 next if $table->property != $perl;
12915 my $proposed_name = $table->short_name;
12916 next if ! defined $proposed_name;
12918 # Don't mention internal-only properties as a possible
12919 # single form synonym
12920 next if substr($proposed_name, 0, 1) eq '_';
12922 $proposed_name = "\\$p\{$proposed_name}";
12923 if (! defined $single_form
12924 || length($proposed_name) < length $single_form)
12926 $single_form = $proposed_name;
12928 # The goal here is to find a single form; not the
12929 # shortest possible one. We've already found a
12930 # short name. So, stop at the first single form
12931 # found, which is likely to be closer to the
12938 # Ouput both short and single in the same parenthesized
12939 # expression, but with only one of 'Single', 'Short' if there
12941 if ($short_name || $single_form || $table->conflicting) {
12942 $parenthesized .= "Short: $short_name" if $short_name;
12943 if ($short_name && $single_form) {
12944 $parenthesized .= ', ';
12946 elsif ($single_form) {
12947 $parenthesized .= 'Single: ';
12949 $parenthesized .= $single_form if $single_form;
12953 if ($caseless_equivalent != 0) {
12954 $parenthesized .= '; ' if $parenthesized ne "";
12955 $parenthesized .= "/i= " . $caseless_equivalent->complete_name;
12959 # Warn if this property isn't the same as one that a
12960 # semi-casual user might expect. The other components of this
12961 # parenthesized structure are calculated only for the first entry
12962 # for this table, but the conflicting is deemed important enough
12963 # to go on every entry.
12964 my $conflicting = join " NOR ", $table->conflicting;
12965 if ($conflicting) {
12966 $parenthesized .= '; ' if $parenthesized ne "";
12967 $parenthesized .= "NOT $conflicting";
12970 push @info, "($parenthesized)" if $parenthesized;
12972 if ($name =~ /_$/ && $alias->loose_match) {
12973 push @info, "Note the trailing '_' matters in spite of loose matching rules.";
12976 if ($table_property != $perl && $table->perl_extension) {
12977 push @info, '(Perl extension)';
12979 push @info, "($string_count)";
12981 # Now, we have both the entry and info so add them to the
12982 # list of all the properties.
12983 push @match_properties,
12984 format_pod_line($indent_info_column,
12988 $alias->loose_match);
12990 $entry_for_first_alias = $entry_ref unless $entry_for_first_alias;
12991 } # End of looping through the aliases for this table.
12993 if (! $entry_for_first_table) {
12994 $entry_for_first_table = $entry_for_first_alias;
12996 } # End of looping through all the related tables
13000 sub pod_alphanumeric_sort {
13001 # Sort pod entries alphanumerically.
13003 # The first few character columns are filler, plus the '\p{'; and get rid
13004 # of all the trailing stuff, starting with the trailing '}', so as to sort
13005 # on just 'Name=Value'
13006 (my $a = lc $a) =~ s/^ .*? { //x;
13008 (my $b = lc $b) =~ s/^ .*? { //x;
13011 # Determine if the two operands are both internal only or both not.
13012 # Character 0 should be a '\'; 1 should be a p; 2 should be '{', so 3
13013 # should be the underscore that begins internal only
13014 my $a_is_internal = (substr($a, 0, 1) eq '_');
13015 my $b_is_internal = (substr($b, 0, 1) eq '_');
13017 # Sort so the internals come last in the table instead of first (which the
13018 # leading underscore would otherwise indicate).
13019 if ($a_is_internal != $b_is_internal) {
13020 return 1 if $a_is_internal;
13024 # Determine if the two operands are numeric property values or not.
13025 # A numeric property will look like xyz: 3. But the number
13026 # can begin with an optional minus sign, and may have a
13027 # fraction or rational component, like xyz: 3/2. If either
13028 # isn't numeric, use alphabetic sort.
13029 my ($a_initial, $a_number) =
13030 ($a =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
13031 return $a cmp $b unless defined $a_number;
13032 my ($b_initial, $b_number) =
13033 ($b =~ /^ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix);
13034 return $a cmp $b unless defined $b_number;
13036 # Here they are both numeric, but use alphabetic sort if the
13037 # initial parts don't match
13038 return $a cmp $b if $a_initial ne $b_initial;
13040 # Convert rationals to floating for the comparison.
13041 $a_number = eval $a_number if $a_number =~ qr{/};
13042 $b_number = eval $b_number if $b_number =~ qr{/};
13044 return $a_number <=> $b_number;
13048 # Create the .pod file. This generates the various subsections and then
13049 # combines them in one big HERE document.
13051 return unless defined $pod_directory;
13052 print "Making pod file\n" if $verbosity >= $PROGRESS;
13054 my $exception_message =
13055 '(Any exceptions are individually noted beginning with the word NOT.)';
13057 if (-e 'Blocks.txt') {
13059 # Add the line: '\p{In_*} \p{Block: *}', with the warning message
13060 # if the global $has_In_conflicts indicates we have them.
13061 push @match_properties, format_pod_line($indent_info_column,
13064 . (($has_In_conflicts)
13065 ? " $exception_message"
13067 @block_warning = << "END";
13069 Matches in the Block property have shortcuts that begin with "In_". For
13070 example, C<\\p{Block=Latin1}> can be written as C<\\p{In_Latin1}>. For
13071 backward compatibility, if there is no conflict with another shortcut, these
13072 may also be written as C<\\p{Latin1}> or C<\\p{Is_Latin1}>. But, N.B., there
13073 are numerous such conflicting shortcuts. Use of these forms for Block is
13074 discouraged, and are flagged as such, not only because of the potential
13075 confusion as to what is meant, but also because a later release of Unicode may
13076 preempt the shortcut, and your program would no longer be correct. Use the
13077 "In_" form instead to avoid this, or even more clearly, use the compound form,
13078 e.g., C<\\p{blk:latin1}>. See L<perlunicode/"Blocks"> for more information
13082 my $text = "If an entry has flag(s) at its beginning, like \"$DEPRECATED\", the \"Is_\" form has the same flag(s)";
13083 $text = "$exception_message $text" if $has_Is_conflicts;
13085 # And the 'Is_ line';
13086 push @match_properties, format_pod_line($indent_info_column,
13090 # Sort the properties array for output. It is sorted alphabetically
13091 # except numerically for numeric properties, and only output unique lines.
13092 @match_properties = sort pod_alphanumeric_sort uniques @match_properties;
13094 my $formatted_properties = simple_fold(\@match_properties,
13096 # indent succeeding lines by two extra
13097 # which looks better
13098 $indent_info_column + 2,
13100 # shorten the line length by how much
13101 # the formatter indents, so the folded
13102 # line will fit in the space
13103 # presumably available
13104 $automatic_pod_indent);
13105 # Add column headings, indented to be a little more centered, but not
13107 $formatted_properties = format_pod_line($indent_info_column,
13111 . $formatted_properties;
13113 # Generate pod documentation lines for the tables that match nothing
13114 my $zero_matches = "";
13115 if (@zero_match_tables) {
13116 @zero_match_tables = uniques(@zero_match_tables);
13117 $zero_matches = join "\n\n",
13118 map { $_ = '=item \p{' . $_->complete_name . "}" }
13119 sort { $a->complete_name cmp $b->complete_name }
13120 @zero_match_tables;
13122 $zero_matches = <<END;
13124 =head2 Legal C<\\p{}> and C<\\P{}> constructs that match no characters
13126 Unicode has some property-value pairs that currently don't match anything.
13127 This happens generally either because they are obsolete, or they exist for
13128 symmetry with other forms, but no language has yet been encoded that uses
13129 them. In this version of Unicode, the following match zero code points:
13140 # Generate list of properties that we don't accept, grouped by the reasons
13141 # why. This is so only put out the 'why' once, and then list all the
13142 # properties that have that reason under it.
13144 my %why_list; # The keys are the reasons; the values are lists of
13145 # properties that have the key as their reason
13147 # For each property, add it to the list that are suppressed for its reason
13148 # The sort will cause the alphabetically first properties to be added to
13149 # each list first, so each list will be sorted.
13150 foreach my $property (sort keys %why_suppressed) {
13151 push @{$why_list{$why_suppressed{$property}}}, $property;
13154 # For each reason (sorted by the first property that has that reason)...
13155 my @bad_re_properties;
13156 foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] }
13159 # Add to the output, all the properties that have that reason. Start
13160 # with an empty line.
13161 push @bad_re_properties, "\n\n";
13163 my $has_item = 0; # Flag if actually output anything.
13164 foreach my $name (@{$why_list{$why}}) {
13166 # Split compound names into $property and $table components
13167 my $property = $name;
13169 if ($property =~ / (.*) = (.*) /x) {
13174 # This release of Unicode may not have a property that is
13175 # suppressed, so don't reference a non-existent one.
13176 $property = property_ref($property);
13177 next if ! defined $property;
13179 # And since this list is only for match tables, don't list the
13180 # ones that don't have match tables.
13181 next if ! $property->to_create_match_tables;
13183 # Find any abbreviation, and turn it into a compound name if this
13184 # is a property=value pair.
13185 my $short_name = $property->name;
13186 $short_name .= '=' . $property->table($table)->name if $table;
13188 # And add the property as an item for the reason.
13189 push @bad_re_properties, "\n=item I<$name> ($short_name)\n";
13193 # And add the reason under the list of properties, if such a list
13194 # actually got generated. Note that the header got added
13195 # unconditionally before. But pod ignores extra blank lines, so no
13197 push @bad_re_properties, "\n$why\n" if $has_item;
13199 } # End of looping through each reason.
13201 # Generate a list of the properties whose map table we output, from the
13202 # global @map_properties.
13203 my @map_tables_actually_output;
13204 my $info_indent = 20; # Left column is narrower than \p{} table.
13205 foreach my $property (@map_properties) {
13207 # Get the path to the file; don't output any not in the standard
13209 my @path = $property->file_path;
13210 next if $path[0] ne $map_directory;
13212 # Don't mention map tables that are for internal-use only
13213 next if $property->to_output_map == $INTERNAL_MAP;
13215 shift @path; # Remove the standard name
13217 my $file = join '/', @path; # In case is in sub directory
13218 my $info = $property->full_name;
13219 my $short_name = $property->name;
13220 if ($info ne $short_name) {
13221 $info .= " ($short_name)";
13223 foreach my $more_info ($property->description,
13225 $property->status_info)
13227 next unless $more_info;
13229 $info .= ". $more_info";
13231 push @map_tables_actually_output, format_pod_line($info_indent,
13234 $property->status);
13237 # Sort alphabetically, and fold for output
13238 @map_tables_actually_output = sort
13239 pod_alphanumeric_sort @map_tables_actually_output;
13240 @map_tables_actually_output
13241 = simple_fold(\@map_tables_actually_output,
13244 $automatic_pod_indent);
13246 # Generate a list of the formats that can appear in the map tables.
13247 my @map_table_formats;
13248 foreach my $format (sort keys %map_table_formats) {
13249 push @map_table_formats,
13250 Text::Tabs::expand("$format\t$map_table_formats{$format}\n");
13252 @map_table_formats = simple_fold(\@map_table_formats,
13255 $automatic_pod_indent);
13258 # Everything is ready to assemble.
13259 my @OUT = << "END";
13264 To change this file, edit $0 instead.
13270 $pod_file - Index of Unicode Version $string_version properties in Perl
13274 There are many properties in Unicode, and Perl provides access to almost all of
13275 them, as well as some additional extensions and short-cut synonyms.
13277 And just about all of the few that aren't accessible through the Perl
13278 core are accessible through the modules: L<Unicode::Normalize> and
13279 L<Unicode::UCD>, and for Unihan properties, via the CPAN module
13280 L<Unicode::Unihan>.
13282 This document merely lists all available properties and does not attempt to
13283 explain what each property really means. There is a brief description of each
13284 Perl extension. There is some detail about Blocks, Scripts, General_Category,
13285 and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the
13286 Unicode properties, refer to the Unicode standard. A good starting place is
13287 L<$unicode_reference_url>. More information on the Perl extensions is in
13288 L<perlunicode/Other Properties>.
13290 Note that you can define your own properties; see
13291 L<perlunicode/"User-Defined Character Properties">.
13293 =head1 Properties accessible through C<\\p{}> and C<\\P{}>
13295 The Perl regular expression C<\\p{}> and C<\\P{}> constructs give access to
13296 most of the Unicode character properties. The table below shows all these
13297 constructs, both single and compound forms.
13299 B<Compound forms> consist of two components, separated by an equals sign or a
13300 colon. The first component is the property name, and the second component is
13301 the particular value of the property to match against, for example,
13302 C<\\p{Script: Greek}> and C<\\p{Script=Greek}> both mean to match characters
13303 whose Script property is Greek.
13305 B<Single forms>, like C<\\p{Greek}>, are mostly Perl-defined shortcuts for
13306 their equivalent compound forms. The table shows these equivalences. (In our
13307 example, C<\\p{Greek}> is a just a shortcut for C<\\p{Script=Greek}>.)
13308 There are also a few Perl-defined single forms that are not shortcuts for a
13309 compound form. One such is C<\\p{Word}>. These are also listed in the table.
13311 In parsing these constructs, Perl always ignores Upper/lower case differences
13312 everywhere within the {braces}. Thus C<\\p{Greek}> means the same thing as
13313 C<\\p{greek}>. But note that changing the case of the C<"p"> or C<"P"> before
13314 the left brace completely changes the meaning of the construct, from "match"
13315 (for C<\\p{}>) to "doesn't match" (for C<\\P{}>). Casing in this document is
13316 for improved legibility.
13318 Also, white space, hyphens, and underscores are also normally ignored
13319 everywhere between the {braces}, and hence can be freely added or removed
13320 even if the C</x> modifier hasn't been specified on the regular expression.
13321 But $a_bold_stricter at the beginning of an entry in the table below
13322 means that tighter (stricter) rules are used for that entry:
13326 =item Single form (C<\\p{name}>) tighter rules:
13328 White space, hyphens, and underscores ARE significant
13333 =item * white space adjacent to a non-word character
13335 =item * underscores separating digits in numbers
13339 That means, for example, that you can freely add or remove white space
13340 adjacent to (but within) the braces without affecting the meaning.
13342 =item Compound form (C<\\p{name=value}> or C<\\p{name:value}>) tighter rules:
13344 The tighter rules given above for the single form apply to everything to the
13345 right of the colon or equals; the looser rules still apply to everything to
13348 That means, for example, that you can freely add or remove white space
13349 adjacent to (but within) the braces and the colon or equal sign.
13353 Some properties are considered obsolete by Unicode, but still available.
13354 There are several varieties of obsolescence:
13360 A property may be stabilized. Such a determination does not indicate
13361 that the property should or should not be used; instead it is a declaration
13362 that the property will not be maintained nor extended for newly encoded
13363 characters. Such properties are marked with $a_bold_stabilized in the
13368 A property may be deprecated, perhaps because its original intent
13369 has been replaced by another property, or because its specification was
13370 somehow defective. This means that its use is strongly
13371 discouraged, so much so that a warning will be issued if used, unless the
13372 regular expression is in the scope of a C<S<no warnings 'deprecated'>>
13373 statement. $A_bold_deprecated flags each such entry in the table, and
13374 the entry there for the longest, most descriptive version of the property will
13375 give the reason it is deprecated, and perhaps advice. Perl may issue such a
13376 warning, even for properties that aren't officially deprecated by Unicode,
13377 when there used to be characters or code points that were matched by them, but
13378 no longer. This is to warn you that your program may not work like it did on
13379 earlier Unicode releases.
13381 A deprecated property may be made unavailable in a future Perl version, so it
13382 is best to move away from them.
13384 A deprecated property may also be stabilized, but this fact is not shown.
13388 Properties marked with $a_bold_obsolete in the table are considered (plain)
13389 obsolete. Generally this designation is given to properties that Unicode once
13390 used for internal purposes (but not any longer).
13394 Some Perl extensions are present for backwards compatibility and are
13395 discouraged from being used, but are not obsolete. $A_bold_discouraged
13396 flags each such entry in the table. Future Unicode versions may force
13397 some of these extensions to be removed without warning, replaced by another
13398 property with the same name that means something different. Use the
13399 equivalent shown instead.
13403 The table below has two columns. The left column contains the C<\\p{}>
13404 constructs to look up, possibly preceded by the flags mentioned above; and
13405 the right column contains information about them, like a description, or
13406 synonyms. It shows both the single and compound forms for each property that
13407 has them. If the left column is a short name for a property, the right column
13408 will give its longer, more descriptive name; and if the left column is the
13409 longest name, the right column will show any equivalent shortest name, in both
13410 single and compound forms if applicable.
13412 The right column will also caution you if a property means something different
13413 than what might normally be expected.
13415 All single forms are Perl extensions; a few compound forms are as well, and
13418 Numbers in (parentheses) indicate the total number of code points matched by
13419 the property. For emphasis, those properties that match no code points at all
13420 are listed as well in a separate section following the table.
13422 Most properties match the same code points regardless of whether C<"/i">
13423 case-insensitive matching is specified or not. But a few properties are
13424 affected. These are shown with the notation
13426 (/i= other_property)
13428 in the second column. Under case-insensitive matching they match the
13429 same code pode points as the property "other_property".
13431 There is no description given for most non-Perl defined properties (See
13432 L<$unicode_reference_url> for that).
13434 For compactness, 'B<*>' is used as a wildcard instead of showing all possible
13435 combinations. For example, entries like:
13437 \\p{Gc: *} \\p{General_Category: *}
13439 mean that 'Gc' is a synonym for 'General_Category', and anything that is valid
13440 for the latter is also valid for the former. Similarly,
13444 means that if and only if, for example, C<\\p{Foo}> exists, then
13445 C<\\p{Is_Foo}> and C<\\p{IsFoo}> are also valid and all mean the same thing.
13446 And similarly, C<\\p{Foo=Bar}> means the same as C<\\p{Is_Foo=Bar}> and
13447 C<\\p{IsFoo=Bar}>. "*" here is restricted to something not beginning with an
13450 Also, in binary properties, 'Yes', 'T', and 'True' are all synonyms for 'Y'.
13451 And 'No', 'F', and 'False' are all synonyms for 'N'. The table shows 'Y*' and
13452 'N*' to indicate this, and doesn't have separate entries for the other
13453 possibilities. Note that not all properties which have values 'Yes' and 'No'
13454 are binary, and they have all their values spelled out without using this wild
13455 card, and a C<NOT> clause in their description that highlights their not being
13456 binary. These also require the compound form to match them, whereas true
13457 binary properties have both single and compound forms available.
13459 Note that all non-essential underscores are removed in the display of the
13466 =item Z<>B<*> is a wild-card
13468 =item B<(\\d+)> in the info column gives the number of code points matched by
13471 =item B<$DEPRECATED> means this is deprecated.
13473 =item B<$OBSOLETE> means this is obsolete.
13475 =item B<$STABILIZED> means this is stabilized.
13477 =item B<$STRICTER> means tighter (stricter) name matching applies.
13479 =item B<$DISCOURAGED> means use of this form is discouraged, and may not be
13484 $formatted_properties
13488 =head1 Properties not accessible through \\p{} and \\P{}
13490 A few properties are accessible in Perl via various function calls only.
13493 Lowercase_Mapping lc() and lcfirst()
13494 Titlecase_Mapping ucfirst()
13495 Uppercase_Mapping uc()
13497 Case_Folding is accessible through the C</i> modifier in regular expressions.
13499 The Name property is accessible through the C<\\N{}> interpolation in
13500 double-quoted strings and regular expressions, but both usages require a C<use
13501 charnames;> to be specified, which also contains related functions viacode(),
13502 vianame(), and string_vianame().
13504 =head1 Unicode regular expression properties that are NOT accepted by Perl
13506 Perl will generate an error for a few character properties in Unicode when
13507 used in a regular expression. The non-Unihan ones are listed below, with the
13508 reasons they are not accepted, perhaps with work-arounds. The short names for
13509 the properties are listed enclosed in (parentheses).
13510 As described after the list, an installation can change the defaults and choose
13511 to accept any of these. The list is machine generated based on the
13512 choices made for the installation that generated this document.
13520 An installation can choose to allow any of these to be matched by downloading
13521 the Unicode database from L<http://www.unicode.org/Public/> to
13522 C<\$Config{privlib}>/F<unicore/> in the Perl source tree, changing the
13523 controlling lists contained in the program
13524 C<\$Config{privlib}>/F<unicore/mktables> and then re-compiling and installing.
13525 (C<\%Config> is available from the Config module).
13527 =head1 Files in the I<To> directory (for serious hackers only)
13529 All Unicode properties are really mappings (in the mathematical sense) from
13530 code points to their respective values. As part of its build process,
13531 Perl constructs tables containing these mappings for all properties that it
13532 deals with. Some, but not all, of these are written out into files.
13533 Those written out are in the directory C<\$Config{privlib}>/F<unicore/To/>
13534 (C<%Config> is available from the C<Config> module).
13536 Perl reserves the right to change the format and even the existence of any of
13537 those files without notice, except the ones that were in existence prior to
13538 release 5.14. If those change, a deprecation cycle will be done first. These
13541 @map_tables_actually_output
13543 Each of the files in this directory defines several hash entries to help
13544 reading programs decipher it. One of them looks like this:
13546 \$utf8::SwashInfo{'ToNAME'}{'format'} = 's';
13548 where "NAME" is a name to indicate the property. For backwards compatibility,
13549 this is not necessarily the property's official Unicode name. (The "To" is
13550 also for backwards compatibility.) The hash entry gives the format of the
13551 mapping fields of the table, currently one of the following:
13555 This format applies only to the entries in the main body of the table.
13556 Entries defined in hashes or ones that are missing from the list can have a
13559 The value that the missing entries have is given by another SwashInfo hash
13560 entry line; it looks like this:
13562 \$utf8::SwashInfo{'ToNAME'}{'missing'} = 'NaN';
13564 This example line says that any Unicode code points not explicitly listed in
13565 the file have the value "NaN" under the property indicated by NAME. If the
13566 value is the special string C<< <code point> >>, it means that the value for
13567 any missing code point is the code point itself. This happens, for example,
13568 in the file for Uppercase_Mapping (To/Upper.pl), in which code points like the
13569 character "A", are missing because the uppercase of "A" is itself.
13571 Finally, if the file contains a hash for special case entries, its name is
13572 specified by an entry that looks like this:
13574 \$utf8::SwashInfo{'ToNAME'}{'specials_name'} = 'utf8::ToSpecNAME';
13578 L<$unicode_reference_url>
13586 # And write it. The 0 means no utf8.
13587 main::write([ $pod_directory, "$pod_file.pod" ], 0, \@OUT);
13591 sub make_Heavy () {
13592 # Create and write Heavy.pl, which passes info about the tables to
13599 # This file is for the use of utf8_heavy.pl
13601 # Maps Unicode (not Perl single-form extensions) property names in loose
13602 # standard form to their corresponding standard names
13603 \%utf8::loose_property_name_of = (
13606 push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4);
13607 push @heavy, <<END;
13610 # Maps property, table to file for those using stricter matching
13611 \%utf8::stricter_to_file_of = (
13613 push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4);
13614 push @heavy, <<END;
13617 # Maps property, table to file for those using loose matching
13618 \%utf8::loose_to_file_of = (
13620 push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4);
13621 push @heavy, <<END;
13624 # Maps floating point to fractional form
13625 \%utf8::nv_floating_to_rational = (
13627 push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4);
13628 push @heavy, <<END;
13631 # If a floating point number doesn't have enough digits in it to get this
13632 # close to a fraction, it isn't considered to be that fraction even if all the
13633 # digits it does have match.
13634 \$utf8::max_floating_slop = $MAX_FLOATING_SLOP;
13636 # Deprecated tables to generate a warning for. The key is the file containing
13637 # the table, so as to avoid duplication, as many property names can map to the
13638 # file, but we only need one entry for all of them.
13639 \%utf8::why_deprecated = (
13642 push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4);
13643 push @heavy, <<END;
13646 # A few properties have different behavior under /i matching. This maps the
13647 # those to substitute files to use under /i.
13648 \%utf8::caseless_equivalent = (
13651 # We set the key to the file when we associated files with tables, but we
13652 # couldn't do the same for the value then, as we might not have the file
13653 # for the alternate table figured out at that time.
13654 foreach my $cased (keys %caseless_equivalent_to) {
13655 my @path = $caseless_equivalent_to{$cased}->file_path;
13656 my $path = join '/', @path[1, -1];
13657 $utf8::caseless_equivalent_to{$cased} = $path;
13659 push @heavy, simple_dumper (\%utf8::caseless_equivalent_to, ' ' x 4);
13660 push @heavy, <<END;
13666 main::write("Heavy.pl", 0, \@heavy); # The 0 means no utf8.
13670 sub make_Name_pm () {
13671 # Create and write Name.pm, which contains subroutines and data to use in
13672 # conjunction with Name.pl
13674 # Maybe there's nothing to do.
13675 return unless $has_hangul_syllables || @code_points_ending_in_code_point;
13682 # Convert these structures to output format.
13683 my $code_points_ending_in_code_point =
13684 main::simple_dumper(\@code_points_ending_in_code_point,
13686 my $names = main::simple_dumper(\%names_ending_in_code_point,
13688 my $loose_names = main::simple_dumper(\%loose_names_ending_in_code_point,
13691 # Do the same with the Hangul names,
13697 if ($has_hangul_syllables) {
13699 # Construct a regular expression of all the possible
13700 # combinations of the Hangul syllables.
13701 my @L_re; # Leading consonants
13702 for my $i ($LBase .. $LBase + $LCount - 1) {
13703 push @L_re, $Jamo{$i}
13705 my @V_re; # Middle vowels
13706 for my $i ($VBase .. $VBase + $VCount - 1) {
13707 push @V_re, $Jamo{$i}
13709 my @T_re; # Trailing consonants
13710 for my $i ($TBase + 1 .. $TBase + $TCount - 1) {
13711 push @T_re, $Jamo{$i}
13714 # The whole re is made up of the L V T combination.
13716 . join ('|', sort @L_re)
13718 . join ('|', sort @V_re)
13720 . join ('|', sort @T_re)
13723 # These hashes needed by the algorithm were generated
13724 # during reading of the Jamo.txt file
13725 $jamo = main::simple_dumper(\%Jamo, ' ' x 8);
13726 $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8);
13727 $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8);
13728 $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8);
13733 # This module contains machine-generated tables and code for the
13734 # algorithmically-determinable Unicode character names. The following
13735 # routines can be used to translate between name and code point and vice versa
13739 # Matches legal code point. 4-6 hex numbers, If there are 6, the
13740 # first two must be '10'; if there are 5, the first must not be a '0'.
13741 # First can match at the end of a word provided that the end of the
13742 # word doesn't look like a hex number.
13743 my \$run_on_code_point_re = qr/$run_on_code_point_re/;
13744 my \$code_point_re = qr/$code_point_re/;
13746 # In the following hash, the keys are the bases of names which includes
13747 # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values
13748 # of each key is another hash which is used to get the low and high ends
13749 # for each range of code points that apply to the name.
13750 my %names_ending_in_code_point = (
13754 # The following hash is a copy of the previous one, except is for loose
13755 # matching, so each name has blanks and dashes squeezed out
13756 my %loose_names_ending_in_code_point = (
13760 # And the following array gives the inverse mapping from code points to
13761 # names. Lowest code points are first
13762 my \@code_points_ending_in_code_point = (
13763 $code_points_ending_in_code_point
13766 # Earlier releases didn't have Jamos. No sense outputting
13767 # them unless will be used.
13768 if ($has_hangul_syllables) {
13771 # Convert from code point to Jamo short name for use in composing Hangul
13777 # Leading consonant (can be null)
13787 # Optional trailing consonant
13792 # Computed re that splits up a Hangul name into LVT or LV syllables
13793 my \$syllable_re = qr/$jamo_re/;
13795 my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
13796 my \$loose_HANGUL_SYLLABLE = "HANGULSYLLABLE";
13798 # These constants names and values were taken from the Unicode standard,
13799 # version 5.1, section 3.12. They are used in conjunction with Hangul
13801 my \$SBase = $SBase_string;
13802 my \$LBase = $LBase_string;
13803 my \$VBase = $VBase_string;
13804 my \$TBase = $TBase_string;
13805 my \$SCount = $SCount;
13806 my \$LCount = $LCount;
13807 my \$VCount = $VCount;
13808 my \$TCount = $TCount;
13809 my \$NCount = \$VCount * \$TCount;
13811 } # End of has Jamos
13813 push @name, << 'END';
13815 sub name_to_code_point_special {
13816 my ($name, $loose) = @_;
13818 # Returns undef if not one of the specially handled names; otherwise
13819 # returns the code point equivalent to the input name
13820 # $loose is non-zero if to use loose matching, 'name' in that case
13821 # must be input as upper case with all blanks and dashes squeezed out.
13823 if ($has_hangul_syllables) {
13824 push @name, << 'END';
13826 if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//)
13827 || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//))
13829 return if $name !~ qr/^$syllable_re$/;
13830 my $L = $Jamo_L{$1};
13831 my $V = $Jamo_V{$2};
13832 my $T = (defined $3) ? $Jamo_T{$3} : 0;
13833 return ($L * $VCount + $V) * $TCount + $T + $SBase;
13837 push @name, << 'END';
13839 # Name must end in 'code_point' for this to handle.
13840 return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x)
13841 || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x));
13844 my $code_point = CORE::hex $2;
13848 $names_ref = \%loose_names_ending_in_code_point;
13851 return if $base !~ s/-$//;
13852 $names_ref = \%names_ending_in_code_point;
13855 # Name must be one of the ones which has the code point in it.
13856 return if ! $names_ref->{$base};
13858 # Look through the list of ranges that apply to this name to see if
13859 # the code point is in one of them.
13860 for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) {
13861 return if $names_ref->{$base}{'low'}->[$i] > $code_point;
13862 next if $names_ref->{$base}{'high'}->[$i] < $code_point;
13864 # Here, the code point is in the range.
13865 return $code_point;
13868 # Here, looked like the name had a code point number in it, but
13869 # did not match one of the valid ones.
13873 sub code_point_to_name_special {
13874 my $code_point = shift;
13876 # Returns the name of a code point if algorithmically determinable;
13879 if ($has_hangul_syllables) {
13880 push @name, << 'END';
13882 # If in the Hangul range, calculate the name based on Unicode's
13884 if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
13886 my $SIndex = $code_point - $SBase;
13887 my $L = $LBase + $SIndex / $NCount;
13888 my $V = $VBase + ($SIndex % $NCount) / $TCount;
13889 my $T = $TBase + $SIndex % $TCount;
13890 $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
13891 $name .= $Jamo{$T} if $T != $TBase;
13896 push @name, << 'END';
13898 # Look through list of these code points for one in range.
13899 foreach my $hash (@code_points_ending_in_code_point) {
13900 return if $code_point < $hash->{'low'};
13901 if ($code_point <= $hash->{'high'}) {
13902 return sprintf("%s-%04X", $hash->{'name'}, $code_point);
13905 return; # None found
13912 main::write("Name.pm", 0, \@name); # The 0 means no utf8.
13917 sub write_all_tables() {
13918 # Write out all the tables generated by this program to files, as well as
13919 # the supporting data structures, pod file, and .t file.
13921 my @writables; # List of tables that actually get written
13922 my %match_tables_to_write; # Used to collapse identical match tables
13923 # into one file. Each key is a hash function
13924 # result to partition tables into buckets.
13925 # Each value is an array of the tables that
13926 # fit in the bucket.
13928 # For each property ...
13929 # (sort so that if there is an immutable file name, it has precedence, so
13930 # some other property can't come in and take over its file name. If b's
13931 # file name is defined, will return 1, meaning to take it first; don't
13932 # care if both defined, as they had better be different anyway. And the
13933 # property named 'Perl' needs to be first (it doesn't have any immutable
13934 # file name) because empty properties are defined in terms of it's table
13937 foreach my $property (sort { return -1 if $a == $perl;
13938 return 1 if $b == $perl;
13939 return defined $b->file
13940 } property_ref('*'))
13942 my $type = $property->type;
13944 # And for each table for that property, starting with the mapping
13947 foreach my $table($property,
13949 # and all the match tables for it (if any), sorted so
13950 # the ones with the shortest associated file name come
13951 # first. The length sorting prevents problems of a
13952 # longer file taking a name that might have to be used
13953 # by a shorter one. The alphabetic sorting prevents
13954 # differences between releases
13955 sort { my $ext_a = $a->external_name;
13956 return 1 if ! defined $ext_a;
13957 my $ext_b = $b->external_name;
13958 return -1 if ! defined $ext_b;
13960 # But return the non-complement table before
13961 # the complement one, as the latter is defined
13962 # in terms of the former, and needs to have
13963 # the information for the former available.
13964 return 1 if $a->complement != 0;
13965 return -1 if $b->complement != 0;
13967 # Similarly, return a subservient table after
13969 return 1 if $a->leader != $a;
13970 return -1 if $b->leader != $b;
13972 my $cmp = length $ext_a <=> length $ext_b;
13974 # Return result if lengths not equal
13975 return $cmp if $cmp;
13977 # Alphabetic if lengths equal
13978 return $ext_a cmp $ext_b
13979 } $property->tables
13983 # Here we have a table associated with a property. It could be
13984 # the map table (done first for each property), or one of the
13985 # other tables. Determine which type.
13986 my $is_property = $table->isa('Property');
13988 my $name = $table->name;
13989 my $complete_name = $table->complete_name;
13991 # See if should suppress the table if is empty, but warn if it
13992 # contains something.
13993 my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ }
13994 keys %why_suppress_if_empty_warn_if_not;
13996 # Calculate if this table should have any code points associated
13998 my $expected_empty =
14000 # $perl should be empty, as well as properties that we just
14001 # don't do anything with
14003 && ($table == $perl
14004 || grep { $complete_name eq $_ }
14005 @unimplemented_properties
14009 # Match tables in properties we skipped populating should be
14011 || (! $is_property && ! $property->to_create_match_tables)
14013 # Tables and properties that are expected to have no code
14014 # points should be empty
14015 || $suppress_if_empty_warn_if_not
14018 # Set a boolean if this table is the complement of an empty binary
14020 my $is_complement_of_empty_binary =
14021 $type == $BINARY &&
14022 (($table == $property->table('Y')
14023 && $property->table('N')->is_empty)
14024 || ($table == $property->table('N')
14025 && $property->table('Y')->is_empty));
14028 # Some tables should match everything
14029 my $expected_full =
14031 ? # All these types of map tables will be full because
14032 # they will have been populated with defaults
14033 ($type == $ENUM || $type == $FORCED_BINARY)
14035 : # A match table should match everything if its method
14037 ($table->matches_all
14039 # The complement of an empty binary table will match
14041 || $is_complement_of_empty_binary
14045 if ($table->is_empty) {
14047 if ($suppress_if_empty_warn_if_not) {
14048 $table->set_status($SUPPRESSED,
14049 $why_suppress_if_empty_warn_if_not{$complete_name});
14052 # Suppress (by skipping them) expected empty tables.
14053 next TABLE if $expected_empty;
14055 # And setup to later output a warning for those that aren't
14056 # known to be allowed to be empty. Don't do the warning if
14057 # this table is a child of another one to avoid duplicating
14058 # the warning that should come from the parent one.
14059 if (($table == $property || $table->parent == $table)
14060 && $table->status ne $SUPPRESSED
14061 && ! grep { $complete_name =~ /^$_$/ }
14062 @tables_that_may_be_empty)
14064 push @unhandled_properties, "$table";
14067 # An empty table is just the complement of everything.
14068 $table->set_complement($Any) if $table != $property;
14070 elsif ($expected_empty) {
14072 if ($suppress_if_empty_warn_if_not) {
14073 $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}";
14076 Carp::my_carp("Not expecting property $table$because. Generating file for it anyway.");
14079 my $count = $table->count;
14080 if ($expected_full) {
14081 if ($count != $MAX_UNICODE_CODEPOINTS) {
14082 Carp::my_carp("$table matches only "
14083 . clarify_number($count)
14084 . " Unicode code points but should match "
14085 . clarify_number($MAX_UNICODE_CODEPOINTS)
14087 . clarify_number(abs($MAX_UNICODE_CODEPOINTS - $count))
14088 . "). Proceeding anyway.");
14091 # Here is expected to be full. If it is because it is the
14092 # complement of an (empty) binary table that is to be
14093 # suppressed, then suppress this one as well.
14094 if ($is_complement_of_empty_binary) {
14095 my $opposing_name = ($name eq 'Y') ? 'N' : 'Y';
14096 my $opposing = $property->table($opposing_name);
14097 my $opposing_status = $opposing->status;
14098 if ($opposing_status) {
14099 $table->set_status($opposing_status,
14100 $opposing->status_info);
14104 elsif ($count == $MAX_UNICODE_CODEPOINTS) {
14105 if ($table == $property || $table->leader == $table) {
14106 Carp::my_carp("$table unexpectedly matches all Unicode code points. Proceeding anyway.");
14110 if ($table->status eq $SUPPRESSED) {
14111 if (! $is_property) {
14112 my @children = $table->children;
14113 foreach my $child (@children) {
14114 if ($child->status ne $SUPPRESSED) {
14115 Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't");
14122 if (! $is_property) {
14124 # Several things need to be done just once for each related
14125 # group of match tables. Do them on the parent.
14126 if ($table->parent == $table) {
14128 # Add an entry in the pod file for the table; it also does
14130 make_table_pod_entries($table) if defined $pod_directory;
14132 # See if the the table matches identical code points with
14133 # something that has already been output. In that case,
14134 # no need to have two files with the same code points in
14135 # them. We use the table's hash() method to store these
14136 # in buckets, so that it is quite likely that if two
14137 # tables are in the same bucket they will be identical, so
14138 # don't have to compare tables frequently. The tables
14139 # have to have the same status to share a file, so add
14140 # this to the bucket hash. (The reason for this latter is
14141 # that Heavy.pl associates a status with a file.)
14142 # We don't check tables that are inverses of others, as it
14143 # would lead to some coding complications, and checking
14144 # all the regular ones should find everything.
14145 if ($table->complement == 0) {
14146 my $hash = $table->hash . ';' . $table->status;
14148 # Look at each table that is in the same bucket as
14149 # this one would be.
14150 foreach my $comparison
14151 (@{$match_tables_to_write{$hash}})
14153 if ($table->matches_identically_to($comparison)) {
14154 $table->set_equivalent_to($comparison,
14160 # Here, not equivalent, add this table to the bucket.
14161 push @{$match_tables_to_write{$hash}}, $table;
14167 # Here is the property itself.
14168 # Don't write out or make references to the $perl property
14169 next if $table == $perl;
14171 if ($type != $STRING) {
14173 # There is a mapping stored of the various synonyms to the
14174 # standardized name of the property for utf8_heavy.pl.
14175 # Also, the pod file contains entries of the form:
14176 # \p{alias: *} \p{full: *}
14177 # rather than show every possible combination of things.
14179 my @property_aliases = $property->aliases;
14181 # The full name of this property is stored by convention
14182 # first in the alias array
14183 my $full_property_name =
14184 '\p{' . $property_aliases[0]->name . ': *}';
14185 my $standard_property_name = standardize($table->name);
14187 # For each synonym ...
14188 for my $i (0 .. @property_aliases - 1) {
14189 my $alias = $property_aliases[$i];
14190 my $alias_name = $alias->name;
14191 my $alias_standard = standardize($alias_name);
14193 # For utf8_heavy, set the mapping of the alias to the
14195 if (exists ($loose_property_name_of{$alias_standard}))
14197 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");
14200 $loose_property_name_of{$alias_standard}
14201 = $standard_property_name;
14204 # Now for the pod entry for this alias. Skip if not
14205 # outputting a pod; skip the first one, which is the
14206 # full name so won't have an entry like: '\p{full: *}
14207 # \p{full: *}', and skip if don't want an entry for
14210 || ! defined $pod_directory
14211 || ! $alias->make_pod_entry;
14213 my $rhs = $full_property_name;
14214 if ($property != $perl && $table->perl_extension) {
14215 $rhs .= ' (Perl extension)';
14217 push @match_properties,
14218 format_pod_line($indent_info_column,
14219 '\p{' . $alias->name . ': *}',
14223 } # End of non-string-like property code
14226 # Don't write out a mapping file if not desired.
14227 next if ! $property->to_output_map;
14230 # Here, we know we want to write out the table, but don't do it
14231 # yet because there may be other tables that come along and will
14232 # want to share the file, and the file's comments will change to
14233 # mention them. So save for later.
14234 push @writables, $table;
14236 } # End of looping through the property and all its tables.
14237 } # End of looping through all properties.
14239 # Now have all the tables that will have files written for them. Do it.
14240 foreach my $table (@writables) {
14243 my $property = $table->property;
14244 my $is_property = ($table == $property);
14245 if (! $is_property) {
14247 # Match tables for the property go in lib/$subdirectory, which is
14248 # the property's name. Don't use the standard file name for this,
14249 # as may get an unfamiliar alias
14250 @directory = ($matches_directory, $property->external_name);
14254 @directory = $table->directory;
14255 $filename = $table->file;
14258 # Use specified filename if available, or default to property's
14259 # shortest name. We need an 8.3 safe filename (which means "an 8
14260 # safe" filename, since after the dot is only 'pl', which is < 3)
14261 # The 2nd parameter is if the filename shouldn't be changed, and
14262 # it shouldn't iff there is a hard-coded name for this table.
14263 $filename = construct_filename(
14264 $filename || $table->external_name,
14265 ! $filename, # mutable if no filename
14268 register_file_for_name($table, \@directory, $filename);
14270 # Only need to write one file when shared by more than one
14272 next if ! $is_property
14273 && ($table->leader != $table || $table->complement != 0);
14275 # Construct a nice comment to add to the file
14276 $table->set_final_comment;
14282 # Write out the pod file
14285 # And Heavy.pl, Name.pm
14289 make_property_test_script() if $make_test_script;
14293 my @white_space_separators = ( # This used only for making the test script.
14300 sub generate_separator($) {
14301 # This used only for making the test script. It generates the colon or
14302 # equal separator between the property and property value, with random
14303 # white space surrounding the separator
14307 return "" if $lhs eq ""; # No separator if there's only one (the r) side
14309 # Choose space before and after randomly
14310 my $spaces_before =$white_space_separators[rand(@white_space_separators)];
14311 my $spaces_after = $white_space_separators[rand(@white_space_separators)];
14313 # And return the whole complex, half the time using a colon, half the
14315 return $spaces_before
14316 . (rand() < 0.5) ? '=' : ':'
14320 sub generate_tests($$$$$) {
14321 # This used only for making the test script. It generates test cases that
14322 # are expected to compile successfully in perl. Note that the lhs and
14323 # rhs are assumed to already be as randomized as the caller wants.
14325 my $lhs = shift; # The property: what's to the left of the colon
14326 # or equals separator
14327 my $rhs = shift; # The property value; what's to the right
14328 my $valid_code = shift; # A code point that's known to be in the
14329 # table given by lhs=rhs; undef if table is
14331 my $invalid_code = shift; # A code point known to not be in the table;
14332 # undef if the table is all code points
14333 my $warning = shift;
14335 # Get the colon or equal
14336 my $separator = generate_separator($lhs);
14338 # The whole 'property=value'
14339 my $name = "$lhs$separator$rhs";
14342 # Create a complete set of tests, with complements.
14343 if (defined $valid_code) {
14344 push @output, <<"EOC"
14345 Expect(1, $valid_code, '\\p{$name}', $warning);
14346 Expect(0, $valid_code, '\\p{^$name}', $warning);
14347 Expect(0, $valid_code, '\\P{$name}', $warning);
14348 Expect(1, $valid_code, '\\P{^$name}', $warning);
14351 if (defined $invalid_code) {
14352 push @output, <<"EOC"
14353 Expect(0, $invalid_code, '\\p{$name}', $warning);
14354 Expect(1, $invalid_code, '\\p{^$name}', $warning);
14355 Expect(1, $invalid_code, '\\P{$name}', $warning);
14356 Expect(0, $invalid_code, '\\P{^$name}', $warning);
14362 sub generate_error($$$) {
14363 # This used only for making the test script. It generates test cases that
14364 # are expected to not only not match, but to be syntax or similar errors
14366 my $lhs = shift; # The property: what's to the left of the
14367 # colon or equals separator
14368 my $rhs = shift; # The property value; what's to the right
14369 my $already_in_error = shift; # Boolean; if true it's known that the
14370 # unmodified lhs and rhs will cause an error.
14371 # This routine should not force another one
14372 # Get the colon or equal
14373 my $separator = generate_separator($lhs);
14375 # Since this is an error only, don't bother to randomly decide whether to
14376 # put the error on the left or right side; and assume that the rhs is
14377 # loosely matched, again for convenience rather than rigor.
14378 $rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error;
14380 my $property = $lhs . $separator . $rhs;
14383 Error('\\p{$property}');
14384 Error('\\P{$property}');
14388 # These are used only for making the test script
14389 # XXX Maybe should also have a bad strict seps, which includes underscore.
14391 my @good_loose_seps = (
14398 my @bad_loose_seps = (
14403 sub randomize_stricter_name {
14404 # This used only for making the test script. Take the input name and
14405 # return a randomized, but valid version of it under the stricter matching
14409 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
14411 # If the name looks like a number (integer, floating, or rational), do
14413 if ($name =~ qr{ ^ ( -? ) (\d+ ( ( [./] ) \d+ )? ) $ }x) {
14416 my $separator = $3;
14418 # If there isn't a sign, part of the time add a plus
14419 # Note: Not testing having any denominator having a minus sign
14421 $sign = '+' if rand() <= .3;
14424 # And add 0 or more leading zeros.
14425 $name = $sign . ('0' x int rand(10)) . $number;
14427 if (defined $separator) {
14428 my $extra_zeros = '0' x int rand(10);
14430 if ($separator eq '.') {
14432 # Similarly, add 0 or more trailing zeros after a decimal
14434 $name .= $extra_zeros;
14438 # Or, leading zeros before the denominator
14439 $name =~ s,/,/$extra_zeros,;
14444 # For legibility of the test, only change the case of whole sections at a
14445 # time. To do this, first split into sections. The split returns the
14448 for my $section (split / ( [ - + \s _ . ]+ ) /x, $name) {
14449 trace $section if main::DEBUG && $to_trace;
14451 if (length $section > 1 && $section !~ /\D/) {
14453 # If the section is a sequence of digits, about half the time
14454 # randomly add underscores between some of them.
14457 # Figure out how many underscores to add. max is 1 less than
14458 # the number of digits. (But add 1 at the end to make sure
14459 # result isn't 0, and compensate earlier by subtracting 2
14461 my $num_underscores = int rand(length($section) - 2) + 1;
14463 # And add them evenly throughout, for convenience, not rigor
14465 my $spacing = (length($section) - 1)/ $num_underscores;
14466 my $temp = $section;
14468 for my $i (1 .. $num_underscores) {
14469 $section .= substr($temp, 0, $spacing, "") . '_';
14473 push @sections, $section;
14477 # Here not a sequence of digits. Change the case of the section
14479 my $switch = int rand(4);
14480 if ($switch == 0) {
14481 push @sections, uc $section;
14483 elsif ($switch == 1) {
14484 push @sections, lc $section;
14486 elsif ($switch == 2) {
14487 push @sections, ucfirst $section;
14490 push @sections, $section;
14494 trace "returning", join "", @sections if main::DEBUG && $to_trace;
14495 return join "", @sections;
14498 sub randomize_loose_name($;$) {
14499 # This used only for making the test script
14502 my $want_error = shift; # if true, make an error
14503 Carp::carp_extra_args(\@_) if main::DEBUG && @_;
14505 $name = randomize_stricter_name($name);
14508 push @parts, $good_loose_seps[rand(@good_loose_seps)];
14510 # Preserve trailing ones for the sake of not stripping the underscore from
14512 for my $part (split /[-\s_]+ (?= . )/, $name) {
14514 if ($want_error and rand() < 0.3) {
14515 push @parts, $bad_loose_seps[rand(@bad_loose_seps)];
14519 push @parts, $good_loose_seps[rand(@good_loose_seps)];
14522 push @parts, $part;
14524 my $new = join("", @parts);
14525 trace "$name => $new" if main::DEBUG && $to_trace;
14528 if (rand() >= 0.5) {
14529 $new .= $bad_loose_seps[rand(@bad_loose_seps)];
14532 $new = $bad_loose_seps[rand(@bad_loose_seps)] . $new;
14538 # Used to make sure don't generate duplicate test cases.
14539 my %test_generated;
14541 sub make_property_test_script() {
14542 # This used only for making the test script
14543 # this written directly -- it's huge.
14545 print "Making test script\n" if $verbosity >= $PROGRESS;
14547 # This uses randomness to test different possibilities without testing all
14548 # possibilities. To ensure repeatability, set the seed to 0. But if
14549 # tests are added, it will perturb all later ones in the .t file
14552 $t_path = 'TestProp.pl' unless defined $t_path; # the traditional name
14554 # Keep going down an order of magnitude
14555 # until find that adding this quantity to
14556 # 1 remains 1; but put an upper limit on
14557 # this so in case this algorithm doesn't
14558 # work properly on some platform, that we
14559 # won't loop forever.
14561 my $min_floating_slop = 1;
14562 while (1+ $min_floating_slop != 1
14565 my $next = $min_floating_slop / 10;
14566 last if $next == 0; # If underflows,
14568 $min_floating_slop = $next;
14571 # It doesn't matter whether the elements of this array contain single lines
14572 # or multiple lines. main::write doesn't count the lines.
14575 foreach my $property (property_ref('*')) {
14576 foreach my $table ($property->tables) {
14578 # Find code points that match, and don't match this table.
14579 my $valid = $table->get_valid_code_point;
14580 my $invalid = $table->get_invalid_code_point;
14581 my $warning = ($table->status eq $DEPRECATED)
14585 # Test each possible combination of the property's aliases with
14586 # the table's. If this gets to be too many, could do what is done
14587 # in the set_final_comment() for Tables
14588 my @table_aliases = $table->aliases;
14589 my @property_aliases = $table->property->aliases;
14591 # Every property can be optionally be prefixed by 'Is_', so test
14592 # that those work, by creating such a new alias for each
14593 # pre-existing one.
14594 push @property_aliases, map { Alias->new("Is_" . $_->name,
14596 $_->make_pod_entry,
14599 } @property_aliases;
14600 my $max = max(scalar @table_aliases, scalar @property_aliases);
14601 for my $j (0 .. $max - 1) {
14603 # The current alias for property is the next one on the list,
14604 # or if beyond the end, start over. Similarly for table
14606 = $property_aliases[$j % @property_aliases]->name;
14608 $property_name = "" if $table->property == $perl;
14609 my $table_alias = $table_aliases[$j % @table_aliases];
14610 my $table_name = $table_alias->name;
14611 my $loose_match = $table_alias->loose_match;
14613 # If the table doesn't have a file, any test for it is
14614 # already guaranteed to be in error
14615 my $already_error = ! $table->file_path;
14617 # Generate error cases for this alias.
14618 push @output, generate_error($property_name,
14622 # If the table is guaranteed to always generate an error,
14623 # quit now without generating success cases.
14624 next if $already_error;
14626 # Now for the success cases.
14628 if ($loose_match) {
14630 # For loose matching, create an extra test case for the
14632 my $standard = standardize($table_name);
14634 # $test_name should be a unique combination for each test
14635 # case; used just to avoid duplicate tests
14636 my $test_name = "$property_name=$standard";
14638 # Don't output duplicate test cases.
14639 if (! exists $test_generated{$test_name}) {
14640 $test_generated{$test_name} = 1;
14641 push @output, generate_tests($property_name,
14648 $random = randomize_loose_name($table_name)
14650 else { # Stricter match
14651 $random = randomize_stricter_name($table_name);
14654 # Now for the main test case for this alias.
14655 my $test_name = "$property_name=$random";
14656 if (! exists $test_generated{$test_name}) {
14657 $test_generated{$test_name} = 1;
14658 push @output, generate_tests($property_name,
14665 # If the name is a rational number, add tests for the
14666 # floating point equivalent.
14667 if ($table_name =~ qr{/}) {
14669 # Calculate the float, and find just the fraction.
14670 my $float = eval $table_name;
14671 my ($whole, $fraction)
14672 = $float =~ / (.*) \. (.*) /x;
14674 # Starting with one digit after the decimal point,
14675 # create a test for each possible precision (number of
14676 # digits past the decimal point) until well beyond the
14677 # native number found on this machine. (If we started
14678 # with 0 digits, it would be an integer, which could
14679 # well match an unrelated table)
14681 for my $i (1 .. $min_floating_slop + 3) {
14682 my $table_name = sprintf("%.*f", $i, $float);
14683 if ($i < $MIN_FRACTION_LENGTH) {
14685 # If the test case has fewer digits than the
14686 # minimum acceptable precision, it shouldn't
14687 # succeed, so we expect an error for it.
14688 # E.g., 2/3 = .7 at one decimal point, and we
14689 # shouldn't say it matches .7. We should make
14690 # it be .667 at least before agreeing that the
14691 # intent was to match 2/3. But at the
14692 # less-than- acceptable level of precision, it
14693 # might actually match an unrelated number.
14694 # So don't generate a test case if this
14695 # conflating is possible. In our example, we
14696 # don't want 2/3 matching 7/10, if there is
14697 # a 7/10 code point.
14699 (keys %nv_floating_to_rational)
14702 if abs($table_name - $existing)
14703 < $MAX_FLOATING_SLOP;
14705 push @output, generate_error($property_name,
14707 1 # 1 => already an error
14712 # Here the number of digits exceeds the
14713 # minimum we think is needed. So generate a
14714 # success test case for it.
14715 push @output, generate_tests($property_name,
14733 (map {"Test_X('$_');\n"} @backslash_X_tests),
14738 # This is a list of the input files and how to handle them. The files are
14739 # processed in their order in this list. Some reordering is possible if
14740 # desired, but the v0 files should be first, and the extracted before the
14741 # others except DAge.txt (as data in an extracted file can be over-ridden by
14742 # the non-extracted. Some other files depend on data derived from an earlier
14743 # file, like UnicodeData requires data from Jamo, and the case changing and
14744 # folding requires data from Unicode. Mostly, it safest to order by first
14745 # version releases in (except the Jamo). DAge.txt is read before the
14746 # extracted ones because of the rarely used feature $compare_versions. In the
14747 # unlikely event that there were ever an extracted file that contained the Age
14748 # property information, it would have to go in front of DAge.
14750 # The version strings allow the program to know whether to expect a file or
14751 # not, but if a file exists in the directory, it will be processed, even if it
14752 # is in a version earlier than expected, so you can copy files from a later
14753 # release into an earlier release's directory.
14754 my @input_file_objects = (
14755 Input_file->new('PropertyAliases.txt', v0,
14756 Handler => \&process_PropertyAliases,
14758 Input_file->new(undef, v0, # No file associated with this
14759 Progress_Message => 'Finishing property setup',
14760 Handler => \&finish_property_setup,
14762 Input_file->new('PropValueAliases.txt', v0,
14763 Handler => \&process_PropValueAliases,
14764 Has_Missings_Defaults => $NOT_IGNORED,
14766 Input_file->new('DAge.txt', v3.2.0,
14767 Has_Missings_Defaults => $NOT_IGNORED,
14770 Input_file->new("${EXTRACTED}DGeneralCategory.txt", v3.1.0,
14771 Property => 'General_Category',
14773 Input_file->new("${EXTRACTED}DCombiningClass.txt", v3.1.0,
14774 Property => 'Canonical_Combining_Class',
14775 Has_Missings_Defaults => $NOT_IGNORED,
14777 Input_file->new("${EXTRACTED}DNumType.txt", v3.1.0,
14778 Property => 'Numeric_Type',
14779 Has_Missings_Defaults => $NOT_IGNORED,
14781 Input_file->new("${EXTRACTED}DEastAsianWidth.txt", v3.1.0,
14782 Property => 'East_Asian_Width',
14783 Has_Missings_Defaults => $NOT_IGNORED,
14785 Input_file->new("${EXTRACTED}DLineBreak.txt", v3.1.0,
14786 Property => 'Line_Break',
14787 Has_Missings_Defaults => $NOT_IGNORED,
14789 Input_file->new("${EXTRACTED}DBidiClass.txt", v3.1.1,
14790 Property => 'Bidi_Class',
14791 Has_Missings_Defaults => $NOT_IGNORED,
14793 Input_file->new("${EXTRACTED}DDecompositionType.txt", v3.1.0,
14794 Property => 'Decomposition_Type',
14795 Has_Missings_Defaults => $NOT_IGNORED,
14797 Input_file->new("${EXTRACTED}DBinaryProperties.txt", v3.1.0),
14798 Input_file->new("${EXTRACTED}DNumValues.txt", v3.1.0,
14799 Property => 'Numeric_Value',
14800 Each_Line_Handler => \&filter_numeric_value_line,
14801 Has_Missings_Defaults => $NOT_IGNORED,
14803 Input_file->new("${EXTRACTED}DJoinGroup.txt", v3.1.0,
14804 Property => 'Joining_Group',
14805 Has_Missings_Defaults => $NOT_IGNORED,
14808 Input_file->new("${EXTRACTED}DJoinType.txt", v3.1.0,
14809 Property => 'Joining_Type',
14810 Has_Missings_Defaults => $NOT_IGNORED,
14812 Input_file->new('Jamo.txt', v2.0.0,
14813 Property => 'Jamo_Short_Name',
14814 Each_Line_Handler => \&filter_jamo_line,
14816 Input_file->new('UnicodeData.txt', v1.1.5,
14817 Pre_Handler => \&setup_UnicodeData,
14819 # We clean up this file for some early versions.
14820 Each_Line_Handler => [ (($v_version lt v2.0.0 )
14822 : ($v_version eq v2.1.5)
14823 ? \&filter_v2_1_5_ucd
14825 # And for 5.14 Perls with 6.0,
14826 # have to also make changes
14827 : ($v_version ge v6.0.0)
14831 # And the main filter
14832 \&filter_UnicodeData_line,
14834 EOF_Handler => \&EOF_UnicodeData,
14836 Input_file->new('ArabicShaping.txt', v2.0.0,
14837 Each_Line_Handler =>
14838 [ ($v_version lt 4.1.0)
14839 ? \&filter_old_style_arabic_shaping
14841 \&filter_arabic_shaping_line,
14843 Has_Missings_Defaults => $NOT_IGNORED,
14845 Input_file->new('Blocks.txt', v2.0.0,
14846 Property => 'Block',
14847 Has_Missings_Defaults => $NOT_IGNORED,
14848 Each_Line_Handler => \&filter_blocks_lines
14850 Input_file->new('PropList.txt', v2.0.0,
14851 Each_Line_Handler => (($v_version lt v3.1.0)
14852 ? \&filter_old_style_proplist
14855 Input_file->new('Unihan.txt', v2.0.0,
14856 Pre_Handler => \&setup_unihan,
14858 Each_Line_Handler => \&filter_unihan_line,
14860 Input_file->new('SpecialCasing.txt', v2.1.8,
14861 Each_Line_Handler => \&filter_special_casing_line,
14862 Pre_Handler => \&setup_special_casing,
14865 'LineBreak.txt', v3.0.0,
14866 Has_Missings_Defaults => $NOT_IGNORED,
14867 Property => 'Line_Break',
14868 # Early versions had problematic syntax
14869 Each_Line_Handler => (($v_version lt v3.1.0)
14870 ? \&filter_early_ea_lb
14873 Input_file->new('EastAsianWidth.txt', v3.0.0,
14874 Property => 'East_Asian_Width',
14875 Has_Missings_Defaults => $NOT_IGNORED,
14876 # Early versions had problematic syntax
14877 Each_Line_Handler => (($v_version lt v3.1.0)
14878 ? \&filter_early_ea_lb
14881 Input_file->new('CompositionExclusions.txt', v3.0.0,
14882 Property => 'Composition_Exclusion',
14884 Input_file->new('BidiMirroring.txt', v3.0.1,
14885 Property => 'Bidi_Mirroring_Glyph',
14887 Input_file->new("NormalizationTest.txt", v3.0.1,
14890 Input_file->new('CaseFolding.txt', v3.0.1,
14891 Pre_Handler => \&setup_case_folding,
14892 Each_Line_Handler =>
14893 [ ($v_version lt v3.1.0)
14894 ? \&filter_old_style_case_folding
14896 \&filter_case_folding_line
14899 Input_file->new('DCoreProperties.txt', v3.1.0,
14900 # 5.2 changed this file
14901 Has_Missings_Defaults => (($v_version ge v5.2.0)
14905 Input_file->new('Scripts.txt', v3.1.0,
14906 Property => 'Script',
14907 Has_Missings_Defaults => $NOT_IGNORED,
14909 Input_file->new('DNormalizationProps.txt', v3.1.0,
14910 Has_Missings_Defaults => $NOT_IGNORED,
14911 Each_Line_Handler => (($v_version lt v4.0.1)
14912 ? \&filter_old_style_normalization_lines
14915 Input_file->new('HangulSyllableType.txt', v4.0.0,
14916 Has_Missings_Defaults => $NOT_IGNORED,
14917 Property => 'Hangul_Syllable_Type'),
14918 Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0,
14919 Property => 'Word_Break',
14920 Has_Missings_Defaults => $NOT_IGNORED,
14922 Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1.0,
14923 Property => 'Grapheme_Cluster_Break',
14924 Has_Missings_Defaults => $NOT_IGNORED,
14926 Input_file->new("$AUXILIARY/GCBTest.txt", v4.1.0,
14927 Handler => \&process_GCB_test,
14929 Input_file->new("$AUXILIARY/LBTest.txt", v4.1.0,
14932 Input_file->new("$AUXILIARY/SBTest.txt", v4.1.0,
14935 Input_file->new("$AUXILIARY/WBTest.txt", v4.1.0,
14938 Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0,
14939 Property => 'Sentence_Break',
14940 Has_Missings_Defaults => $NOT_IGNORED,
14942 Input_file->new('NamedSequences.txt', v4.1.0,
14943 Handler => \&process_NamedSequences
14945 Input_file->new('NameAliases.txt', v5.0.0,
14946 Property => 'Name_Alias',
14947 Pre_Handler => ($v_version ge v6.0.0)
14948 ? \&setup_v6_name_alias
14951 Input_file->new("BidiTest.txt", v5.2.0,
14954 Input_file->new('UnihanIndicesDictionary.txt', v5.2.0,
14956 Each_Line_Handler => \&filter_unihan_line,
14958 Input_file->new('UnihanDataDictionaryLike.txt', v5.2.0,
14960 Each_Line_Handler => \&filter_unihan_line,
14962 Input_file->new('UnihanIRGSources.txt', v5.2.0,
14964 Pre_Handler => \&setup_unihan,
14965 Each_Line_Handler => \&filter_unihan_line,
14967 Input_file->new('UnihanNumericValues.txt', v5.2.0,
14969 Each_Line_Handler => \&filter_unihan_line,
14971 Input_file->new('UnihanOtherMappings.txt', v5.2.0,
14973 Each_Line_Handler => \&filter_unihan_line,
14975 Input_file->new('UnihanRadicalStrokeCounts.txt', v5.2.0,
14977 Each_Line_Handler => \&filter_unihan_line,
14979 Input_file->new('UnihanReadings.txt', v5.2.0,
14981 Each_Line_Handler => \&filter_unihan_line,
14983 Input_file->new('UnihanVariants.txt', v5.2.0,
14985 Each_Line_Handler => \&filter_unihan_line,
14987 Input_file->new('ScriptExtensions.txt', v6.0.0,
14988 Property => 'Script_Extensions',
14989 Pre_Handler => \&setup_script_extensions,
14990 Each_Line_Handler => \&filter_script_extensions_line,
14994 # End of all the preliminaries.
14997 if ($compare_versions) {
14998 Carp::my_carp(<<END
14999 Warning. \$compare_versions is set. Output is not suitable for production
15004 # Put into %potential_files a list of all the files in the directory structure
15005 # that could be inputs to this program, excluding those that we should ignore.
15006 # Use absolute file names because it makes it easier across machine types.
15007 my @ignored_files_full_names = map { File::Spec->rel2abs(
15008 internal_file_to_platform($_))
15009 } keys %ignored_files;
15012 return unless /\.txt$/i; # Some platforms change the name's case
15013 my $full = lc(File::Spec->rel2abs($_));
15014 $potential_files{$full} = 1
15015 if ! grep { $full eq lc($_) } @ignored_files_full_names;
15018 }, File::Spec->curdir());
15020 my @mktables_list_output_files;
15021 my $old_start_time = 0;
15023 if (! -e $file_list) {
15024 print "'$file_list' doesn't exist, so forcing rebuild.\n" if $verbosity >= $VERBOSE;
15025 $write_unchanged_files = 1;
15026 } elsif ($write_unchanged_files) {
15027 print "Not checking file list '$file_list'.\n" if $verbosity >= $VERBOSE;
15030 print "Reading file list '$file_list'\n" if $verbosity >= $VERBOSE;
15032 if (! open $file_handle, "<", $file_list) {
15033 Carp::my_carp("Failed to open '$file_list'; turning on -globlist option instead: $!");
15039 # Read and parse mktables.lst, placing the results from the first part
15040 # into @input, and the second part into @mktables_list_output_files
15041 for my $list ( \@input, \@mktables_list_output_files ) {
15042 while (<$file_handle>) {
15043 s/^ \s+ | \s+ $//xg;
15044 if (/^ \s* \# .* Autogenerated\ starting\ on\ (\d+)/x) {
15045 $old_start_time = $1;
15047 next if /^ \s* (?: \# .* )? $/x;
15049 my ( $file ) = split /\t/;
15050 push @$list, $file;
15052 @$list = uniques(@$list);
15056 # Look through all the input files
15057 foreach my $input (@input) {
15058 next if $input eq 'version'; # Already have checked this.
15060 # Ignore if doesn't exist. The checking about whether we care or
15061 # not is done via the Input_file object.
15062 next if ! file_exists($input);
15064 # The paths are stored with relative names, and with '/' as the
15065 # delimiter; convert to absolute on this machine
15066 my $full = lc(File::Spec->rel2abs(internal_file_to_platform($input)));
15067 $potential_files{$full} = 1
15068 if ! grep { lc($full) eq lc($_) } @ignored_files_full_names;
15072 close $file_handle;
15077 # Here wants to process all .txt files in the directory structure.
15078 # Convert them to full path names. They are stored in the platform's
15081 foreach my $object (@input_file_objects) {
15082 my $file = $object->file;
15083 next unless defined $file;
15084 push @known_files, File::Spec->rel2abs($file);
15087 my @unknown_input_files;
15088 foreach my $file (keys %potential_files) {
15089 next if grep { lc($file) eq lc($_) } @known_files;
15091 # Here, the file is unknown to us. Get relative path name
15092 $file = File::Spec->abs2rel($file);
15093 push @unknown_input_files, $file;
15095 # What will happen is we create a data structure for it, and add it to
15096 # the list of input files to process. First get the subdirectories
15098 my (undef, $directories, undef) = File::Spec->splitpath($file);
15099 $directories =~ s;/$;;; # Can have extraneous trailing '/'
15100 my @directories = File::Spec->splitdir($directories);
15102 # If the file isn't extracted (meaning none of the directories is the
15103 # extracted one), just add it to the end of the list of inputs.
15104 if (! grep { $EXTRACTED_DIR eq $_ } @directories) {
15105 push @input_file_objects, Input_file->new($file, v0);
15109 # Here, the file is extracted. It needs to go ahead of most other
15110 # processing. Search for the first input file that isn't a
15111 # special required property (that is, find one whose first_release
15112 # is non-0), and isn't extracted. Also, the Age property file is
15113 # processed before the extracted ones, just in case
15114 # $compare_versions is set.
15115 for (my $i = 0; $i < @input_file_objects; $i++) {
15116 if ($input_file_objects[$i]->first_released ne v0
15117 && lc($input_file_objects[$i]->file) ne 'dage.txt'
15118 && $input_file_objects[$i]->file !~ /$EXTRACTED_DIR/i)
15120 splice @input_file_objects, $i, 0,
15121 Input_file->new($file, v0);
15128 if (@unknown_input_files) {
15129 print STDERR simple_fold(join_lines(<<END
15131 The following files are unknown as to how to handle. Assuming they are
15132 typical property files. You'll know by later error messages if it worked or
15135 ) . " " . join(", ", @unknown_input_files) . "\n\n");
15137 } # End of looking through directory structure for more .txt files.
15139 # Create the list of input files from the objects we have defined, plus
15141 my @input_files = 'version';
15142 foreach my $object (@input_file_objects) {
15143 my $file = $object->file;
15144 next if ! defined $file; # Not all objects have files
15145 next if $object->optional && ! -e $file;
15146 push @input_files, $file;
15149 if ( $verbosity >= $VERBOSE ) {
15150 print "Expecting ".scalar( @input_files )." input files. ",
15151 "Checking ".scalar( @mktables_list_output_files )." output files.\n";
15154 # We set $most_recent to be the most recently changed input file, including
15155 # this program itself (done much earlier in this file)
15156 foreach my $in (@input_files) {
15157 next unless -e $in; # Keep going even if missing a file
15158 my $mod_time = (stat $in)[9];
15159 $most_recent = $mod_time if $mod_time > $most_recent;
15161 # See that the input files have distinct names, to warn someone if they
15162 # are adding a new one
15164 my ($volume, $directories, $file ) = File::Spec->splitpath($in);
15165 $directories =~ s;/$;;; # Can have extraneous trailing '/'
15166 my @directories = File::Spec->splitdir($directories);
15167 my $base = $file =~ s/\.txt$//;
15168 construct_filename($file, 'mutable', \@directories);
15172 my $rebuild = $write_unchanged_files # Rebuild: if unconditional rebuild
15173 || ! scalar @mktables_list_output_files # or if no outputs known
15174 || $old_start_time < $most_recent; # or out-of-date
15176 # Now we check to see if any output files are older than youngest, if
15177 # they are, we need to continue on, otherwise we can presumably bail.
15179 foreach my $out (@mktables_list_output_files) {
15180 if ( ! file_exists($out)) {
15181 print "'$out' is missing.\n" if $verbosity >= $VERBOSE;
15185 #local $to_trace = 1 if main::DEBUG;
15186 trace $most_recent, (stat $out)[9] if main::DEBUG && $to_trace;
15187 if ( (stat $out)[9] <= $most_recent ) {
15188 #trace "$out: most recent mod time: ", (stat $out)[9], ", youngest: $most_recent\n" if main::DEBUG && $to_trace;
15189 print "'$out' is too old.\n" if $verbosity >= $VERBOSE;
15196 print "Files seem to be ok, not bothering to rebuild. Add '-w' option to force build\n";
15199 print "Must rebuild tables.\n" if $verbosity >= $VERBOSE;
15201 # Ready to do the major processing. First create the perl pseudo-property.
15202 $perl = Property->new('perl', Type => $NON_STRING, Perl_Extension => 1);
15204 # Process each input file
15205 foreach my $file (@input_file_objects) {
15209 # Finish the table generation.
15211 print "Finishing processing Unicode properties\n" if $verbosity >= $PROGRESS;
15214 print "Compiling Perl properties\n" if $verbosity >= $PROGRESS;
15217 print "Creating Perl synonyms\n" if $verbosity >= $PROGRESS;
15218 add_perl_synonyms();
15220 print "Writing tables\n" if $verbosity >= $PROGRESS;
15221 write_all_tables();
15223 # Write mktables.lst
15224 if ( $file_list and $make_list ) {
15226 print "Updating '$file_list'\n" if $verbosity >= $PROGRESS;
15227 foreach my $file (@input_files, @files_actually_output) {
15228 my (undef, $directories, $file) = File::Spec->splitpath($file);
15229 my @directories = File::Spec->splitdir($directories);
15230 $file = join '/', @directories, $file;
15234 if (! open $ofh,">",$file_list) {
15235 Carp::my_carp("Can't write to '$file_list'. Skipping: $!");
15239 my $localtime = localtime $start_time;
15240 print $ofh <<"END";
15242 # $file_list -- File list for $0.
15244 # Autogenerated starting on $start_time ($localtime)
15246 # - First section is input files
15247 # ($0 itself is not listed but is automatically considered an input)
15248 # - Section separator is /^=+\$/
15249 # - Second section is a list of output files.
15250 # - Lines matching /^\\s*#/ are treated as comments
15251 # which along with blank lines are ignored.
15257 print $ofh "$_\n" for sort(@input_files);
15258 print $ofh "\n=================================\n# Output files:\n\n";
15259 print $ofh "$_\n" for sort @files_actually_output;
15260 print $ofh "\n# ",scalar(@input_files)," input files\n",
15261 "# ",scalar(@files_actually_output)+1," output files\n\n",
15264 or Carp::my_carp("Failed to close $ofh: $!");
15266 print "Filelist has ",scalar(@input_files)," input files and ",
15267 scalar(@files_actually_output)+1," output files\n"
15268 if $verbosity >= $VERBOSE;
15272 # Output these warnings unless -q explicitly specified.
15273 if ($verbosity >= $NORMAL_VERBOSITY && ! $debug_skip) {
15274 if (@unhandled_properties) {
15275 print "\nProperties and tables that unexpectedly have no code points\n";
15276 foreach my $property (sort @unhandled_properties) {
15277 print $property, "\n";
15281 if (%potential_files) {
15282 print "\nInput files that are not considered:\n";
15283 foreach my $file (sort keys %potential_files) {
15284 print File::Spec->abs2rel($file), "\n";
15287 print "\nAll done\n" if $verbosity >= $VERBOSE;
15291 # TRAILING CODE IS USED BY make_property_test_script()
15297 # If run outside the normal test suite on an ASCII platform, you can
15298 # just create a latin1_to_native() function that just returns its
15299 # inputs, because that's the only function used from test.pl
15302 # Test qr/\X/ and the \p{} regular expression constructs. This file is
15303 # constructed by mktables from the tables it generates, so if mktables is
15304 # buggy, this won't necessarily catch those bugs. Tests are generated for all
15305 # feasible properties; a few aren't currently feasible; see
15306 # is_code_point_usable() in mktables for details.
15308 # Standard test packages are not used because this manipulates SIG_WARN. It
15309 # exits 0 if every non-skipped test succeeded; -1 if any failed.
15315 my $expected = shift;
15318 my $warning_type = shift; # Type of warning message, like 'deprecated'
15320 my $line = (caller)[2];
15321 $ord = ord(latin1_to_native(chr($ord)));
15323 # Convert the code point to hex form
15324 my $string = sprintf "\"\\x{%04X}\"", $ord;
15328 # The first time through, use all warnings. If the input should generate
15329 # a warning, add another time through with them turned off
15330 push @tests, "no warnings '$warning_type';" if $warning_type;
15332 foreach my $no_warnings (@tests) {
15334 # Store any warning messages instead of outputting them
15335 local $SIG{__WARN__} = $SIG{__WARN__};
15336 my $warning_message;
15337 $SIG{__WARN__} = sub { $warning_message = $_[0] };
15341 # A string eval is needed because of the 'no warnings'.
15342 # Assumes no parens in the regular expression
15343 my $result = eval "$no_warnings
15344 my \$RegObj = qr($regex);
15345 $string =~ \$RegObj ? 1 : 0";
15346 if (not defined $result) {
15347 print "not ok $Tests - couldn't compile /$regex/; line $line: $@\n";
15350 elsif ($result ^ $expected) {
15351 print "not ok $Tests - expected $expected but got $result for $string =~ qr/$regex/; line $line\n";
15354 elsif ($warning_message) {
15355 if (! $warning_type || ($warning_type && $no_warnings)) {
15356 print "not ok $Tests - for qr/$regex/ did not expect warning message '$warning_message'; line $line\n";
15360 print "ok $Tests - expected and got a warning message for qr/$regex/; line $line\n";
15363 elsif ($warning_type && ! $no_warnings) {
15364 print "not ok $Tests - for qr/$regex/ expected a $warning_type warning message, but got none; line $line\n";
15368 print "ok $Tests - got $result for $string =~ qr/$regex/; line $line\n";
15377 if (eval { 'x' =~ qr/$regex/; 1 }) {
15379 my $line = (caller)[2];
15380 print "not ok $Tests - re compiled ok, but expected error for qr/$regex/; line $line: $@\n";
15383 my $line = (caller)[2];
15384 print "ok $Tests - got and expected error for qr/$regex/; line $line\n";
15389 # GCBTest.txt character that separates grapheme clusters
15390 my $breakable_utf8 = my $breakable = chr(0xF7);
15391 utf8::upgrade($breakable_utf8);
15393 # GCBTest.txt character that indicates that the adjoining code points are part
15394 # of the same grapheme cluster
15395 my $nobreak_utf8 = my $nobreak = chr(0xD7);
15396 utf8::upgrade($nobreak_utf8);
15399 # Test qr/\X/ matches. The input is a line from auxiliary/GCBTest.txt
15400 # Each such line is a sequence of code points given by their hex numbers,
15401 # separated by the two characters defined just before this subroutine that
15402 # indicate that either there can or cannot be a break between the adjacent
15403 # code points. If there isn't a break, that means the sequence forms an
15404 # extended grapheme cluster, which means that \X should match the whole
15405 # thing. If there is a break, \X should stop there. This is all
15406 # converted by this routine into a match:
15407 # $string =~ /(\X)/,
15408 # Each \X should match the next cluster; and that is what is checked.
15410 my $template = shift;
15412 my $line = (caller)[2];
15414 # The line contains characters above the ASCII range, but in Latin1. It
15415 # may or may not be in utf8, and if it is, it may or may not know it. So,
15416 # convert these characters to 8 bits. If knows is in utf8, simply
15418 if (utf8::is_utf8($template)) {
15419 utf8::downgrade($template);
15422 # Otherwise, if it is in utf8, but doesn't know it, the next lines
15423 # convert the two problematic characters to their 8-bit equivalents.
15424 # If it isn't in utf8, they don't harm anything.
15426 $template =~ s/$nobreak_utf8/$nobreak/g;
15427 $template =~ s/$breakable_utf8/$breakable/g;
15430 # Get rid of the leading and trailing breakables
15431 $template =~ s/^ \s* $breakable \s* //x;
15432 $template =~ s/ \s* $breakable \s* $ //x;
15434 # And no-breaks become just a space.
15435 $template =~ s/ \s* $nobreak \s* / /xg;
15437 # Split the input into segments that are breakable between them.
15438 my @segments = split /\s*$breakable\s*/, $template;
15441 my $display_string = "";
15443 my @should_display;
15445 # Convert the code point sequence in each segment into a Perl string of
15447 foreach my $segment (@segments) {
15448 my @code_points = split /\s+/, $segment;
15449 my $this_string = "";
15450 my $this_display = "";
15451 foreach my $code_point (@code_points) {
15452 $this_string .= latin1_to_native(chr(hex $code_point));
15453 $this_display .= "\\x{$code_point}";
15456 # The next cluster should match the string in this segment.
15457 push @should_match, $this_string;
15458 push @should_display, $this_display;
15459 $string .= $this_string;
15460 $display_string .= $this_display;
15463 # If a string can be represented in both non-ut8 and utf8, test both cases
15465 for my $to_upgrade (0 .. 1) {
15469 # If already in utf8, would just be a repeat
15470 next UPGRADE if utf8::is_utf8($string);
15472 utf8::upgrade($string);
15475 # Finally, do the \X match.
15476 my @matches = $string =~ /(\X)/g;
15478 # Look through each matched cluster to verify that it matches what we
15480 my $min = (@matches < @should_match) ? @matches : @should_match;
15481 for my $i (0 .. $min - 1) {
15483 if ($matches[$i] eq $should_match[$i]) {
15484 print "ok $Tests - ";
15486 print "In \"$display_string\" =~ /(\\X)/g, \\X #1";
15488 print "And \\X #", $i + 1,
15490 print " correctly matched $should_display[$i]; line $line\n";
15492 $matches[$i] = join("", map { sprintf "\\x{%04X}", $_ }
15493 unpack("U*", $matches[$i]));
15494 print "not ok $Tests - In \"$display_string\" =~ /(\\X)/g, \\X #",
15496 " should have matched $should_display[$i]",
15497 " but instead matched $matches[$i]",
15498 ". Abandoning rest of line $line\n";
15503 # And the number of matches should equal the number of expected matches.
15505 if (@matches == @should_match) {
15506 print "ok $Tests - Nothing was left over; line $line\n";
15508 print "not ok $Tests - There were ", scalar @should_match, " \\X matches expected, but got ", scalar @matches, " instead; line $line\n";
15516 print "1..$Tests\n";
15517 exit($Fails ? -1 : 0);
15520 Error('\p{Script=InGreek}'); # Bug #69018
15521 Test_X("1100 $nobreak 1161"); # Bug #70940
15522 Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
15523 Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
15524 Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726