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