This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Provide $Config{libswanted_uselargefiles} on Win32
[perl5.git] / lib / unicore / mktables
CommitLineData
00a8df5c
YO
1## !!!!!!!!!!!!!! IF YOU MODIFY THIS FILE !!!!!!!!!!!!!!!!!!!!!!!!!
2## Any files created or read by this program should be listed in 'mktables.lst'
3
d73e5302 4#!/usr/bin/perl -w
4392c1cd 5require 5.008; # Needs pack "U". Probably safest to run on 5.8.x
d73e5302 6use strict;
cf25bb62 7use Carp;
d07a55ed 8use File::Spec;
5beb625e 9
cf25bb62
JH
10##
11## mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl)
12## from the Unicode database files (lib/unicore/*.txt).
13##
d2d499f5 14
cb3d361a
JH
15## "Fuzzy" means this section in Unicode TR18:
16##
17## The recommended names for UCD properties and property values are in
18## PropertyAliases.txt [Prop] and PropertyValueAliases.txt
19## [PropValue]. There are both abbreviated names and longer, more
20## descriptive names. It is strongly recommended that both names be
21## recognized, and that loose matching of property names be used,
22## whereby the case distinctions, whitespace, hyphens, and underbar
23## are ignored.
24
8e4b7420
NC
25## Base names already used in lib/gc_sc (for avoiding 8.3 conflicts)
26my %BaseNames;
27
cf25bb62
JH
28##
29## Process any args.
30##
5beb625e
JH
31my $Verbose = 0;
32my $MakeTestScript = 0;
00da7942 33my $AlwaysWrite = 0;
02b1aeec
YO
34my $UseDir = "";
35my $FileList = "$0.lst";
cf25bb62
JH
36
37while (@ARGV)
38{
39 my $arg = shift @ARGV;
40 if ($arg eq '-v') {
41 $Verbose = 1;
42 } elsif ($arg eq '-q') {
43 $Verbose = 0;
00da7942
DM
44 } elsif ($arg eq '-w') {
45 $AlwaysWrite = 1; # update the files even if they havent changed
02b1aeec 46 $FileList = "";
5beb625e
JH
47 } elsif ($arg eq '-maketest') {
48 $MakeTestScript = 1;
02b1aeec
YO
49 } elsif ($arg eq '-C' && defined ($UseDir = shift)) {
50 -d $UseDir or die "Unknown directory '$UseDir'";
51 } elsif ($arg eq '-L' && defined ($FileList = shift)) {
52 -e $FileList or die "Filelist '$FileList' doesn't appear to exist!";
d73e5302 53 } else {
02b1aeec 54 die "usage: $0 [-v|-q|-C dir|-L filelist] [-maketest]\n";
d73e5302
JH
55 }
56}
57
02b1aeec
YO
58if ($FileList) {
59 print "Reading file list '$FileList'\n"
00a8df5c 60 if $Verbose;
02b1aeec
YO
61 open my $fh,"<",$FileList or die "Failed to read '$FileList':$!";
62 my @input;
00a8df5c
YO
63 my @output;
64 for my $list ( \@input, \@output ) {
65 while (<$fh>) {
66 s/^ \s+ | \s+ $//xg;
67 next if /^ \s* (?: \# .* )? $/x;
68 last if /^ =+ $/x;
69 my ( $file ) = split /\t/, $_;
70 push @$list, $file;
71 }
72 my %dupe;
73 @$list = grep !$dupe{ $_ }++, @$list;
74 }
75 close $fh;
02b1aeec 76 die "No input or output files in '$FileList'!"
00a8df5c
YO
77 if !@input or !@output;
78 if ( $Verbose ) {
79 print "Expecting ".scalar( @input )." input files. ",
80 "Checking ".scalar( @output )." output files.\n";
81 }
02b1aeec
YO
82 # we set maxtime to be the youngest input file, including $0 itself.
83 my $maxtime = -M $0; # do this before the chdir!
84 if ($UseDir) {
85 chdir $UseDir or die "Failed to chdir to '$UseDir':$!";
86 }
00a8df5c
YO
87 foreach my $in (@input) {
88 my $time = -M $in;
89 die "Missing input file '$in'" unless defined $time;
90 $maxtime = $time if $maxtime < $time;
91 }
92
02b1aeec
YO
93 # now we check to see if any output files are older than maxtime, if
94 # they are we need to continue on, otherwise we can presumably bail.
00a8df5c
YO
95 my $ok = 1;
96 foreach my $out (@output) {
97 if ( ! -e $out ) {
98 print "'$out' is missing.\n"
99 if $Verbose;
100 $ok = 0;
101 last;
102 }
103 if ( -M $out > $maxtime ) {
104 print "'$out' is too old.\n"
105 if $Verbose;
106 $ok = 0;
107 last;
108 }
109 }
110 if ($ok) {
111 print "Files seem to be ok, not bothering to rebuild.\n";
112 exit(0);
113 }
114 print "Must rebuild tables.\n"
115 if $Verbose;
02b1aeec
YO
116} else {
117 if ($Verbose) {
118 print "Not checking filelist.\n";
119 }
120 if ($UseDir) {
121 chdir $UseDir or die "Failed to chdir to '$UseDir':$!";
122 }
00a8df5c
YO
123}
124
ca12659b
NC
125foreach my $lib ('To', 'lib',
126 map {File::Spec->catdir("lib",$_)}
127 qw(gc_sc dt bc hst ea jt lb nt ccc)) {
128 next if -d $lib;
129 mkdir $lib, 0755 or die "mkdir '$lib': $!";
130}
131
cf25bb62 132my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
d73e5302 133
cf25bb62 134my $HEADER=<<"EOF";
d73e5302 135# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
551b6b6f 136# This file is built by $0 from e.g. UnicodeData.txt.
d73e5302 137# Any changes made here will be lost!
cf25bb62
JH
138
139EOF
140
d07a55ed
NC
141sub force_unlink {
142 my $filename = shift;
143 return unless -e $filename;
144 return if CORE::unlink($filename);
145 # We might need write permission
146 chmod 0777, $filename;
147 CORE::unlink($filename) or die "Couldn't unlink $filename: $!\n";
148}
5beb625e
JH
149
150##
151## Given a filename and a reference to an array of lines,
152## write the lines to the file only if the contents have not changed.
d07a55ed 153## Filename can be given as an arrayref of directory names
5beb625e
JH
154##
155sub WriteIfChanged($\@)
156{
157 my $file = shift;
158 my $lines = shift;
159
d07a55ed
NC
160 $file = File::Spec->catfile(@$file) if ref $file;
161
5beb625e
JH
162 my $TextToWrite = join '', @$lines;
163 if (open IN, $file) {
164 local($/) = undef;
165 my $PreviousText = <IN>;
166 close IN;
167 if ($PreviousText eq $TextToWrite) {
168 print "$file unchanged.\n" if $Verbose;
00da7942 169 return unless $AlwaysWrite;
5beb625e
JH
170 }
171 }
d07a55ed 172 force_unlink ($file);
5beb625e
JH
173 if (not open OUT, ">$file") {
174 die "$0: can't open $file for output: $!\n";
175 }
176 print "$file written.\n" if $Verbose;
177
178 print OUT $TextToWrite;
179 close OUT;
180}
181
cf25bb62
JH
182##
183## The main datastructure (a "Table") represents a set of code points that
184## are part of a particular quality (that are part of \pL, \p{InGreek},
185## etc.). They are kept as ranges of code points (starting and ending of
186## each range).
187##
188## For example, a range ASCII LETTERS would be represented as:
189## [ [ 0x41 => 0x5A, 'UPPER' ],
190## [ 0x61 => 0x7A, 'LOWER, ] ]
191##
192sub RANGE_START() { 0 } ## index into range element
193sub RANGE_END() { 1 } ## index into range element
194sub RANGE_NAME() { 2 } ## index into range element
195
99598c8c 196## Conceptually, these should really be folded into the 'Table' objects
cf25bb62 197my %TableInfo;
99598c8c 198my %TableDesc;
cf25bb62
JH
199my %FuzzyNames;
200my %AliasInfo;
5beb625e 201my %CanonicalToOrig;
cf25bb62
JH
202
203##
99598c8c
JH
204## Turn something like
205## OLD-ITALIC
5beb625e 206## into
99598c8c
JH
207## OldItalic
208##
209sub CanonicalName($)
210{
5beb625e
JH
211 my $orig = shift;
212 my $name = lc $orig;
99598c8c 213 $name =~ s/(?<![a-z])(\w)/\u$1/g;
5beb625e 214 $name =~ s/[-_\s]+//g;
99598c8c 215
5beb625e 216 $CanonicalToOrig{$name} = $orig if not $CanonicalToOrig{$name};
99598c8c
JH
217 return $name;
218}
219
12ac2576
JP
220
221##
222## Store the alias definitions for later use.
223##
224my %PropertyAlias;
225my %PropValueAlias;
226
227my %PA_reverse;
228my %PVA_reverse;
229
230sub Build_Aliases()
231{
232 ##
233 ## Most of the work with aliases doesn't occur here,
7ebf06b3
NC
234 ## but rather in utf8_heavy.pl, which uses PVA.pl,
235
236 # Placate the warnings about used only once. (They are used again, but
237 # via a typeglob lookup)
238 %utf8::PropertyAlias = ();
239 %utf8::PA_reverse = ();
240 %utf8::PropValueAlias = ();
241 %utf8::PVA_reverse = ();
242 %utf8::PVA_abbr_map = ();
12ac2576
JP
243
244 open PA, "< PropertyAliases.txt"
245 or confess "Can't open PropertyAliases.txt: $!";
246 while (<PA>) {
247 s/#.*//;
248 s/\s+$//;
249 next if /^$/;
250
251 my ($abbrev, $name) = split /\s*;\s*/;
252 next if $abbrev eq "n/a";
253 $PropertyAlias{$abbrev} = $name;
254 $PA_reverse{$name} = $abbrev;
7ebf06b3
NC
255
256 # The %utf8::... versions use japhy's code originally from utf8_pva.pl
257 # However, it's moved here so that we build the tables at runtime.
258 tr/ _-//d for $abbrev, $name;
259 $utf8::PropertyAlias{lc $abbrev} = $name;
260 $utf8::PA_reverse{lc $name} = $abbrev;
12ac2576
JP
261 }
262 close PA;
263
264 open PVA, "< PropValueAliases.txt"
265 or confess "Can't open PropValueAliases.txt: $!";
266 while (<PVA>) {
267 s/#.*//;
268 s/\s+$//;
269 next if /^$/;
270
271 my ($prop, @data) = split /\s*;\s*/;
272
273 if ($prop eq 'ccc') {
274 $PropValueAlias{$prop}{$data[1]} = [ @data[0,2] ];
275 $PVA_reverse{$prop}{$data[2]} = [ @data[0,1] ];
276 }
277 else {
278 next if $data[0] eq "n/a";
279 $PropValueAlias{$prop}{$data[0]} = $data[1];
280 $PVA_reverse{$prop}{$data[1]} = $data[0];
281 }
7ebf06b3
NC
282
283 shift @data if $prop eq 'ccc';
284 next if $data[0] eq "n/a";
285
286 $data[1] =~ tr/ _-//d;
287 $utf8::PropValueAlias{$prop}{lc $data[0]} = $data[1];
288 $utf8::PVA_reverse{$prop}{lc $data[1]} = $data[0];
289
290 my $abbr_class = ($prop eq 'gc' or $prop eq 'sc') ? 'gc_sc' : $prop;
291 $utf8::PVA_abbr_map{$abbr_class}{lc $data[0]} = $data[0];
12ac2576
JP
292 }
293 close PVA;
7ebf06b3
NC
294
295 # backwards compatibility for L& -> LC
296 $utf8::PropValueAlias{gc}{'l&'} = $utf8::PropValueAlias{gc}{lc};
297 $utf8::PVA_abbr_map{gc_sc}{'l&'} = $utf8::PVA_abbr_map{gc_sc}{lc};
298
12ac2576
JP
299}
300
301
99598c8c 302##
cf25bb62
JH
303## Associates a property ("Greek", "Lu", "Assigned",...) with a Table.
304##
305## Called like:
99598c8c 306## New_Prop(In => 'Greek', $Table, Desc => 'Greek Block', Fuzzy => 1);
cf25bb62
JH
307##
308## Normally, these parameters are set when the Table is created (when the
309## Table->New constructor is called), but there are times when it needs to
310## be done after-the-fact...)
311##
312sub New_Prop($$$@)
313{
314 my $Type = shift; ## "Is" or "In";
315 my $Name = shift;
316 my $Table = shift;
317
318 ## remaining args are optional key/val
319 my %Args = @_;
320
99598c8c
JH
321 my $Fuzzy = delete $Args{Fuzzy};
322 my $Desc = delete $Args{Desc}; # description
323
5beb625e 324 $Name = CanonicalName($Name) if $Fuzzy;
cf25bb62
JH
325
326 ## sanity check a few args
327 if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) {
328 confess "$0: bad args to New_Prop"
329 }
330
331 if (not $TableInfo{$Type}->{$Name})
332 {
333 $TableInfo{$Type}->{$Name} = $Table;
99598c8c
JH
334 $TableDesc{$Type}->{$Name} = $Desc;
335 if ($Fuzzy) {
cf25bb62
JH
336 $FuzzyNames{$Type}->{$Name} = $Name;
337 }
338 }
d73e5302
JH
339}
340
d73e5302 341
cf25bb62
JH
342##
343## Creates a new Table object.
344##
345## Args are key/value pairs:
99598c8c
JH
346## In => Name -- Name of "In" property to be associated with
347## Is => Name -- Name of "Is" property to be associated with
348## Fuzzy => Boolean -- True if name can be accessed "fuzzily"
349## Desc => String -- Description of the property
cf25bb62
JH
350##
351## No args are required.
352##
353sub Table::New
354{
355 my $class = shift;
356 my %Args = @_;
357
358 my $Table = bless [], $class;
359
99598c8c
JH
360 my $Fuzzy = delete $Args{Fuzzy};
361 my $Desc = delete $Args{Desc};
cf25bb62
JH
362
363 for my $Type ('Is', 'In')
364 {
365 if (my $Name = delete $Args{$Type}) {
99598c8c 366 New_Prop($Type => $Name, $Table, Desc => $Desc, Fuzzy => $Fuzzy);
cf25bb62
JH
367 }
368 }
369
370 ## shouldn't have any left over
371 if (%Args) {
372 confess "$0: bad args to Table->New"
373 }
374
375 return $Table;
d73e5302
JH
376}
377
cf25bb62
JH
378##
379## Returns true if the Table has no code points
380##
381sub Table::IsEmpty
382{
383 my $Table = shift; #self
384 return not @$Table;
d73e5302
JH
385}
386
cf25bb62
JH
387##
388## Returns true if the Table has code points
389##
390sub Table::NotEmpty
391{
392 my $Table = shift; #self
393 return @$Table;
d73e5302
JH
394}
395
cf25bb62
JH
396##
397## Returns the maximum code point currently in the table.
398##
399sub Table::Max
400{
401 my $Table = shift; #self
402 confess "oops" if $Table->IsEmpty; ## must have code points to have a max
403 return $Table->[-1]->[RANGE_END];
404}
d73e5302 405
cf25bb62
JH
406##
407## Replaces the codepoints in the Table with those in the Table given
408## as an arg. (NOTE: this is not a "deep copy").
409##
410sub Table::Replace($$)
411{
412 my $Table = shift; #self
413 my $New = shift;
d73e5302 414
cf25bb62
JH
415 @$Table = @$New;
416}
71d929cb 417
cf25bb62
JH
418##
419## Given a new code point, make the last range of the Table extend to
420## include the new (and all intervening) code points.
421##
422sub Table::Extend
423{
424 my $Table = shift; #self
425 my $codepoint = shift;
d73e5302 426
cf25bb62 427 my $PrevMax = $Table->Max;
e904f995 428
cf25bb62 429 confess "oops ($codepoint <= $PrevMax)" if $codepoint <= $PrevMax;
e904f995 430
cf25bb62
JH
431 $Table->[-1]->[RANGE_END] = $codepoint;
432}
c3a8a2b8 433
cf25bb62
JH
434##
435## Given a code point range start and end (and optional name), blindly
436## append them to the list of ranges for the Table.
437##
438## NOTE: Code points must be added in strictly ascending numeric order.
439##
440sub Table::RawAppendRange
441{
442 my $Table = shift; #self
443 my $start = shift;
444 my $end = shift;
445 my $name = shift;
446 $name = "" if not defined $name; ## warning: $name can be "0"
447
448 push @$Table, [ $start, # RANGE_START
449 $end, # RANGE_END
450 $name ]; # RANGE_NAME
451}
c3a8a2b8 452
cf25bb62
JH
453##
454## Given a code point (and optional name), add it to the Table.
455##
456## NOTE: Code points must be added in strictly ascending numeric order.
457##
458sub Table::Append
459{
460 my $Table = shift; #self
461 my $codepoint = shift;
462 my $name = shift;
463 $name = "" if not defined $name; ## warning: $name can be "0"
464
465 ##
466 ## If we've already got a range working, and this code point is the next
467 ## one in line, and if the name is the same, just extend the current range.
468 ##
469 if ($Table->NotEmpty
470 and
471 $Table->Max == $codepoint - 1
472 and
473 $Table->[-1]->[RANGE_NAME] eq $name)
474 {
475 $Table->Extend($codepoint);
c3a8a2b8 476 }
cf25bb62
JH
477 else
478 {
479 $Table->RawAppendRange($codepoint, $codepoint, $name);
d73e5302 480 }
cf25bb62 481}
d73e5302 482
cf25bb62
JH
483##
484## Given a code point range starting value and ending value (and name),
485## Add the range to teh Table.
486##
487## NOTE: Code points must be added in strictly ascending numeric order.
488##
489sub Table::AppendRange
490{
491 my $Table = shift; #self
492 my $start = shift;
493 my $end = shift;
494 my $name = shift;
495 $name = "" if not defined $name; ## warning: $name can be "0"
496
497 $Table->Append($start, $name);
498 $Table->Extend($end) if $end > $start;
499}
d73e5302 500
cf25bb62
JH
501##
502## Return a new Table that represents all code points not in the Table.
503##
504sub Table::Invert
505{
506 my $Table = shift; #self
507
508 my $New = Table->New();
509 my $max = -1;
510 for my $range (@$Table)
511 {
512 my $start = $range->[RANGE_START];
513 my $end = $range->[RANGE_END];
514 if ($start-1 >= $max+1) {
515 $New->AppendRange($max+1, $start-1, "");
516 }
517 $max = $end;
d73e5302 518 }
cf25bb62
JH
519 if ($max+1 < $LastUnicodeCodepoint) {
520 $New->AppendRange($max+1, $LastUnicodeCodepoint);
d73e5302 521 }
cf25bb62
JH
522 return $New;
523}
d73e5302 524
cf25bb62
JH
525##
526## Merges any number of other tables with $self, returning the new table.
527## (existing tables are not modified)
528##
a3a8c5f0
JH
529##
530## Args may be Tables, or individual code points (as integers).
531##
cf25bb62
JH
532## Can be called as either a constructor or a method.
533##
534sub Table::Merge
535{
536 shift(@_) if not ref $_[0]; ## if called as a constructor, lose the class
537 my @Tables = @_;
538
539 ## Accumulate all records from all tables
540 my @Records;
a3a8c5f0
JH
541 for my $Arg (@Tables)
542 {
543 if (ref $Arg) {
544 ## arg is a table -- get its ranges
545 push @Records, @$Arg;
546 } else {
547 ## arg is a codepoint, make a range
548 push @Records, [ $Arg, $Arg ]
549 }
d73e5302
JH
550 }
551
cf25bb62
JH
552 ## sort by range start, with longer ranges coming first.
553 my ($first, @Rest) = sort {
554 ($a->[RANGE_START] <=> $b->[RANGE_START])
555 or
556 ($b->[RANGE_END] <=> $b->[RANGE_END])
557 } @Records;
558
559 my $New = Table->New();
560
561 ## Ensuring the first range is there makes the subsequent loop easier
562 $New->AppendRange($first->[RANGE_START],
563 $first->[RANGE_END]);
564
565 ## Fold in records so long as they add new information.
566 for my $set (@Rest)
567 {
568 my $start = $set->[RANGE_START];
569 my $end = $set->[RANGE_END];
570 if ($start > $New->Max) {
571 $New->AppendRange($start, $end);
572 } elsif ($end > $New->Max) {
573 $New->Extend($end);
574 }
d73e5302 575 }
d73e5302 576
cf25bb62 577 return $New;
d73e5302
JH
578}
579
cf25bb62
JH
580##
581## Given a filename, write a representation of the Table to a file.
99598c8c 582## May have an optional comment as a 2nd arg.
d07a55ed 583## Filename may actually be an arrayref of directories
cf25bb62
JH
584##
585sub Table::Write
586{
99598c8c 587 my $Table = shift; #self
cf25bb62 588 my $filename = shift;
99598c8c 589 my $comment = shift;
d73e5302 590
5beb625e 591 my @OUT = $HEADER;
99598c8c
JH
592 if (defined $comment) {
593 $comment =~ s/\s+\Z//;
594 $comment =~ s/^/# /gm;
5beb625e 595 push @OUT, "#\n$comment\n#\n";
99598c8c 596 }
5beb625e 597 push @OUT, "return <<'END';\n";
d73e5302 598
cf25bb62
JH
599 for my $set (@$Table)
600 {
601 my $start = $set->[RANGE_START];
602 my $end = $set->[RANGE_END];
603 my $name = $set->[RANGE_NAME];
d73e5302 604
cf25bb62 605 if ($start == $end) {
5beb625e 606 push @OUT, sprintf "%04X\t\t%s\n", $start, $name;
cf25bb62 607 } else {
5beb625e 608 push @OUT, sprintf "%04X\t%04X\t%s\n", $start, $end, $name;
cf25bb62
JH
609 }
610 }
d73e5302 611
5beb625e
JH
612 push @OUT, "END\n";
613
614 WriteIfChanged($filename, @OUT);
615}
616
617## This used only for making the test script.
618## helper function
619sub IsUsable($)
620{
621 my $code = shift;
622 return 0 if $code <= 0x0000; ## don't use null
623 return 0 if $code >= $LastUnicodeCodepoint; ## keep in range
624 return 0 if ($code >= 0xD800 and $code <= 0xDFFF); ## no surrogates
625 return 0 if ($code >= 0xFDD0 and $code <= 0xFDEF); ## utf8.c says no good
626 return 0 if (($code & 0xFFFF) == 0xFFFE); ## utf8.c says no good
627 return 0 if (($code & 0xFFFF) == 0xFFFF); ## utf8.c says no good
628 return 1;
629}
630
631## Return a code point that's part of the table.
632## Returns nothing if the table is empty (or covers only surrogates).
633## This used only for making the test script.
634sub Table::ValidCode
635{
636 my $Table = shift; #self
637 for my $set (@$Table) {
638 return $set->[RANGE_END] if IsUsable($set->[RANGE_END]);
639 }
640 return ();
641}
642
643## Return a code point that's not part of the table
644## Returns nothing if the table covers all code points.
645## This used only for making the test script.
646sub Table::InvalidCode
647{
648 my $Table = shift; #self
649
650 return 0x1234 if $Table->IsEmpty();
651
652 for my $set (@$Table)
653 {
654 if (IsUsable($set->[RANGE_END] + 1))
655 {
656 return $set->[RANGE_END] + 1;
657 }
658
659 if (IsUsable($set->[RANGE_START] - 1))
660 {
661 return $set->[RANGE_START] - 1;
662 }
663 }
664 return ();
cf25bb62
JH
665}
666
667###########################################################################
668###########################################################################
669###########################################################################
670
671
672##
673## Called like:
99598c8c 674## New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 1);
cf25bb62 675##
99598c8c 676## The args must be in that order, although the Fuzzy pair may be omitted.
cf25bb62
JH
677##
678## This creates 'IsAll' as an alias for 'IsAny'
679##
680sub New_Alias($$$@)
681{
682 my $Type = shift; ## "Is" or "In"
683 my $Alias = shift;
99598c8c 684 my $SameAs = shift; # expecting "SameAs" -- just ignored
cf25bb62
JH
685 my $Name = shift;
686
687 ## remaining args are optional key/val
688 my %Args = @_;
689
99598c8c 690 my $Fuzzy = delete $Args{Fuzzy};
cf25bb62
JH
691
692 ## sanity check a few args
693 if (%Args or ($Type ne 'Is' and $Type ne 'In') or $SameAs ne 'SameAs') {
694 confess "$0: bad args to New_Alias"
d73e5302
JH
695 }
696
5beb625e
JH
697 $Alias = CanonicalName($Alias) if $Fuzzy;
698
699 if (not $TableInfo{$Type}->{$Name})
700 {
701 my $CName = CanonicalName($Name);
702 if ($TableInfo{$Type}->{$CName}) {
703 confess "$0: Use canonical form '$CName' instead of '$Name' for alias.";
704 } else {
12ac2576 705 confess "$0: don't have original $Type => $Name to make alias\n";
5beb625e 706 }
cf25bb62
JH
707 }
708 if ($TableInfo{$Alias}) {
709 confess "$0: already have original $Type => $Alias; can't make alias";
d73e5302 710 }
cf25bb62 711 $AliasInfo{$Type}->{$Name} = $Alias;
99598c8c 712 if ($Fuzzy) {
cf25bb62
JH
713 $FuzzyNames{$Type}->{$Alias} = $Name;
714 }
715
d73e5302
JH
716}
717
d73e5302 718
cf25bb62 719## All assigned code points
99598c8c
JH
720my $Assigned = Table->New(Is => 'Assigned',
721 Desc => "All assigned code points",
5beb625e 722 Fuzzy => 0);
d2d499f5 723
cf25bb62
JH
724my $Name = Table->New(); ## all characters, individually by name
725my $General = Table->New(); ## all characters, grouped by category
726my %General;
727my %Cat;
d73e5302 728
7ebf06b3
NC
729## Simple Data::Dumper alike. Good enough for our needs. We can't use the real
730## thing as we have to run under miniperl
731sub simple_dumper {
732 my @lines;
733 my $item;
734 foreach $item (@_) {
735 if (ref $item) {
736 if (ref $item eq 'ARRAY') {
737 push @lines, "[\n", simple_dumper (@$item), "],\n";
738 } elsif (ref $item eq 'HASH') {
739 push @lines, "{\n", simple_dumper (%$item), "},\n";
740 } else {
741 die "Can't cope with $item";
742 }
743 } else {
744 if (defined $item) {
745 my $copy = $item;
746 $copy =~ s/([\'\\])/\\$1/gs;
747 push @lines, "'$copy',\n";
748 } else {
749 push @lines, "undef,\n";
750 }
751 }
752 }
753 @lines;
754}
755
cf25bb62 756##
551b6b6f 757## Process UnicodeData.txt (Categories, etc.)
cf25bb62 758##
44da8cae 759sub UnicodeData_Txt()
cf25bb62
JH
760{
761 my $Bidi = Table->New();
762 my $Deco = Table->New();
763 my $Comb = Table->New();
764 my $Number = Table->New();
12ac2576
JP
765 my $Mirrored = Table->New();#Is => 'Mirrored',
766 #Desc => "Mirrored in bidirectional text",
767 #Fuzzy => 0);
d73e5302 768
cf25bb62
JH
769 my %DC;
770 my %Bidi;
12ac2576
JP
771 my %Number;
772 $DC{can} = Table->New();
773 $DC{com} = Table->New();
cf25bb62
JH
774
775 ## Initialize Perl-generated categories
551b6b6f 776 ## (Categories from UnicodeData.txt are auto-initialized in gencat)
44da8cae
JH
777 $Cat{Alnum} =
778 Table->New(Is => 'Alnum', Desc => "[[:Alnum:]]", Fuzzy => 0);
779 $Cat{Alpha} =
780 Table->New(Is => 'Alpha', Desc => "[[:Alpha:]]", Fuzzy => 0);
781 $Cat{ASCII} =
782 Table->New(Is => 'ASCII', Desc => "[[:ASCII:]]", Fuzzy => 0);
783 $Cat{Blank} =
784 Table->New(Is => 'Blank', Desc => "[[:Blank:]]", Fuzzy => 0);
785 $Cat{Cntrl} =
786 Table->New(Is => 'Cntrl', Desc => "[[:Cntrl:]]", Fuzzy => 0);
787 $Cat{Digit} =
788 Table->New(Is => 'Digit', Desc => "[[:Digit:]]", Fuzzy => 0);
789 $Cat{Graph} =
790 Table->New(Is => 'Graph', Desc => "[[:Graph:]]", Fuzzy => 0);
791 $Cat{Lower} =
792 Table->New(Is => 'Lower', Desc => "[[:Lower:]]", Fuzzy => 0);
793 $Cat{Print} =
794 Table->New(Is => 'Print', Desc => "[[:Print:]]", Fuzzy => 0);
795 $Cat{Punct} =
796 Table->New(Is => 'Punct', Desc => "[[:Punct:]]", Fuzzy => 0);
797 $Cat{Space} =
798 Table->New(Is => 'Space', Desc => "[[:Space:]]", Fuzzy => 0);
799 $Cat{Title} =
800 Table->New(Is => 'Title', Desc => "[[:Title:]]", Fuzzy => 0);
801 $Cat{Upper} =
802 Table->New(Is => 'Upper', Desc => "[[:Upper:]]", Fuzzy => 0);
803 $Cat{XDigit} =
804 Table->New(Is => 'XDigit', Desc => "[[:XDigit:]]", Fuzzy => 0);
805 $Cat{Word} =
806 Table->New(Is => 'Word', Desc => "[[:Word:]]", Fuzzy => 0);
807 $Cat{SpacePerl} =
808 Table->New(Is => 'SpacePerl', Desc => '\s', Fuzzy => 0);
d73e5302 809
cf25bb62
JH
810 my %To;
811 $To{Upper} = Table->New();
812 $To{Lower} = Table->New();
813 $To{Title} = Table->New();
814 $To{Digit} = Table->New();
815
816 sub gencat($$$$)
817 {
818 my ($name, ## Name ("LATIN CAPITAL LETTER A")
819 $cat, ## Category ("Lu", "Zp", "Nd", etc.)
820 $code, ## Code point (as an integer)
821 $op) = @_;
822
823 my $MajorCat = substr($cat, 0, 1); ## L, M, Z, S, etc
824
825 $Assigned->$op($code);
826 $Name->$op($code, $name);
827 $General->$op($code, $cat);
828
829 ## add to the sub category (e.g. "Lu", "Nd", "Cf", ..)
99598c8c
JH
830 $Cat{$cat} ||= Table->New(Is => $cat,
831 Desc => "General Category '$cat'",
832 Fuzzy => 0);
cf25bb62
JH
833 $Cat{$cat}->$op($code);
834
835 ## add to the major category (e.g. "L", "N", "C", ...)
99598c8c
JH
836 $Cat{$MajorCat} ||= Table->New(Is => $MajorCat,
837 Desc => "Major Category '$MajorCat'",
838 Fuzzy => 0);
cf25bb62
JH
839 $Cat{$MajorCat}->$op($code);
840
841 ($General{$name} ||= Table->New)->$op($code, $name);
842
843 # 005F: SPACING UNDERSCORE
d75d706f 844 $Cat{Word}->$op($code) if $cat =~ /^[LMN]|Pc/;
c65e4d19 845 $Cat{Alnum}->$op($code) if $cat =~ /^[LM]|Nd/;
cf25bb62
JH
846 $Cat{Alpha}->$op($code) if $cat =~ /^[LM]/;
847
d75d706f
JH
848 my $isspace =
849 ($cat =~ /Zs|Zl|Zp/ &&
850 $code != 0x200B) # 200B is ZWSP which is for line break control
851 # and therefore it is not part of "space" even while it is "Zs".
cf25bb62
JH
852 || $code == 0x0009 # 0009: HORIZONTAL TAB
853 || $code == 0x000A # 000A: LINE FEED
854 || $code == 0x000B # 000B: VERTICAL TAB
855 || $code == 0x000C # 000C: FORM FEED
e6f58734 856 || $code == 0x000D # 000D: CARRIAGE RETURN
d75d706f
JH
857 || $code == 0x0085 # 0085: NEL
858
859 ;
cf25bb62 860
d75d706f 861 $Cat{Space}->$op($code) if $isspace;
cf25bb62 862
d75d706f
JH
863 $Cat{SpacePerl}->$op($code) if $isspace
864 && $code != 0x000B; # Backward compat.
cf25bb62 865
d75d706f
JH
866 $Cat{Blank}->$op($code) if $isspace
867 && !($code == 0x000A ||
868 $code == 0x000B ||
869 $code == 0x000C ||
870 $code == 0x000D ||
871 $code == 0x0085 ||
872 $cat =~ /^Z[lp]/);
cf25bb62
JH
873
874 $Cat{Digit}->$op($code) if $cat eq "Nd";
875 $Cat{Upper}->$op($code) if $cat eq "Lu";
876 $Cat{Lower}->$op($code) if $cat eq "Ll";
877 $Cat{Title}->$op($code) if $cat eq "Lt";
878 $Cat{ASCII}->$op($code) if $code <= 0x007F;
879 $Cat{Cntrl}->$op($code) if $cat =~ /^C/;
d75d706f
JH
880 my $isgraph = !$isspace && $cat !~ /Cc|Cs|Cn/;
881 $Cat{Graph}->$op($code) if $isgraph;
882 $Cat{Print}->$op($code) if $isgraph || $isspace;
cf25bb62
JH
883 $Cat{Punct}->$op($code) if $cat =~ /^P/;
884
885 $Cat{XDigit}->$op($code) if ($code >= 0x30 && $code <= 0x39) ## 0..9
886 || ($code >= 0x41 && $code <= 0x46) ## A..F
887 || ($code >= 0x61 && $code <= 0x66); ## a..f
888 }
d73e5302 889
cf25bb62 890 ## open ane read file.....
551b6b6f
JH
891 if (not open IN, "UnicodeData.txt") {
892 die "$0: UnicodeData.txt: $!\n";
cf25bb62 893 }
d73e5302 894
a3a8c5f0
JH
895 ##
896 ## For building \p{_CombAbove} and \p{_CanonDCIJ}
897 ##
898 my %_Above_HexCodes; ## Hexcodes for chars with $comb == 230 ("ABOVE")
899
900 my %CodeToDeco; ## Maps code to decomp. list for chars with first
901 ## decomp. char an "i" or "j" (for \p{_CanonDCIJ})
902
903 ## This is filled in as we go....
99598c8c
JH
904 my $CombAbove = Table->New(Is => '_CombAbove',
905 Desc => '(for internal casefolding use)',
906 Fuzzy => 0);
a3a8c5f0 907
cf25bb62
JH
908 while (<IN>)
909 {
910 next unless /^[0-9A-Fa-f]+;/;
911 s/\s+$//;
912
913 my ($hexcode, ## code point in hex (e.g. "0041")
914 $name, ## character name (e.g. "LATIN CAPITAL LETTER A")
915 $cat, ## category (e.g. "Lu")
916 $comb, ## Canonical combining class (e.t. "230")
917 $bidi, ## directional category (e.g. "L")
918 $deco, ## decomposition mapping
919 $decimal, ## decimal digit value
920 $digit, ## digit value
921 $number, ## numeric value
922 $mirrored, ## mirrored
923 $unicode10, ## name in Unicode 1.0
924 $comment, ## comment field
925 $upper, ## uppercase mapping
926 $lower, ## lowercase mapping
927 $title, ## titlecase mapping
928 ) = split(/\s*;\s*/);
929
2eb5892f
JH
930 # Note that in Unicode 3.2 there will be names like
931 # LINE FEED (LF), which probably means that \N{} needs
932 # to cope also with LINE FEED and LF.
933 $name = $unicode10 if $name eq '<control>' && $unicode10 ne '';
934
cf25bb62
JH
935 my $code = hex($hexcode);
936
a3a8c5f0
JH
937 if ($comb and $comb == 230) {
938 $CombAbove->Append($code);
939 $_Above_HexCodes{$hexcode} = 1;
940 }
941
942 ## Used in building \p{_CanonDCIJ}
943 if ($deco and $deco =~ m/^006[9A]\b/) {
944 $CodeToDeco{$code} = $deco;
945 }
946
cf25bb62
JH
947 ##
948 ## There are a few pairs of lines like:
949 ## AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
950 ## D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
951 ## that define ranges.
952 ##
953 if ($name =~ /^<(.+), (First|Last)>$/)
954 {
955 $name = $1;
956 gencat($name, $cat, $code, $2 eq 'First' ? 'Append' : 'Extend');
99598c8c 957 #New_Prop(In => $name, $General{$name}, Fuzzy => 1);
cf25bb62
JH
958 }
959 else
960 {
961 ## normal (single-character) lines
962 gencat($name, $cat, $code, 'Append');
963
964 # No Append() here since since several codes may map into one.
965 $To{Upper}->RawAppendRange($code, $code, $upper) if $upper;
966 $To{Lower}->RawAppendRange($code, $code, $lower) if $lower;
967 $To{Title}->RawAppendRange($code, $code, $title) if $title;
968 $To{Digit}->Append($code, $decimal) if length $decimal;
969
970 $Bidi->Append($code, $bidi);
971 $Comb->Append($code, $comb) if $comb;
972 $Number->Append($code, $number) if length $number;
973
12ac2576
JP
974 length($decimal) and ($Number{De} ||= Table->New())->Append($code)
975 or
976 length($digit) and ($Number{Di} ||= Table->New())->Append($code)
977 or
978 length($number) and ($Number{Nu} ||= Table->New())->Append($code);
979
cf25bb62
JH
980 $Mirrored->Append($code) if $mirrored eq "Y";
981
12ac2576
JP
982 $Bidi{$bidi} ||= Table->New();#Is => "bt/$bidi",
983 #Desc => "Bi-directional category '$bidi'",
984 #Fuzzy => 0);
cf25bb62
JH
985 $Bidi{$bidi}->Append($code);
986
987 if ($deco)
988 {
989 $Deco->Append($code, $deco);
990 if ($deco =~/^<(\w+)>/)
991 {
12ac2576
JP
992 my $dshort = $PVA_reverse{dt}{ucfirst lc $1};
993 $DC{com}->Append($code);
cf25bb62 994
12ac2576
JP
995 $DC{$dshort} ||= Table->New();
996 $DC{$dshort}->Append($code);
cf25bb62
JH
997 }
998 else
999 {
12ac2576 1000 $DC{can}->Append($code);
cf25bb62
JH
1001 }
1002 }
1003 }
1004 }
1005 close IN;
d2d499f5 1006
cf25bb62
JH
1007 ##
1008 ## Tidy up a few special cases....
1009 ##
d73e5302 1010
cf25bb62 1011 $Cat{Cn} = $Assigned->Invert; ## Cn is everything that doesn't exist
99598c8c
JH
1012 New_Prop(Is => 'Cn',
1013 $Cat{Cn},
1014 Desc => "General Category 'Cn' [not functional in Perl]",
1015 Fuzzy => 0);
d73e5302 1016
cf25bb62 1017 ## Unassigned is the same as 'Cn'
5beb625e 1018 New_Alias(Is => 'Unassigned', SameAs => 'Cn', Fuzzy => 0);
d73e5302 1019
cf25bb62 1020 $Cat{C}->Replace($Cat{C}->Merge($Cat{Cn})); ## Now merge in Cn into C
d73e5302 1021
d73e5302 1022
12ac2576
JP
1023 # LC is Ll, Lu, and Lt.
1024 # (used to be L& or L_, but PropValueAliases.txt defines it as LC)
1025 New_Prop(Is => 'LC',
cf25bb62 1026 Table->Merge(@Cat{qw[Ll Lu Lt]}),
99598c8c
JH
1027 Desc => '[\p{Ll}\p{Lu}\p{Lt}]',
1028 Fuzzy => 0);
d73e5302 1029
cf25bb62 1030 ## Any and All are all code points.
99598c8c
JH
1031 my $Any = Table->New(Is => 'Any',
1032 Desc => sprintf("[\\x{0000}-\\x{%X}]",
1033 $LastUnicodeCodepoint),
5beb625e 1034 Fuzzy => 0);
cf25bb62 1035 $Any->RawAppendRange(0, $LastUnicodeCodepoint);
d73e5302 1036
5beb625e 1037 New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 0);
d73e5302 1038
a3a8c5f0
JH
1039 ##
1040 ## Build special properties for Perl's internal case-folding needs:
1041 ## \p{_CaseIgnorable}
1042 ## \p{_CanonDCIJ}
1043 ## \p{_CombAbove}
1044 ## _CombAbove was built above. Others are built here....
1045 ##
1046
1047 ## \p{_CaseIgnorable} is [\p{Mn}\0x00AD\x2010]
1048 New_Prop(Is => '_CaseIgnorable',
1049 Table->Merge($Cat{Mn},
1050 0x00AD, #SOFT HYPHEN
1051 0x2010), #HYPHEN
99598c8c
JH
1052 Desc => '(for internal casefolding use)',
1053 Fuzzy => 0);
a3a8c5f0
JH
1054
1055
1056 ## \p{_CanonDCIJ} is fairly complex...
99598c8c
JH
1057 my $CanonCDIJ = Table->New(Is => '_CanonDCIJ',
1058 Desc => '(for internal casefolding use)',
1059 Fuzzy => 0);
a3a8c5f0
JH
1060 ## It contains the ASCII 'i' and 'j'....
1061 $CanonCDIJ->Append(0x0069); # ASCII ord("i")
1062 $CanonCDIJ->Append(0x006A); # ASCII ord("j")
1063 ## ...and any character with a decomposition that starts with either of
1064 ## those code points, but only if the decomposition does not have any
1065 ## combining character with the "ABOVE" canonical combining class.
1066 for my $code (sort { $a <=> $b} keys %CodeToDeco)
1067 {
1068 ## Need to ensure that all decomposition characters do not have
1069 ## a %HexCodeToComb in %AboveCombClasses.
1070 my $want = 1;
1071 for my $deco_hexcode (split / /, $CodeToDeco{$code})
1072 {
1073 if (exists $_Above_HexCodes{$deco_hexcode}) {
1074 ## one of the decmposition chars has an ABOVE combination
1075 ## class, so we're not interested in this one
1076 $want = 0;
1077 last;
1078 }
1079 }
1080 if ($want) {
1081 $CanonCDIJ->Append($code);
1082 }
1083 }
1084
1085
d73e5302 1086
cf25bb62
JH
1087 ##
1088 ## Now dump the files.
1089 ##
1090 $Name->Write("Name.pl");
12ac2576 1091
7ebf06b3
NC
1092 {
1093 my @PVA = $HEADER;
1094 foreach my $name (qw (PropertyAlias PA_reverse PropValueAlias
1095 PVA_reverse PVA_abbr_map)) {
1096 # Should I really jump through typeglob hoops just to avoid a
1097 # symbolic reference? (%{"utf8::$name})
1098 push @PVA, "\n", "\%utf8::$name = (\n",
1099 simple_dumper (%{$utf8::{$name}}), ");\n";
1100 }
d403599d 1101 push @PVA, "1;\n";
7ebf06b3
NC
1102 WriteIfChanged("PVA.pl", @PVA);
1103 }
1104
12ac2576 1105 # $Bidi->Write("Bidirectional.pl");
12ac2576
JP
1106 for (keys %Bidi) {
1107 $Bidi{$_}->Write(
d07a55ed 1108 ["lib","bc","$_.pl"],
12ac2576
JP
1109 "BidiClass category '$PropValueAlias{bc}{$_}'"
1110 );
1111 }
1112
cf25bb62 1113 $Comb->Write("CombiningClass.pl");
12ac2576
JP
1114 for (keys %{ $PropValueAlias{ccc} }) {
1115 my ($code, $name) = @{ $PropValueAlias{ccc}{$_} };
1116 (my $c = Table->New())->Append($code);
1117 $c->Write(
d07a55ed 1118 ["lib","ccc","$_.pl"],
12ac2576
JP
1119 "CombiningClass category '$name'"
1120 );
1121 }
1122
cf25bb62 1123 $Deco->Write("Decomposition.pl");
12ac2576
JP
1124 for (keys %DC) {
1125 $DC{$_}->Write(
d07a55ed 1126 ["lib","dt","$_.pl"],
12ac2576
JP
1127 "DecompositionType category '$PropValueAlias{dt}{$_}'"
1128 );
1129 }
1130
1131 # $Number->Write("Number.pl");
12ac2576
JP
1132 for (keys %Number) {
1133 $Number{$_}->Write(
d07a55ed 1134 ["lib","nt","$_.pl"],
12ac2576
JP
1135 "NumericType category '$PropValueAlias{nt}{$_}'"
1136 );
1137 }
1138
1139 # $General->Write("Category.pl");
cf25bb62
JH
1140
1141 for my $to (sort keys %To) {
d07a55ed 1142 $To{$to}->Write(["To","$to.pl"]);
d73e5302 1143 }
12ac2576
JP
1144
1145 for (keys %{ $PropValueAlias{gc} }) {
1146 New_Alias(Is => $PropValueAlias{gc}{$_}, SameAs => $_, Fuzzy => 1);
1147 }
d73e5302
JH
1148}
1149
cf25bb62 1150##
551b6b6f 1151## Process LineBreak.txt
cf25bb62 1152##
551b6b6f 1153sub LineBreak_Txt()
cf25bb62 1154{
551b6b6f
JH
1155 if (not open IN, "LineBreak.txt") {
1156 die "$0: LineBreak.txt: $!\n";
cf25bb62 1157 }
d73e5302 1158
cf25bb62
JH
1159 my $Lbrk = Table->New();
1160 my %Lbrk;
d73e5302 1161
cf25bb62
JH
1162 while (<IN>)
1163 {
1164 next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
d73e5302 1165
cf25bb62 1166 my ($first, $last, $lbrk) = (hex($1), hex($2||""), $3);
d73e5302 1167
cf25bb62 1168 $Lbrk->Append($first, $lbrk);
d73e5302 1169
12ac2576 1170 $Lbrk{$lbrk} ||= Table->New();
cf25bb62 1171 $Lbrk{$lbrk}->Append($first);
d73e5302 1172
cf25bb62
JH
1173 if ($last) {
1174 $Lbrk->Extend($last);
1175 $Lbrk{$lbrk}->Extend($last);
d73e5302
JH
1176 }
1177 }
cf25bb62 1178 close IN;
d73e5302 1179
12ac2576
JP
1180 # $Lbrk->Write("Lbrk.pl");
1181
12ac2576
JP
1182
1183 for (keys %Lbrk) {
1184 $Lbrk{$_}->Write(
d07a55ed 1185 ["lib","lb","$_.pl"],
12ac2576
JP
1186 "Linebreak category '$PropValueAlias{lb}{$_}'"
1187 );
1188 }
cf25bb62 1189}
d73e5302 1190
cf25bb62 1191##
551b6b6f 1192## Process ArabicShaping.txt.
cf25bb62 1193##
551b6b6f 1194sub ArabicShaping_txt()
cf25bb62 1195{
551b6b6f
JH
1196 if (not open IN, "ArabicShaping.txt") {
1197 die "$0: ArabicShaping.txt: $!\n";
cf25bb62 1198 }
d73e5302 1199
cf25bb62
JH
1200 my $ArabLink = Table->New();
1201 my $ArabLinkGroup = Table->New();
d73e5302 1202
12ac2576
JP
1203 my %JoinType;
1204
cf25bb62
JH
1205 while (<IN>)
1206 {
1207 next unless /^[0-9A-Fa-f]+;/;
1208 s/\s+$//;
d73e5302 1209
cf25bb62
JH
1210 my ($hexcode, $name, $link, $linkgroup) = split(/\s*;\s*/);
1211 my $code = hex($hexcode);
1212 $ArabLink->Append($code, $link);
1213 $ArabLinkGroup->Append($code, $linkgroup);
12ac2576
JP
1214
1215 $JoinType{$link} ||= Table->New(Is => "JoinType$link");
1216 $JoinType{$link}->Append($code);
d73e5302 1217 }
cf25bb62
JH
1218 close IN;
1219
12ac2576
JP
1220 # $ArabLink->Write("ArabLink.pl");
1221 # $ArabLinkGroup->Write("ArabLnkGrp.pl");
1222
12ac2576
JP
1223
1224 for (keys %JoinType) {
1225 $JoinType{$_}->Write(
d07a55ed 1226 ["lib","jt","$_.pl"],
12ac2576
JP
1227 "JoiningType category '$PropValueAlias{jt}{$_}'"
1228 );
1229 }
1230}
1231
1232##
1233## Process EastAsianWidth.txt.
1234##
1235sub EastAsianWidth_txt()
1236{
1237 if (not open IN, "EastAsianWidth.txt") {
1238 die "$0: EastAsianWidth.txt: $!\n";
1239 }
1240
1241 my %EAW;
1242
1243 while (<IN>)
1244 {
adc6a8bd 1245 next unless /^[0-9A-Fa-f]+(\.\.[0-9A-Fa-f]+)?;/;
12ac2576
JP
1246 s/#.*//;
1247 s/\s+$//;
1248
adc6a8bd 1249 my ($hexcodes, $pv) = split(/\s*;\s*/);
12ac2576 1250 $EAW{$pv} ||= Table->New(Is => "EastAsianWidth$pv");
adc6a8bd
AT
1251 my ($start, $end) = split(/\.\./, $hexcodes);
1252 if (defined $end) {
1253 $EAW{$pv}->AppendRange(hex($start), hex($end));
1254 } else {
1255 $EAW{$pv}->Append(hex($start));
1256 }
12ac2576
JP
1257 }
1258 close IN;
1259
12ac2576
JP
1260
1261 for (keys %EAW) {
1262 $EAW{$_}->Write(
d07a55ed 1263 ["lib","ea","$_.pl"],
12ac2576
JP
1264 "EastAsianWidth category '$PropValueAlias{ea}{$_}'"
1265 );
1266 }
1267}
1268
1269##
1270## Process HangulSyllableType.txt.
1271##
1272sub HangulSyllableType_txt()
1273{
1274 if (not open IN, "HangulSyllableType.txt") {
1275 die "$0: HangulSyllableType.txt: $!\n";
1276 }
1277
1278 my %HST;
1279
1280 while (<IN>)
1281 {
1282 next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
1283 my ($first, $last, $pv) = (hex($1), hex($2||""), $3);
1284
1285 $HST{$pv} ||= Table->New(Is => "HangulSyllableType$pv");
1286 $HST{$pv}->Append($first);
1287
1288 if ($last) { $HST{$pv}->Extend($last) }
1289 }
1290 close IN;
1291
12ac2576
JP
1292 for (keys %HST) {
1293 $HST{$_}->Write(
d07a55ed 1294 ["lib","hst","$_.pl"],
12ac2576
JP
1295 "HangulSyllableType category '$PropValueAlias{hst}{$_}'"
1296 );
1297 }
d73e5302
JH
1298}
1299
cf25bb62
JH
1300##
1301## Process Jamo.txt.
1302##
1303sub Jamo_txt()
1304{
1305 if (not open IN, "Jamo.txt") {
1306 die "$0: Jamo.txt: $!\n";
1307 }
1308 my $Short = Table->New();
d73e5302 1309
cf25bb62
JH
1310 while (<IN>)
1311 {
1312 next unless /^([0-9A-Fa-f]+)\s*;\s*(\w*)/;
1313 my ($code, $short) = (hex($1), $2);
d73e5302 1314
cf25bb62 1315 $Short->Append($code, $short);
d73e5302 1316 }
cf25bb62 1317 close IN;
12ac2576 1318 # $Short->Write("JamoShort.pl");
d73e5302
JH
1319}
1320
cf25bb62
JH
1321##
1322## Process Scripts.txt.
1323##
1324sub Scripts_txt()
1325{
1326 my @ScriptInfo;
d73e5302 1327
cf25bb62
JH
1328 if (not open(IN, "Scripts.txt")) {
1329 die "$0: Scripts.txt: $!\n";
1330 }
1331 while (<IN>) {
1332 next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
d73e5302 1333
cf25bb62
JH
1334 # Wait until all the scripts have been read since
1335 # they are not listed in numeric order.
1336 push @ScriptInfo, [ hex($1), hex($2||""), $3 ];
1337 }
1338 close IN;
d73e5302 1339
cf25bb62 1340 # Now append the scripts properties in their code point order.
d73e5302 1341
cf25bb62
JH
1342 my %Script;
1343 my $Scripts = Table->New();
d73e5302 1344
cf25bb62
JH
1345 for my $script (sort { $a->[0] <=> $b->[0] } @ScriptInfo)
1346 {
1347 my ($first, $last, $name) = @$script;
1348 $Scripts->Append($first, $name);
d73e5302 1349
99598c8c
JH
1350 $Script{$name} ||= Table->New(Is => $name,
1351 Desc => "Script '$name'",
1352 Fuzzy => 1);
cf25bb62 1353 $Script{$name}->Append($first, $name);
d73e5302 1354
cf25bb62
JH
1355 if ($last) {
1356 $Scripts->Extend($last);
1357 $Script{$name}->Extend($last);
1358 }
1359 }
d73e5302 1360
12ac2576 1361 # $Scripts->Write("Scripts.pl");
d73e5302 1362
cf25bb62
JH
1363 ## Common is everything not explicitly assigned to a Script
1364 ##
1365 ## ***shouldn't this be intersected with \p{Assigned}? ******
1366 ##
99598c8c
JH
1367 New_Prop(Is => 'Common',
1368 $Scripts->Invert,
1369 Desc => 'Pseudo-Script of codepoints not in other Unicode scripts',
1370 Fuzzy => 1);
cf25bb62 1371}
d73e5302 1372
cf25bb62
JH
1373##
1374## Given a name like "Close Punctuation", return a regex (that when applied
1375## with /i) matches any valid form of that name (e.g. "ClosePunctuation",
1376## "Close-Punctuation", etc.)
1377##
1378## Accept any space, dash, or underbar where in the official name there is
1379## space or a dash (or underbar, but there never is).
1380##
1381##
1382sub NameToRegex($)
1383{
1384 my $Name = shift;
1385 $Name =~ s/[- _]/(?:[-_]|\\s+)?/g;
1386 return $Name;
1387}
d73e5302 1388
cf25bb62
JH
1389##
1390## Process Blocks.txt.
1391##
1392sub Blocks_txt()
1393{
1394 my $Blocks = Table->New();
1395 my %Blocks;
d73e5302 1396
cf25bb62
JH
1397 if (not open IN, "Blocks.txt") {
1398 die "$0: Blocks.txt: $!\n";
1399 }
d73e5302 1400
cf25bb62
JH
1401 while (<IN>)
1402 {
1403 #next if not /Private Use$/;
1404 next if not /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s*;\s*(.+?)\s*$/;
d73e5302 1405
cf25bb62 1406 my ($first, $last, $name) = (hex($1), hex($2), $3);
d73e5302 1407
cf25bb62 1408 $Blocks->Append($first, $name);
76ccdbe2 1409
99598c8c
JH
1410 $Blocks{$name} ||= Table->New(In => $name,
1411 Desc => "Block '$name'",
1412 Fuzzy => 1);
cf25bb62 1413 $Blocks{$name}->Append($first, $name);
76ccdbe2 1414
cf25bb62
JH
1415 if ($last and $last != $first) {
1416 $Blocks->Extend($last);
1417 $Blocks{$name}->Extend($last);
d73e5302 1418 }
d73e5302 1419 }
cf25bb62
JH
1420 close IN;
1421
12ac2576 1422 # $Blocks->Write("Blocks.pl");
d73e5302
JH
1423}
1424
cf25bb62
JH
1425##
1426## Read in the PropList.txt. It contains extended properties not
551b6b6f 1427## listed in the UnicodeData.txt, such as 'Other_Alphabetic':
cf25bb62
JH
1428## alphabetic but not of the general category L; many modifiers
1429## belong to this extended property category: while they are not
1430## alphabets, they are alphabetic in nature.
1431##
1432sub PropList_txt()
1433{
1434 my @PropInfo;
1435
1436 if (not open IN, "PropList.txt") {
1437 die "$0: PropList.txt: $!\n";
1438 }
d73e5302 1439
cf25bb62
JH
1440 while (<IN>)
1441 {
1442 next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
d73e5302 1443
cf25bb62
JH
1444 # Wait until all the extended properties have been read since
1445 # they are not listed in numeric order.
1446 push @PropInfo, [ hex($1), hex($2||""), $3 ];
1447 }
1448 close IN;
71d929cb 1449
cf25bb62
JH
1450 # Now append the extended properties in their code point order.
1451 my $Props = Table->New();
1452 my %Prop;
71d929cb 1453
cf25bb62
JH
1454 for my $prop (sort { $a->[0] <=> $b->[0] } @PropInfo)
1455 {
1456 my ($first, $last, $name) = @$prop;
1457 $Props->Append($first, $name);
71d929cb 1458
99598c8c
JH
1459 $Prop{$name} ||= Table->New(Is => $name,
1460 Desc => "Extended property '$name'",
1461 Fuzzy => 1);
cf25bb62 1462 $Prop{$name}->Append($first, $name);
71d929cb 1463
cf25bb62
JH
1464 if ($last) {
1465 $Props->Extend($last);
1466 $Prop{$name}->Extend($last);
1467 }
71d929cb 1468 }
d73e5302 1469
12ac2576
JP
1470 for (keys %Prop) {
1471 (my $file = $PA_reverse{$_}) =~ tr/_//d;
8e4b7420
NC
1472 # XXX I'm assuming that the names from %Prop don't suffer 8.3 clashes.
1473 $BaseNames{lc $file}++;
12ac2576 1474 $Prop{$_}->Write(
d07a55ed 1475 ["lib","gc_sc","$file.pl"],
12ac2576
JP
1476 "Binary property '$_'"
1477 );
1478 }
1479
cf25bb62 1480 # Alphabetic is L and Other_Alphabetic.
99598c8c 1481 New_Prop(Is => 'Alphabetic',
cf25bb62 1482 Table->Merge($Cat{L}, $Prop{Other_Alphabetic}),
99598c8c
JH
1483 Desc => '[\p{L}\p{OtherAlphabetic}]', # use canonical names here
1484 Fuzzy => 1);
cf25bb62
JH
1485
1486 # Lowercase is Ll and Other_Lowercase.
99598c8c 1487 New_Prop(Is => 'Lowercase',
cf25bb62 1488 Table->Merge($Cat{Ll}, $Prop{Other_Lowercase}),
99598c8c
JH
1489 Desc => '[\p{Ll}\p{OtherLowercase}]', # use canonical names here
1490 Fuzzy => 1);
cf25bb62
JH
1491
1492 # Uppercase is Lu and Other_Uppercase.
1493 New_Prop(Is => 'Uppercase',
1494 Table->Merge($Cat{Lu}, $Prop{Other_Uppercase}),
99598c8c
JH
1495 Desc => '[\p{Lu}\p{Other_Uppercase}]', # use canonical names here
1496 Fuzzy => 1);
cf25bb62
JH
1497
1498 # Math is Sm and Other_Math.
1499 New_Prop(Is => 'Math',
1500 Table->Merge($Cat{Sm}, $Prop{Other_Math}),
99598c8c
JH
1501 Desc => '[\p{Sm}\p{OtherMath}]', # use canonical names here
1502 Fuzzy => 1);
cf25bb62
JH
1503
1504 # ID_Start is Ll, Lu, Lt, Lm, Lo, and Nl.
1505 New_Prop(Is => 'ID_Start',
1506 Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl]}),
99598c8c
JH
1507 Desc => '[\p{Ll}\p{Lu}\p{Lt}\p{Lm}\p{Lo}\p{Nl}]',
1508 Fuzzy => 1);
cf25bb62
JH
1509
1510 # ID_Continue is ID_Start, Mn, Mc, Nd, and Pc.
1511 New_Prop(Is => 'ID_Continue',
1512 Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl Mn Mc Nd Pc ]}),
99598c8c
JH
1513 Desc => '[\p{ID_Start}\p{Mn}\p{Mc}\p{Nd}\p{Pc}]',
1514 Fuzzy => 1);
d73e5302
JH
1515}
1516
5beb625e
JH
1517
1518##
1519## These are used in:
1520## MakePropTestScript()
1521## WriteAllMappings()
1522## for making the test script.
1523##
1524my %FuzzyNameToTest;
1525my %ExactNameToTest;
1526
1527
1528## This used only for making the test script
1529sub GenTests($$$$)
1530{
1531 my $FH = shift;
1532 my $Prop = shift;
1533 my $MatchCode = shift;
1534 my $FailCode = shift;
1535
1536 if (defined $MatchCode) {
1537 printf $FH qq/Expect(1, "\\x{%04X}", '\\p{$Prop}' );\n/, $MatchCode;
1538 printf $FH qq/Expect(0, "\\x{%04X}", '\\p{^$Prop}');\n/, $MatchCode;
1539 printf $FH qq/Expect(0, "\\x{%04X}", '\\P{$Prop}' );\n/, $MatchCode;
1540 printf $FH qq/Expect(1, "\\x{%04X}", '\\P{^$Prop}');\n/, $MatchCode;
1541 }
1542 if (defined $FailCode) {
1543 printf $FH qq/Expect(0, "\\x{%04X}", '\\p{$Prop}' );\n/, $FailCode;
1544 printf $FH qq/Expect(1, "\\x{%04X}", '\\p{^$Prop}');\n/, $FailCode;
1545 printf $FH qq/Expect(1, "\\x{%04X}", '\\P{$Prop}' );\n/, $FailCode;
1546 printf $FH qq/Expect(0, "\\x{%04X}", '\\P{^$Prop}');\n/, $FailCode;
1547 }
1548}
1549
1550## This used only for making the test script
1551sub ExpectError($$)
1552{
1553 my $FH = shift;
1554 my $prop = shift;
1555
1556 print $FH qq/Error('\\p{$prop}');\n/;
1557 print $FH qq/Error('\\P{$prop}');\n/;
1558}
1559
1560## This used only for making the test script
1561my @GoodSeps = (
1562 " ",
1563 "-",
1564 " \t ",
1565 "",
1566 "",
1567 "_",
1568 );
1569my @BadSeps = (
1570 "--",
1571 "__",
1572 " _",
1573 "/"
1574 );
1575
1576## This used only for making the test script
1577sub RandomlyFuzzifyName($;$)
1578{
1579 my $Name = shift;
1580 my $WantError = shift; ## if true, make an error
1581
1582 my @parts;
1583 for my $part (split /[-\s_]+/, $Name)
1584 {
1585 if (@parts) {
1586 if ($WantError and rand() < 0.3) {
1587 push @parts, $BadSeps[rand(@BadSeps)];
1588 $WantError = 0;
1589 } else {
1590 push @parts, $GoodSeps[rand(@GoodSeps)];
1591 }
1592 }
1593 my $switch = int rand(4);
1594 if ($switch == 0) {
1595 push @parts, uc $part;
1596 } elsif ($switch == 1) {
1597 push @parts, lc $part;
1598 } elsif ($switch == 2) {
1599 push @parts, ucfirst $part;
1600 } else {
1601 push @parts, $part;
1602 }
1603 }
1604 my $new = join('', @parts);
1605
1606 if ($WantError) {
1607 if (rand() >= 0.5) {
1608 $new .= $BadSeps[rand(@BadSeps)];
1609 } else {
1610 $new = $BadSeps[rand(@BadSeps)] . $new;
1611 }
1612 }
1613 return $new;
1614}
1615
1616## This used only for making the test script
1617sub MakePropTestScript()
1618{
1619 ## this written directly -- it's huge.
d07a55ed 1620 force_unlink ("TestProp.pl");
5beb625e
JH
1621 if (not open OUT, ">TestProp.pl") {
1622 die "$0: TestProp.pl: $!\n";
1623 }
1624 print OUT <DATA>;
1625
1626 while (my ($Name, $Table) = each %ExactNameToTest)
1627 {
1628 GenTests(*OUT, $Name, $Table->ValidCode, $Table->InvalidCode);
1629 ExpectError(*OUT, uc $Name) if uc $Name ne $Name;
1630 ExpectError(*OUT, lc $Name) if lc $Name ne $Name;
1631 }
1632
1633
1634 while (my ($Name, $Table) = each %FuzzyNameToTest)
1635 {
1636 my $Orig = $CanonicalToOrig{$Name};
1637 my %Names = (
1638 $Name => 1,
1639 $Orig => 1,
1640 RandomlyFuzzifyName($Orig) => 1
1641 );
1642
1643 for my $N (keys %Names) {
1644 GenTests(*OUT, $N, $Table->ValidCode, $Table->InvalidCode);
1645 }
1646
1647 ExpectError(*OUT, RandomlyFuzzifyName($Orig, 'ERROR'));
1648 }
1649
1650 print OUT "Finished();\n";
1651 close OUT;
1652}
1653
1654
1655##
1656## These are used only in:
1657## RegisterFileForName()
1658## WriteAllMappings()
1659##
1660my %Exact; ## will become %utf8::Exact;
1661my %Canonical; ## will become %utf8::Canonical;
1662my %CaComment; ## Comment for %Canonical entry of same key
1663
1664##
1665## Given info about a name and a datafile that it should be associated with,
1666## register that assocation in %Exact and %Canonical.
1667sub RegisterFileForName($$$$)
1668{
1669 my $Type = shift;
1670 my $Name = shift;
1671 my $IsFuzzy = shift;
1672 my $filename = shift;
1673
1674 ##
1675 ## Now in details for the mapping. $Type eq 'Is' has the
1676 ## Is removed, as it will be removed in utf8_heavy when this
1677 ## data is being checked. In keeps its "In", but a second
1678 ## sans-In record is written if it doesn't conflict with
1679 ## anything already there.
1680 ##
1681 if (not $IsFuzzy)
1682 {
1683 if ($Type eq 'Is') {
1684 die "oops[$Name]" if $Exact{$Name};
1685 $Exact{$Name} = $filename;
1686 } else {
1687 die "oops[$Type$Name]" if $Exact{"$Type$Name"};
1688 $Exact{"$Type$Name"} = $filename;
1689 $Exact{$Name} = $filename if not $Exact{$Name};
1690 }
1691 }
1692 else
1693 {
1694 my $CName = lc $Name;
1695 if ($Type eq 'Is') {
1696 die "oops[$CName]" if $Canonical{$CName};
1697 $Canonical{$CName} = $filename;
1698 $CaComment{$CName} = $Name if $Name =~ tr/A-Z// >= 2;
1699 } else {
1700 die "oops[$Type$CName]" if $Canonical{lc "$Type$CName"};
1701 $Canonical{lc "$Type$CName"} = $filename;
1702 $CaComment{lc "$Type$CName"} = "$Type$Name";
1703 if (not $Canonical{$CName}) {
1704 $Canonical{$CName} = $filename;
1705 $CaComment{$CName} = "$Type$Name";
1706 }
1707 }
1708 }
1709}
1710
cf25bb62
JH
1711##
1712## Writes the info accumulated in
1713##
1714## %TableInfo;
1715## %FuzzyNames;
1716## %AliasInfo;
1717##
1718##
1719sub WriteAllMappings()
1720{
99598c8c
JH
1721 my @MAP;
1722
5beb625e
JH
1723 ## 'Is' *MUST* come first, so its names have precidence over 'In's
1724 for my $Type ('Is', 'In')
1725 {
1726 my %RawNameToFile; ## a per-$Type cache
cf25bb62 1727
5beb625e 1728 for my $Name (sort {length $a <=> length $b} keys %{$TableInfo{$Type}})
cf25bb62 1729 {
5beb625e 1730 ## Note: $Name is already canonical
99598c8c 1731 my $Table = $TableInfo{$Type}->{$Name};
5beb625e 1732 my $IsFuzzy = $FuzzyNames{$Type}->{$Name};
99598c8c
JH
1733
1734 ## Need an 8.3 safe filename (which means "an 8 safe" $filename)
5beb625e 1735 my $filename;
cf25bb62 1736 {
5beb625e 1737 ## 'Is' items lose 'Is' from the basename.
12ac2576
JP
1738 $filename = $Type eq 'Is' ?
1739 ($PVA_reverse{sc}{$Name} || $Name) :
1740 "$Type$Name";
5beb625e
JH
1741
1742 $filename =~ s/[^\w_]+/_/g; # "L&" -> "L_"
1743 substr($filename, 8) = '' if length($filename) > 8;
1744
1745 ##
1746 ## Make sure the basename doesn't conflict with something we
1747 ## might have already written. If we have, say,
1748 ## InGreekExtended1
1749 ## InGreekExtended2
1750 ## they become
1751 ## InGreekE
1752 ## InGreek2
1753 ##
1754 while (my $num = $BaseNames{lc $filename}++)
1755 {
1756 $num++; ## so basenames with numbers start with '2', which
1757 ## just looks more natural.
1758 ## Want to append $num, but if it'll make the basename longer
1759 ## than 8 characters, pre-truncate $filename so that the result
1760 ## is acceptable.
1761 my $delta = length($filename) + length($num) - 8;
1762 if ($delta > 0) {
1763 substr($filename, -$delta) = $num;
1764 } else {
1765 $filename .= $num;
1766 }
99598c8c 1767 }
5beb625e 1768 };
99598c8c
JH
1769
1770 ##
1771 ## Construct a nice comment to add to the file, and build data
1772 ## for the "./Properties" file along the way.
1773 ##
1774 my $Comment;
1775 {
1776 my $Desc = $TableDesc{$Type}->{$Name} || "";
1777 ## get list of names this table is reference by
1778 my @Supported = $Name;
1779 while (my ($Orig, $Alias) = each %{ $AliasInfo{$Type} })
1780 {
1781 if ($Orig eq $Name) {
1782 push @Supported, $Alias;
1783 }
1784 }
1785
1786 my $TypeToShow = $Type eq 'Is' ? "" : $Type;
1787 my $OrigProp;
1788
1789 $Comment = "This file supports:\n";
1790 for my $N (@Supported)
1791 {
1792 my $IsFuzzy = $FuzzyNames{$Type}->{$N};
5beb625e 1793 my $Prop = "\\p{$TypeToShow$Name}";
99598c8c
JH
1794 $OrigProp = $Prop if not $OrigProp; #cache for aliases
1795 if ($IsFuzzy) {
1796 $Comment .= "\t$Prop (and fuzzy permutations)\n";
1797 } else {
1798 $Comment .= "\t$Prop\n";
1799 }
1800 my $MyDesc = ($N eq $Name) ? $Desc : "Alias for $OrigProp ($Desc)";
1801
1802 push @MAP, sprintf("%s %-42s %s\n",
1803 $IsFuzzy ? '*' : ' ', $Prop, $MyDesc);
1804 }
1805 if ($Desc) {
1806 $Comment .= "\nMeaning: $Desc\n";
1807 }
1808
1809 }
cf25bb62
JH
1810 ##
1811 ## Okay, write the file...
1812 ##
d07a55ed 1813 $Table->Write(["lib","gc_sc","$filename.pl"], $Comment);
99598c8c 1814
5beb625e
JH
1815 ## and register it
1816 $RawNameToFile{$Name} = $filename;
1817 RegisterFileForName($Type => $Name, $IsFuzzy, $filename);
cf25bb62 1818
5beb625e
JH
1819 if ($IsFuzzy)
1820 {
1821 my $CName = CanonicalName($Type . '_'. $Name);
1822 $FuzzyNameToTest{$Name} = $Table if !$FuzzyNameToTest{$Name};
1823 $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
1824 } else {
1825 $ExactNameToTest{$Name} = $Table;
cf25bb62
JH
1826 }
1827
cf25bb62
JH
1828 }
1829
5beb625e
JH
1830 ## Register aliase info
1831 for my $Name (sort {length $a <=> length $b} keys %{$AliasInfo{$Type}})
cf25bb62 1832 {
5beb625e
JH
1833 my $Alias = $AliasInfo{$Type}->{$Name};
1834 my $IsFuzzy = $FuzzyNames{$Type}->{$Alias};
1835 my $filename = $RawNameToFile{$Name};
1836 die "oops [$Alias]->[$Name]" if not $filename;
1837 RegisterFileForName($Type => $Alias, $IsFuzzy, $filename);
1838
1839 my $Table = $TableInfo{$Type}->{$Name};
1840 die "oops" if not $Table;
1841 if ($IsFuzzy)
1842 {
1843 my $CName = CanonicalName($Type .'_'. $Alias);
1844 $FuzzyNameToTest{$Alias} = $Table if !$FuzzyNameToTest{$Alias};
1845 $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
1846 } else {
1847 $ExactNameToTest{$Alias} = $Table;
1848 }
cf25bb62 1849 }
5beb625e 1850 }
cf25bb62 1851
5beb625e
JH
1852 ##
1853 ## Write out the property list
1854 ##
1855 {
1856 my @OUT = (
1857 "##\n",
1858 "## This file created by $0\n",
1859 "## List of built-in \\p{...}/\\P{...} properties.\n",
1860 "##\n",
1861 "## '*' means name may be 'fuzzy'\n",
1862 "##\n\n",
1863 sort { substr($a,2) cmp substr($b, 2) } @MAP,
1864 );
1865 WriteIfChanged('Properties', @OUT);
1866 }
cf25bb62 1867
5beb625e
JH
1868 use Text::Tabs (); ## using this makes the files about half the size
1869
1870 ## Write Exact.pl
1871 {
1872 my @OUT = (
1873 $HEADER,
1874 "##\n",
1875 "## Data in this file used by ../utf8_heavy.pl\n",
1876 "##\n\n",
12ac2576 1877 "## Mapping from name to filename in ./lib/gc_sc\n",
5beb625e
JH
1878 "%utf8::Exact = (\n",
1879 );
cf25bb62 1880
12ac2576 1881 $Exact{InGreek} = 'InGreekA'; # this is evil kludge
cf25bb62
JH
1882 for my $Name (sort keys %Exact)
1883 {
1884 my $File = $Exact{$Name};
5beb625e
JH
1885 $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
1886 my $Text = sprintf("%-15s => %s,\n", $Name, qq/'$File'/);
1887 push @OUT, Text::Tabs::unexpand($Text);
cf25bb62 1888 }
5beb625e
JH
1889 push @OUT, ");\n1;\n";
1890
1891 WriteIfChanged('Exact.pl', @OUT);
1892 }
cf25bb62 1893
5beb625e
JH
1894 ## Write Canonical.pl
1895 {
1896 my @OUT = (
1897 $HEADER,
1898 "##\n",
1899 "## Data in this file used by ../utf8_heavy.pl\n",
1900 "##\n\n",
1901 "## Mapping from lc(canonical name) to filename in ./lib\n",
1902 "%utf8::Canonical = (\n",
1903 );
1904 my $Trail = ""; ## used just to keep the spacing pretty
1905 for my $Name (sort keys %Canonical)
cf25bb62 1906 {
5beb625e
JH
1907 my $File = $Canonical{$Name};
1908 if ($CaComment{$Name}) {
1909 push @OUT, "\n" if not $Trail;
1910 push @OUT, " # $CaComment{$Name}\n";
1911 $Trail = "\n";
1912 } else {
1913 $Trail = "";
cf25bb62 1914 }
5beb625e
JH
1915 $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
1916 my $Text = sprintf(" %-41s => %s,\n$Trail", $Name, qq/'$File'/);
1917 push @OUT, Text::Tabs::unexpand($Text);
cf25bb62 1918 }
5beb625e
JH
1919 push @OUT, ");\n1\n";
1920 WriteIfChanged('Canonical.pl', @OUT);
d2d499f5 1921 }
5beb625e
JH
1922
1923 MakePropTestScript() if $MakeTestScript;
d2d499f5
JH
1924}
1925
5beb625e 1926
551b6b6f 1927sub SpecialCasing_txt()
cf25bb62
JH
1928{
1929 #
1930 # Read in the special cases.
1931 #
983ffd37 1932
cf25bb62
JH
1933 my %CaseInfo;
1934
551b6b6f
JH
1935 if (not open IN, "SpecialCasing.txt") {
1936 die "$0: SpecialCasing.txt: $!\n";
cf25bb62
JH
1937 }
1938 while (<IN>) {
1939 next unless /^[0-9A-Fa-f]+;/;
1940 s/\#.*//;
1941 s/\s+$//;
1942
1943 my ($code, $lower, $title, $upper, $condition) = split(/\s*;\s*/);
1944
1945 if ($condition) { # not implemented yet
1946 print "# SKIPPING $_\n" if $Verbose;
1947 next;
1948 }
1949
1950 # Wait until all the special cases have been read since
1951 # they are not listed in numeric order.
1952 my $ix = hex($code);
a6da3000
JH
1953 push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ]
1954 unless $code eq $lower;
1955 push @{$CaseInfo{Title}}, [ $ix, $code, $title ]
1956 unless $code eq $title;
1957 push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ]
1958 unless $code eq $upper;
cf25bb62
JH
1959 }
1960 close IN;
1961
1962 # Now write out the special cases properties in their code point order.
1963 # Prepend them to the To/{Upper,Lower,Title}.pl.
1964
1965 for my $case (qw(Lower Title Upper))
1966 {
1967 my $NormalCase = do "To/$case.pl" || die "$0: $@\n";
cf25bb62 1968
b08cf34e
JH
1969 my @OUT =
1970 (
1971 $HEADER, "\n",
1972 "# The key UTF-8 _bytes_, the value UTF-8 (speed hack)\n",
1973 "%utf8::ToSpec$case =\n(\n",
1974 );
cf25bb62
JH
1975
1976 for my $prop (sort { $a->[0] <=> $b->[0] } @{$CaseInfo{$case}}) {
1977 my ($ix, $code, $to) = @$prop;
1978 my $tostr =
1979 join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
b08cf34e 1980 push @OUT, sprintf qq["%s" => "$tostr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $ix)));
5cb851a6
JH
1981 # Remove any single-character mappings for
1982 # the same character since we are going for
1983 # the special casing rules.
1984 $NormalCase =~ s/^$code\t\t\w+\n//m;
cf25bb62 1985 }
5beb625e
JH
1986 push @OUT, (
1987 ");\n\n",
1988 "return <<'END';\n",
1989 $NormalCase,
1990 "END\n"
1991 );
d07a55ed 1992 WriteIfChanged(["To","$case.pl"], @OUT);
d2d499f5 1993 }
d2d499f5
JH
1994}
1995
c4051cc5
JH
1996#
1997# Read in the case foldings.
1998#
551b6b6f 1999# We will do full case folding, C + F + I (see CaseFolding.txt).
c4051cc5 2000#
551b6b6f 2001sub CaseFolding_txt()
cf25bb62 2002{
551b6b6f
JH
2003 if (not open IN, "CaseFolding.txt") {
2004 die "$0: CaseFolding.txt: $!\n";
cf25bb62 2005 }
c4051cc5 2006
cf25bb62 2007 my $Fold = Table->New();
c4051cc5
JH
2008 my %Fold;
2009
cf25bb62 2010 while (<IN>) {
254ba52a 2011 # Skip status 'S', simple case folding
c4051cc5
JH
2012 next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/;
2013
cf25bb62 2014 my ($code, $status, $fold) = (hex($1), $2, $3);
c4051cc5
JH
2015
2016 if ($status eq 'C') { # Common: one-to-one folding
254ba52a 2017 # No append() since several codes may fold into one.
cf25bb62 2018 $Fold->RawAppendRange($code, $code, $fold);
c4051cc5 2019 } else { # F: full, or I: dotted uppercase I -> dotless lowercase I
cf25bb62 2020 $Fold{$code} = $fold;
c4051cc5
JH
2021 }
2022 }
cf25bb62 2023 close IN;
c4051cc5 2024
cf25bb62 2025 $Fold->Write("To/Fold.pl");
c4051cc5
JH
2026
2027 #
2028 # Prepend the special foldings to the common foldings.
2029 #
c4051cc5 2030 my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n";
5beb625e 2031
b08cf34e
JH
2032 my @OUT =
2033 (
2034 $HEADER, "\n",
2035 "# The ke UTF-8 _bytes_, the value UTF-8 (speed hack)\n",
2036 "%utf8::ToSpecFold =\n(\n",
2037 );
cf25bb62
JH
2038 for my $code (sort { $a <=> $b } keys %Fold) {
2039 my $foldstr =
2040 join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
b08cf34e 2041 push @OUT, sprintf qq["%s" => "$foldstr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $code)));
c4051cc5 2042 }
5beb625e
JH
2043 push @OUT, (
2044 ");\n\n",
2045 "return <<'END';\n",
2046 $CommonFold,
2047 "END\n",
2048 );
2049
d07a55ed 2050 WriteIfChanged(["To","Fold.pl"], @OUT);
c4051cc5
JH
2051}
2052
cf25bb62
JH
2053## Do it....
2054
12ac2576 2055Build_Aliases();
44da8cae 2056UnicodeData_Txt();
cf25bb62
JH
2057PropList_txt();
2058
2059Scripts_txt();
2060Blocks_txt();
2061
5beb625e
JH
2062WriteAllMappings();
2063
551b6b6f
JH
2064LineBreak_Txt();
2065ArabicShaping_txt();
12ac2576
JP
2066EastAsianWidth_txt();
2067HangulSyllableType_txt();
cf25bb62 2068Jamo_txt();
551b6b6f
JH
2069SpecialCasing_txt();
2070CaseFolding_txt();
cf25bb62 2071
5beb625e 2072exit(0);
cf25bb62 2073
5beb625e
JH
2074## TRAILING CODE IS USED BY MakePropTestScript()
2075__DATA__
2076use strict;
2077use warnings;
2078
2079my $Tests = 0;
2080my $Fails = 0;
cf25bb62 2081
5beb625e
JH
2082sub Expect($$$)
2083{
2084 my $Expect = shift;
2085 my $String = shift;
2086 my $Regex = shift;
2087 my $Line = (caller)[2];
2088
2089 $Tests++;
2090 my $RegObj;
2091 my $result = eval {
2092 $RegObj = qr/$Regex/;
2093 $String =~ $RegObj ? 1 : 0
2094 };
2095
2096 if (not defined $result) {
2097 print "couldn't compile /$Regex/ on $0 line $Line: $@\n";
2098 $Fails++;
2099 } elsif ($result ^ $Expect) {
2100 print "bad result (expected $Expect) on $0 line $Line: $@\n";
2101 $Fails++;
2102 }
2103}
d73e5302 2104
5beb625e
JH
2105sub Error($)
2106{
2107 my $Regex = shift;
2108 $Tests++;
2109 if (eval { 'x' =~ qr/$Regex/; 1 }) {
2110 $Fails++;
2111 my $Line = (caller)[2];
2112 print "expected error for /$Regex/ on $0 line $Line: $@\n";
2113 }
2114}
2115
2116sub Finished()
2117{
2118 if ($Fails == 0) {
2119 print "All $Tests tests passed.\n";
2120 exit(0);
2121 } else {
2122 print "$Tests tests, $Fails failed!\n";
2123 exit(-1);
2124 }
2125}