lib/unicore/mktables

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use Carp;
   4 ##
   5 ## mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl)
   6 ## from the Unicode database files (lib/unicore/*.txt).
   7 ##
   8
   9 mkdir("In", 0755);
  10 mkdir("Is", 0755);
  11 mkdir("To", 0755);
  12
  13 ##
  14 ## Process any args.
  15 ##
  16 my $Verbose = 0;
  17
  18 while (@ARGV)
  19 {
  20     my $arg = shift @ARGV;
  21     if ($arg eq '-v') {
  22         $Verbose = 1;
  23     } elsif ($arg eq '-q') {
  24         $Verbose = 0;
  25     } else {
  26         die "usage: $0 [-v|-q]";
  27     }
  28 }
  29
  30 my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
  31
  32 my $now = localtime;
  33 my $HEADER=<<"EOF";
  34 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  35 # This file is built by $0 from e.g. Unicode.txt.
  36 # Any changes made here will be lost!
  37 # Built $now.
  38
  39 EOF
  40
  41 ##
  42 ## The main datastructure (a "Table") represents a set of code points that
  43 ## are part of a particular quality (that are part of \pL, \p{InGreek},
  44 ## etc.). They are kept as ranges of code points (starting and ending of
  45 ## each range).
  46 ##
  47 ## For example, a range ASCII LETTERS would be represented as:
  48 ##   [ [ 0x41 => 0x5A, 'UPPER' ],
  49 ##     [ 0x61 => 0x7A, 'LOWER, ] ]
  50 ##
  51 sub RANGE_START() { 0 } ## index into range element
  52 sub RANGE_END()   { 1 } ## index into range element
  53 sub RANGE_NAME()  { 2 } ## index into range element
  54
  55 my %TableInfo;
  56 my %FuzzyNames;
  57 my %AliasInfo;
  58
  59 ##
  60 ## Associates a property ("Greek", "Lu", "Assigned",...) with a Table.
  61 ##
  62 ## Called like:
  63 ##       New_Prop(In => 'Greek', $Table, AllowFuzzy => 1);
  64 ##
  65 ## Normally, these parameters are set when the Table is created (when the
  66 ## Table->New constructor is called), but there are times when it needs to
  67 ## be done after-the-fact...)
  68 ##
  69 sub New_Prop($$$@)
  70 {
  71     my $Type = shift; ## "Is" or "In";
  72     my $Name = shift;
  73     my $Table = shift;
  74
  75     ## remaining args are optional key/val
  76     my %Args = @_;
  77
  78     my $AllowFuzzy = delete $Args{AllowFuzzy};
  79
  80     ## sanity check a few args
  81     if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) {
  82         confess "$0: bad args to New_Prop"
  83     }
  84
  85     if (not $TableInfo{$Type}->{$Name})
  86     {
  87         $TableInfo{$Type}->{$Name} = $Table;
  88         if ($AllowFuzzy) {
  89             $FuzzyNames{$Type}->{$Name} = $Name;
  90         }
  91     }
  92 }
  93
  94
  95 ##
  96 ## Creates a new Table object.
  97 ##
  98 ## Args are key/value pairs:
  99 ##    In => Name              -- Name of "In" property to be associated with
 100 ##    Is => Name              -- Name of "Is" property to be associated with
 101 ##    AllowFuzzy => Boolean   -- True if name can be accessed "fuzzily"
 102 ##
 103 ## No args are required.
 104 ##
 105 sub Table::New
 106 {
 107     my $class = shift;
 108     my %Args = @_;
 109
 110     my $Table = bless [], $class;
 111
 112     my $AllowFuzzy = delete $Args{AllowFuzzy};
 113
 114     for my $Type ('Is', 'In')
 115     {
 116         if (my $Name = delete $Args{$Type}) {
 117             New_Prop($Type => $Name, $Table, AllowFuzzy => $AllowFuzzy);
 118         }
 119     }
 120
 121     ## shouldn't have any left over
 122     if (%Args) {
 123         confess "$0: bad args to Table->New"
 124     }
 125
 126     return $Table;
 127 }
 128
 129 ##
 130 ## Returns true if the Table has no code points
 131 ##
 132 sub Table::IsEmpty
 133 {
 134     my $Table = shift; #self
 135     return not @$Table;
 136 }
 137
 138 ##
 139 ## Returns true if the Table has code points
 140 ##
 141 sub Table::NotEmpty
 142 {
 143     my $Table = shift; #self
 144     return @$Table;
 145 }
 146
 147 ##
 148 ## Returns the maximum code point currently in the table.
 149 ##
 150 sub Table::Max
 151 {
 152     my $Table = shift; #self
 153     confess "oops" if $Table->IsEmpty; ## must have code points to have a max
 154     return $Table->[-1]->[RANGE_END];
 155 }
 156
 157 ##
 158 ## Replaces the codepoints in the Table with those in the Table given
 159 ## as an arg. (NOTE: this is not a "deep copy").
 160 ##
 161 sub Table::Replace($$)
 162 {
 163     my $Table = shift; #self
 164     my $New   = shift;
 165
 166     @$Table = @$New;
 167 }
 168
 169 ##
 170 ## Given a new code point, make the last range of the Table extend to
 171 ## include the new (and all intervening) code points.
 172 ##
 173 sub Table::Extend
 174 {
 175     my $Table = shift; #self
 176     my $codepoint = shift;
 177
 178     my $PrevMax = $Table->Max;
 179
 180     confess "oops ($codepoint <= $PrevMax)" if $codepoint <= $PrevMax;
 181
 182     $Table->[-1]->[RANGE_END] = $codepoint;
 183 }
 184
 185 ##
 186 ## Given a code point range start and end (and optional name), blindly
 187 ## append them to the list of ranges for the Table.
 188 ##
 189 ## NOTE: Code points must be added in strictly ascending numeric order.
 190 ##
 191 sub Table::RawAppendRange
 192 {
 193     my $Table = shift; #self
 194     my $start = shift;
 195     my $end   = shift;
 196     my $name  = shift;
 197     $name = "" if not defined $name; ## warning: $name can be "0"
 198
 199     push @$Table, [ $start,    # RANGE_START
 200                     $end,      # RANGE_END
 201                     $name   ]; # RANGE_NAME
 202 }
 203
 204 ##
 205 ## Given a code point (and optional name), add it to the Table.
 206 ##
 207 ## NOTE: Code points must be added in strictly ascending numeric order.
 208 ##
 209 sub Table::Append
 210 {
 211     my $Table     = shift; #self
 212     my $codepoint = shift;
 213     my $name      = shift;
 214     $name = "" if not defined $name; ## warning: $name can be "0"
 215
 216     ##
 217     ## If we've already got a range working, and this code point is the next
 218     ## one in line, and if the name is the same, just extend the current range.
 219     ##
 220     if ($Table->NotEmpty
 221         and
 222         $Table->Max == $codepoint - 1
 223         and
 224         $Table->[-1]->[RANGE_NAME] eq $name)
 225     {
 226         $Table->Extend($codepoint);
 227     }
 228     else
 229     {
 230         $Table->RawAppendRange($codepoint, $codepoint, $name);
 231     }
 232 }
 233
 234 ##
 235 ## Given a code point range starting value and ending value (and name),
 236 ## Add the range to teh Table.
 237 ##
 238 ## NOTE: Code points must be added in strictly ascending numeric order.
 239 ##
 240 sub Table::AppendRange
 241 {
 242     my $Table = shift; #self
 243     my $start = shift;
 244     my $end   = shift;
 245     my $name  = shift;
 246     $name = "" if not defined $name; ## warning: $name can be "0"
 247
 248     $Table->Append($start, $name);
 249     $Table->Extend($end) if $end > $start;
 250 }
 251
 252 ##
 253 ## Return a new Table that represents all code points not in the Table.
 254 ##
 255 sub Table::Invert
 256 {
 257     my $Table = shift; #self
 258
 259     my $New = Table->New();
 260     my $max = -1;
 261     for my $range (@$Table)
 262     {
 263         my $start = $range->[RANGE_START];
 264         my $end   = $range->[RANGE_END];
 265         if ($start-1 >= $max+1) {
 266             $New->AppendRange($max+1, $start-1, "");
 267         }
 268         $max = $end;
 269     }
 270     if ($max+1 < $LastUnicodeCodepoint) {
 271         $New->AppendRange($max+1, $LastUnicodeCodepoint);
 272     }
 273     return $New;
 274 }
 275
 276 ##
 277 ## Merges any number of other tables with $self, returning the new table.
 278 ## (existing tables are not modified)
 279 ##
 280 ## Can be called as either a constructor or a method.
 281 ##
 282 sub Table::Merge
 283 {
 284     shift(@_) if not ref $_[0]; ## if called as a constructor, lose the class
 285     my @Tables = @_;
 286
 287     ## Accumulate all records from all tables
 288     my @Records;
 289     for my $Table (@Tables) {
 290         push @Records, @$Table;
 291     }
 292
 293     ## sort by range start, with longer ranges coming first.
 294     my ($first, @Rest) = sort {
 295         ($a->[RANGE_START] <=> $b->[RANGE_START])
 296           or
 297         ($b->[RANGE_END]   <=> $b->[RANGE_END])
 298     } @Records;
 299
 300     my $New = Table->New();
 301
 302     ## Ensuring the first range is there makes the subsequent loop easier
 303     $New->AppendRange($first->[RANGE_START],
 304                       $first->[RANGE_END]);
 305
 306     ## Fold in records so long as they add new information.
 307     for my $set (@Rest)
 308     {
 309         my $start = $set->[RANGE_START];
 310         my $end   = $set->[RANGE_END];
 311         if ($start > $New->Max) {
 312             $New->AppendRange($start, $end);
 313         } elsif ($end > $New->Max) {
 314             $New->Extend($end);
 315         }
 316     }
 317
 318     return $New;
 319 }
 320
 321 ##
 322 ## Given a filename, write a representation of the Table to a file.
 323 ##
 324 sub Table::Write
 325 {
 326     my $Table = shift; #self
 327     my $filename = shift;
 328
 329     print "$filename\n" if $Verbose;
 330
 331     if (not open(OUT, ">$filename")) {
 332         die "$0: can't write $filename: $!\n";
 333     }
 334
 335     print OUT $HEADER;
 336     print OUT "return <<'END';\n";
 337
 338     for my $set (@$Table)
 339     {
 340         my $start = $set->[RANGE_START];
 341         my $end   = $set->[RANGE_END];
 342         my $name  = $set->[RANGE_NAME];
 343
 344         if ($start == $end) {
 345             printf OUT "%04X\t\t%s\n", $start, $name;
 346         } else {
 347             printf OUT "%04X\t%04X\t%s\n", $start, $end, $name;
 348         }
 349     }
 350
 351     print OUT "END\n";
 352     close OUT;
 353 }
 354
 355 ###########################################################################
 356 ###########################################################################
 357 ###########################################################################
 358
 359
 360 ##
 361 ## Called like:
 362 ##     New_Alias(Is => 'All', SameAs => 'Any', AllowFuzzy => 1);
 363 ##
 364 ## The args must be in that order, although the AllowFuzzy pair may be omitted.
 365 ##
 366 ## This creates 'IsAll' as an alias for 'IsAny'
 367 ##
 368 sub New_Alias($$$@)
 369 {
 370     my $Type   = shift; ## "Is" or "In"
 371     my $Alias  = shift;
 372     my $SameAs = shift;
 373     my $Name   = shift;
 374
 375     ## remaining args are optional key/val
 376     my %Args = @_;
 377
 378     my $AllowFuzzy = delete $Args{AllowFuzzy};
 379
 380     ## sanity check a few args
 381     if (%Args or ($Type ne 'Is' and $Type ne 'In') or $SameAs ne 'SameAs') {
 382         confess "$0: bad args to New_Alias"
 383     }
 384
 385     if (not $TableInfo{$Type}->{$Name}) {
 386         confess "$0: don't have orignial $Type => $Name to make alias"
 387     }
 388     if ($TableInfo{$Alias}) {
 389         confess "$0: already have original $Type => $Alias; can't make alias";
 390     }
 391     $AliasInfo{$Type}->{$Name} = $Alias;
 392     if ($AllowFuzzy) {
 393         $FuzzyNames{$Type}->{$Alias} = $Name;
 394     }
 395
 396 }
 397
 398 ##
 399 ## Turn something like
 400 ##    OLD-ITALIC
 401 ## to
 402 ##    Old_Italic
 403 ##
 404 sub CanonicalName($)
 405 {
 406     my $name = lc shift;
 407     $name =~ s/\W+/_/;
 408     $name =~ s/(?<![a-z])(\w)/\u$1/g;
 409     return $name;
 410 }
 411
 412
 413 ## All assigned code points
 414 my $Assigned = Table->New(Is => 'Assigned', AllowFuzzy => 1);
 415
 416 my $Name     = Table->New(); ## all characters, individually by name
 417 my $General  = Table->New(); ## all characters, grouped by category
 418 my %General;
 419 my %Cat;
 420
 421 ##
 422 ## Process Unicode.txt (Categories, etc.)
 423 ##
 424 sub Unicode_Txt()
 425 {
 426     my $Bidi     = Table->New();
 427     my $Deco     = Table->New();
 428     my $Comb     = Table->New();
 429     my $Number   = Table->New();
 430     my $Mirrored = Table->New(Is => 'Mirrored', AllowFuzzy => 0);
 431
 432     my %DC;
 433     my %Bidi;
 434     my %Deco;
 435     $Deco{Canon}   = Table->New(Is => 'Canon',  AllowFuzzy => 0);
 436     $Deco{Compat}  = Table->New(Is => 'Compat', AllowFuzzy => 0);
 437
 438     ## Initialize Perl-generated categories
 439     $Cat{Alnum}     = Table->New(Is => 'Alnum',     AllowFuzzy => 0);
 440     $Cat{Alpha}     = Table->New(Is => 'Alpha',     AllowFuzzy => 0);
 441     $Cat{ASCII}     = Table->New(Is => 'ASCII',     AllowFuzzy => 0);
 442     $Cat{Blank}     = Table->New(Is => 'Blank',     AllowFuzzy => 0);
 443     $Cat{Cntrl}     = Table->New(Is => 'Cntrl',     AllowFuzzy => 0);
 444     $Cat{Digit}     = Table->New(Is => 'Digit',     AllowFuzzy => 0);
 445     $Cat{Graph}     = Table->New(Is => 'Graph',     AllowFuzzy => 0);
 446     $Cat{Lower}     = Table->New(Is => 'Lower',     AllowFuzzy => 0);
 447     $Cat{Print}     = Table->New(Is => 'Print',     AllowFuzzy => 0);
 448     $Cat{Punct}     = Table->New(Is => 'Punct',     AllowFuzzy => 0);
 449     $Cat{SpacePerl} = Table->New(Is => 'SpacePerl', AllowFuzzy => 0);
 450     $Cat{Space}     = Table->New(Is => 'Space',     AllowFuzzy => 0);
 451     $Cat{Title}     = Table->New(Is => 'Title',     AllowFuzzy => 0);
 452     $Cat{Upper}     = Table->New(Is => 'Upper',     AllowFuzzy => 0);
 453     $Cat{Word}      = Table->New(Is => 'Word' ,     AllowFuzzy => 0);
 454     $Cat{XDigit}    = Table->New(Is => 'XDigit',    AllowFuzzy => 0);
 455     ## Categories from Unicode.txt are auto-initialized in gencat()
 456
 457     my %To;
 458     $To{Upper} = Table->New();
 459     $To{Lower} = Table->New();
 460     $To{Title} = Table->New();
 461     $To{Digit} = Table->New();
 462
 463     sub gencat($$$$)
 464     {
 465         my ($name, ## Name ("LATIN CAPITAL LETTER A")
 466             $cat,  ## Category ("Lu", "Zp", "Nd", etc.)
 467             $code, ## Code point (as an integer)
 468             $op) = @_;
 469
 470         my $MajorCat = substr($cat, 0, 1); ## L, M, Z, S, etc
 471
 472         $Assigned->$op($code);
 473         $Name->$op($code, $name);
 474         $General->$op($code, $cat);
 475
 476         ## add to the sub category (e.g. "Lu", "Nd", "Cf", ..)
 477         $Cat{$cat}      ||= Table->New(Is => $cat, AllowFuzzy => 0);
 478         $Cat{$cat}->$op($code);
 479
 480         ## add to the major category (e.g. "L", "N", "C", ...)
 481         $Cat{$MajorCat} ||= Table->New(Is => $MajorCat, AllowFuzzy => 0);
 482         $Cat{$MajorCat}->$op($code);
 483
 484         ($General{$name} ||= Table->New)->$op($code, $name);
 485
 486         # 005F: SPACING UNDERSCORE
 487         $Cat{Word}->$op($code)  if $cat =~ /^[LMN]/ || $code == 0x005F;
 488         $Cat{Alnum}->$op($code) if $cat =~ /^[LMN]/;
 489         $Cat{Alpha}->$op($code) if $cat =~ /^[LM]/;
 490
 491
 492
 493         $Cat{Space}->$op($code) if $cat  =~ /^Z/
 494                                 || $code == 0x0009  # 0009: HORIZONTAL TAB
 495                                 || $code == 0x000A  # 000A: LINE FEED
 496                                 || $code == 0x000B  # 000B: VERTICAL TAB
 497                                 || $code == 0x000C  # 000C: FORM FEED
 498                                 || $code == 0x000D; # 000D: CARRIAGE RETURN
 499
 500
 501         $Cat{SpacePerl}->$op($code) if $cat =~ /^Z/
 502                                     || $code == 0x0009 # 0009: HORIZONTAL TAB
 503                                     || $code == 0x000A # 000A: LINE FEED
 504                                     || $code == 0x000C # 000C: FORM FEED
 505                                     || $code == 0x000D # 000D: CARRIAGE RETURN
 506                                     || $code == 0x0085 # 0085: <NEXT LINE>
 507                                     || $code == 0x2028 # 2028: LINE SEPARATOR
 508                                     || $code == 0x2029;# 2029: PARAGRAPH SEP.
 509
 510         $Cat{Blank}->$op($code) if $cat  =~ /^Z[^lp]$/
 511                                 || $code == 0x0009  # 0009: HORIZONTAL TAB
 512                                 || $code == 0x0020; # 0020: SPACE
 513
 514         $Cat{Digit}->$op($code) if $cat eq "Nd";
 515         $Cat{Upper}->$op($code) if $cat eq "Lu";
 516         $Cat{Lower}->$op($code) if $cat eq "Ll";
 517         $Cat{Title}->$op($code) if $cat eq "Lt";
 518         $Cat{ASCII}->$op($code) if $code <= 0x007F;
 519         $Cat{Cntrl}->$op($code) if $cat =~ /^C/;
 520         $Cat{Graph}->$op($code) if $cat =~ /^([LMNPS]|Co)/;
 521         $Cat{Print}->$op($code) if $cat =~ /^([LMNPS]|Co|Zs)/;
 522         $Cat{Punct}->$op($code) if $cat =~ /^P/;
 523
 524         $Cat{XDigit}->$op($code) if ($code >= 0x30 && $code <= 0x39)  ## 0..9
 525                                  || ($code >= 0x41 && $code <= 0x46)  ## A..F
 526                                  || ($code >= 0x61 && $code <= 0x66); ## a..f
 527     }
 528
 529     ## open ane read file.....
 530     if (not open IN, "Unicode.txt") {
 531         die "$0: Unicode.txt: $!\n";
 532     }
 533
 534     while (<IN>)
 535     {
 536         next unless /^[0-9A-Fa-f]+;/;
 537         s/\s+$//;
 538
 539         my ($hexcode,   ## code point in hex (e.g. "0041")
 540             $name,      ## character name (e.g. "LATIN CAPITAL LETTER A")
 541             $cat,       ## category (e.g. "Lu")
 542             $comb,      ## Canonical combining class (e.t. "230")
 543             $bidi,      ## directional category (e.g. "L")
 544             $deco,      ## decomposition mapping
 545             $decimal,   ## decimal digit value
 546             $digit,     ## digit value
 547             $number,    ## numeric value
 548             $mirrored,  ## mirrored
 549             $unicode10, ## name in Unicode 1.0
 550             $comment,   ## comment field
 551             $upper,     ## uppercase mapping
 552             $lower,     ## lowercase mapping
 553             $title,     ## titlecase mapping
 554               ) = split(/\s*;\s*/);
 555
 556         my $code = hex($hexcode);
 557
 558         ##
 559         ## There are a few pairs of lines like:
 560         ##   AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
 561         ##   D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;;
 562         ## that define ranges.
 563         ##
 564         if ($name =~ /^<(.+), (First|Last)>$/)
 565         {
 566             $name = $1;
 567             gencat($name, $cat, $code, $2 eq 'First' ? 'Append' : 'Extend');
 568             #New_Prop(In => $name, $General{$name}, AllowFuzzy => 1);
 569         }
 570         else
 571         {
 572             ## normal (single-character) lines
 573             gencat($name, $cat, $code, 'Append');
 574
 575             # No Append() here since since several codes may map into one.
 576             $To{Upper}->RawAppendRange($code, $code, $upper) if $upper;
 577             $To{Lower}->RawAppendRange($code, $code, $lower) if $lower;
 578             $To{Title}->RawAppendRange($code, $code, $title) if $title;
 579             $To{Digit}->Append($code, $decimal) if length $decimal;
 580
 581             $Bidi->Append($code, $bidi);
 582             $Comb->Append($code, $comb) if $comb;
 583             $Number->Append($code, $number) if length $number;
 584
 585             $Mirrored->Append($code) if $mirrored eq "Y";
 586
 587             $Bidi{$bidi} ||= Table->New(Is => "Bidi$bidi", AllowFuzzy => 0);
 588             $Bidi{$bidi}->Append($code);
 589
 590             if ($deco)
 591             {
 592                 $Deco->Append($code, $deco);
 593                 if ($deco =~/^<(\w+)>/)
 594                 {
 595                     $Deco{Compat}->Append($code);
 596
 597                     $DC{$1} ||= Table->New(Is => "DC$1", AllowFuzzy => 0);
 598                     $DC{$1}->Append($code);
 599                 }
 600                 else
 601                 {
 602                     $Deco{Canon}->Append($code);
 603                 }
 604             }
 605         }
 606     }
 607     close IN;
 608
 609     ##
 610     ## Tidy up a few special cases....
 611     ##
 612
 613     $Cat{Cn} = $Assigned->Invert; ## Cn is everything that doesn't exist
 614     New_Prop(Is => 'Cn', $Cat{Cn}, AllowFuzzy => 0);
 615
 616     ## Unassigned is the same as 'Cn'
 617     New_Alias(Is => 'Unassigned', SameAs => 'Cn', AllowFuzzy => 1);
 618
 619     $Cat{C}->Replace($Cat{C}->Merge($Cat{Cn}));  ## Now merge in Cn into C
 620
 621
 622     # L& is Ll, Lu, and Lt.
 623     New_Prop(Is => 'L&',
 624              Table->Merge(@Cat{qw[Ll Lu Lt]}),
 625              AllowFuzzy => 0);
 626
 627     ## Any and All are all code points.
 628     my $Any = Table->New(Is => 'Any', AllowFuzzy => 1);
 629     $Any->RawAppendRange(0, $LastUnicodeCodepoint);
 630
 631     New_Alias(Is => 'All', SameAs => 'Any', AllowFuzzy => 1);
 632
 633
 634     ##
 635     ## Now dump the files.
 636     ##
 637     $Name->Write("Name.pl");
 638     $Bidi->Write("Bidirectional.pl");
 639     $Comb->Write("CombiningClass.pl");
 640     $Deco->Write("Decomposition.pl");
 641     $Number->Write("Number.pl");
 642     $General->Write("Category.pl");
 643
 644     for my $to (sort keys %To) {
 645         $To{$to}->Write("To/$to.pl");
 646     }
 647 }
 648
 649 ##
 650 ## Process LineBrk.txt
 651 ##
 652 sub LineBrk_Txt()
 653 {
 654     if (not open IN, "LineBrk.txt") {
 655         die "$0: LineBrk.txt: $!\n";
 656     }
 657
 658     my $Lbrk = Table->New();
 659     my %Lbrk;
 660
 661     while (<IN>)
 662     {
 663         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
 664
 665         my ($first, $last, $lbrk) = (hex($1), hex($2||""), $3);
 666
 667         $Lbrk->Append($first, $lbrk);
 668
 669         $Lbrk{$lbrk} ||= Table->New(Is => "Lbrk$lbrk", AllowFuzzy => 0);
 670         $Lbrk{$lbrk}->Append($first);
 671
 672         if ($last) {
 673             $Lbrk->Extend($last);
 674             $Lbrk{$lbrk}->Extend($last);
 675         }
 676     }
 677     close IN;
 678
 679     $Lbrk->Write("Lbrk.pl");
 680 }
 681
 682 ##
 683 ## Process ArabShap.txt.
 684 ##
 685 sub ArabShap_txt()
 686 {
 687     if (not open IN, "ArabShap.txt") {
 688         die "$0: ArabShap.txt: $!\n";
 689     }
 690
 691     my $ArabLink      = Table->New();
 692     my $ArabLinkGroup = Table->New();
 693
 694     while (<IN>)
 695     {
 696         next unless /^[0-9A-Fa-f]+;/;
 697         s/\s+$//;
 698
 699         my ($hexcode, $name, $link, $linkgroup) = split(/\s*;\s*/);
 700         my $code = hex($hexcode);
 701         $ArabLink->Append($code, $link);
 702         $ArabLinkGroup->Append($code, $linkgroup);
 703     }
 704     close IN;
 705
 706     $ArabLink->Write("ArabLink.pl");
 707     $ArabLinkGroup->Write("ArabLnkGrp.pl");
 708 }
 709
 710 ##
 711 ## Process Jamo.txt.
 712 ##
 713 sub Jamo_txt()
 714 {
 715     if (not open IN, "Jamo.txt") {
 716         die "$0: Jamo.txt: $!\n";
 717     }
 718     my $Short = Table->New();
 719
 720     while (<IN>)
 721     {
 722         next unless /^([0-9A-Fa-f]+)\s*;\s*(\w*)/;
 723         my ($code, $short) = (hex($1), $2);
 724
 725         $Short->Append($code, $short);
 726     }
 727     close IN;
 728     $Short->Write("JamoShort.pl");
 729 }
 730
 731 ##
 732 ## Process Scripts.txt.
 733 ##
 734 sub Scripts_txt()
 735 {
 736     my @ScriptInfo;
 737
 738     if (not open(IN, "Scripts.txt")) {
 739         die "$0: Scripts.txt: $!\n";
 740     }
 741     while (<IN>) {
 742         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
 743
 744         # Wait until all the scripts have been read since
 745         # they are not listed in numeric order.
 746         push @ScriptInfo, [ hex($1), hex($2||""), $3 ];
 747     }
 748     close IN;
 749
 750     # Now append the scripts properties in their code point order.
 751
 752     my %Script;
 753     my $Scripts = Table->New();
 754
 755     for my $script (sort { $a->[0] <=> $b->[0] } @ScriptInfo)
 756     {
 757         my ($first, $last, $name) = @$script;
 758         $Scripts->Append($first, $name);
 759
 760         $Script{$name} ||= Table->New(Is => CanonicalName($name),
 761                                       AllowFuzzy => 1);
 762         $Script{$name}->Append($first, $name);
 763
 764         if ($last) {
 765             $Scripts->Extend($last);
 766             $Script{$name}->Extend($last);
 767         }
 768     }
 769
 770     $Scripts->Write("Scripts.pl");
 771
 772     ## Common is everything not explicitly assigned to a Script
 773     ##
 774     ##    ***shouldn't this be intersected with \p{Assigned}? ******
 775     ##
 776     New_Prop(Is => 'Common', $Scripts->Invert, AllowFuzzy => 1);
 777 }
 778
 779 ##
 780 ## Given a name like "Close Punctuation", return a regex (that when applied
 781 ## with /i) matches any valid form of that name (e.g. "ClosePunctuation",
 782 ## "Close-Punctuation", etc.)
 783 ##
 784 ## Accept any space, dash, or underbar where in the official name there is
 785 ## space or a dash (or underbar, but there never is).
 786 ##
 787 ##
 788 sub NameToRegex($)
 789 {
 790     my $Name = shift;
 791     $Name =~ s/[- _]/(?:[-_]|\\s+)?/g;
 792     return $Name;
 793 }
 794
 795 ##
 796 ## Process Blocks.txt.
 797 ##
 798 sub Blocks_txt()
 799 {
 800     my $Blocks = Table->New();
 801     my %Blocks;
 802
 803     if (not open IN, "Blocks.txt") {
 804         die "$0: Blocks.txt: $!\n";
 805     }
 806
 807     while (<IN>)
 808     {
 809         #next if not /Private Use$/;
 810         next if not /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s*;\s*(.+?)\s*$/;
 811
 812         my ($first, $last, $name) = (hex($1), hex($2), $3);
 813
 814         $Blocks->Append($first, $name);
 815
 816         $Blocks{$name} ||= Table->New(In=>CanonicalName($name), AllowFuzzy=>1);
 817         $Blocks{$name}->Append($first, $name);
 818
 819         if ($last and $last != $first) {
 820             $Blocks->Extend($last);
 821             $Blocks{$name}->Extend($last);
 822         }
 823     }
 824     close IN;
 825
 826     $Blocks->Write("Blocks.pl");
 827 }
 828
 829 ##
 830 ## Read in the PropList.txt.  It contains extended properties not
 831 ## listed in the Unicode.txt, such as 'Other_Alphabetic':
 832 ## alphabetic but not of the general category L; many modifiers
 833 ## belong to this extended property category: while they are not
 834 ## alphabets, they are alphabetic in nature.
 835 ##
 836 sub PropList_txt()
 837 {
 838     my @PropInfo;
 839
 840     if (not open IN, "PropList.txt") {
 841         die "$0: PropList.txt: $!\n";
 842     }
 843
 844     while (<IN>)
 845     {
 846         next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;
 847
 848         # Wait until all the extended properties have been read since
 849         # they are not listed in numeric order.
 850         push @PropInfo, [ hex($1), hex($2||""), $3 ];
 851     }
 852     close IN;
 853
 854     # Now append the extended properties in their code point order.
 855     my $Props = Table->New();
 856     my %Prop;
 857
 858     for my $prop (sort { $a->[0] <=> $b->[0] } @PropInfo)
 859     {
 860         my ($first, $last, $name) = @$prop;
 861         $Props->Append($first, $name);
 862
 863         $Prop{$name} ||= Table->New(Is => $name, AllowFuzzy => 1);
 864         $Prop{$name}->Append($first, $name);
 865
 866         if ($last) {
 867             $Props->Extend($last);
 868             $Prop{$name}->Extend($last);
 869         }
 870     }
 871
 872     # Alphabetic is L and Other_Alphabetic.
 873     New_Prop(Is => 'Alphabetic',
 874              Table->Merge($Cat{L}, $Prop{Other_Alphabetic}),
 875              AllowFuzzy => 1);
 876
 877     # Lowercase is Ll and Other_Lowercase.
 878     New_Prop(Is => 'Lowercase',
 879              Table->Merge($Cat{Ll}, $Prop{Other_Lowercase}),
 880              AllowFuzzy => 1);
 881
 882     # Uppercase is Lu and Other_Uppercase.
 883     New_Prop(Is => 'Uppercase',
 884              Table->Merge($Cat{Lu}, $Prop{Other_Uppercase}),
 885              AllowFuzzy => 1);
 886
 887     # Math is Sm and Other_Math.
 888     New_Prop(Is => 'Math',
 889              Table->Merge($Cat{Sm}, $Prop{Other_Math}),
 890              AllowFuzzy => 1);
 891
 892     # ID_Start is Ll, Lu, Lt, Lm, Lo, and Nl.
 893     New_Prop(Is => 'ID_Start',
 894              Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl]}),
 895              AllowFuzzy => 1);
 896
 897     # ID_Continue is ID_Start, Mn, Mc, Nd, and Pc.
 898     New_Prop(Is => 'ID_Continue',
 899              Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl Mn Mc Nd Pc ]}),
 900              AllowFuzzy => 1);
 901 }
 902
 903 sub Make_GC_Aliases()
 904 {
 905     ##
 906     ## The mapping from General Category long forms to short forms is
 907     ## currently hardwired here since no simple data file in the UCD
 908     ## seems to do that.  Unicode 3.2 will assumedly correct this.
 909     ##
 910     my %Is = (
 911         'Letter'                        =>      'L',
 912         'Uppercase_Letter'              =>      'Lu',
 913         'Lowercase_Letter'              =>      'Ll',
 914         'Titlecase_Letter'              =>      'Lt',
 915         'Modifier_Letter'               =>      'Lm',
 916         'Other_Letter'                  =>      'Lo',
 917
 918         'Mark'                          =>      'M',
 919         'Non_Spacing_Mark'              =>      'Mn',
 920         'Spacing_Mark'                  =>      'Mc',
 921         'Enclosing_Mark'                =>      'Me',
 922
 923         'Separator'                     =>      'Z',
 924         'Space_Separator'               =>      'Zs',
 925         'Line_Separator'                =>      'Zl',
 926         'Paragraph_Separator'           =>      'Zp',
 927
 928         'Number'                        =>      'N',
 929         'Decimal_Number'                =>      'Nd',
 930         'Letter_Number'                 =>      'Nl',
 931         'Other_Number'                  =>      'No',
 932
 933         'Punctuation'                   =>      'P',
 934         'Connector_Punctuation'         =>      'Pc',
 935         'Dash_Punctuation'              =>      'Pd',
 936         'Open_Punctuation'              =>      'Ps',
 937         'Close_Punctuation'             =>      'Pe',
 938         'Initial_Punctuation'           =>      'Pi',
 939         'Final_Punctuation'             =>      'Pf',
 940         'Other_Punctuation'             =>      'Po',
 941
 942         'Symbol'                        =>      'S',
 943         'Math_Symbol'                   =>      'Sm',
 944         'Currency_Symbol'               =>      'Sc',
 945         'Modifier_Symbol'               =>      'Sk',
 946         'Other_Symbol'                  =>      'So',
 947
 948         'Other'                         =>      'C',
 949         'Control'                       =>      'Cc',
 950         'Format'                        =>      'Cf',
 951         'Surrogate'                     =>      'Cs',
 952         'Private Use'                   =>      'Co',
 953         'Unassigned'                    =>      'Cn',
 954     );
 955
 956     ## make the aliases....
 957     while (my ($Alias, $Name) = each %Is) {
 958         New_Alias(Is => $Alias, SameAs => $Name, AllowFuzzy => 1);
 959     }
 960 }
 961
 962 ##
 963 ## Writes the info accumulated in
 964 ##
 965 ##       %TableInfo;
 966 ##       %FuzzyNames;
 967 ##       %AliasInfo;
 968 ##
 969 ##
 970 sub WriteAllMappings()
 971 {
 972     for my $Type ('In', 'Is')
 973     {
 974         my %Filenames;
 975         my %NameToFile;
 976
 977         my %Exact; ## will become %utf8::Is    or %utf8::In
 978         my %Pat;   ## will become %utf8::IsPat or %utf8::InPat
 979
 980         ##
 981         ## First write all the files to the $Type/ directory
 982         ##
 983         while (my ($Name, $Table) = each %{$TableInfo{$Type}})
 984         {
 985             ## Need an 8.3 safe filename.
 986             my $filename = $Name;
 987             $filename =~ s/[_\W]+(\w*)/\u$1/g;
 988             substr($filename, 8) = '' if length($filename) > 8;
 989
 990             ##
 991             ## Make sure the filename doesn't conflict with something we
 992             ## might have already written. If we have, say,
 993             ##     Greek_Extended1
 994             ##     Greek_Extended2
 995             ## they become
 996             ##     Greek_Ex
 997             ##     Greek_E2
 998             ##
 999             while (my $num = $Filenames{lc $filename}++)
1000             {
1001                 $num++; ## so filenames with numbers start with '2', which
1002                         ## just looks more natural.
1003                 substr($filename, -length($num)) = $num;
1004             }
1005
1006             ##
1007             ## Okay, write the file...
1008             ##
1009             $Exact{$Name} = $filename;
1010             $Table->Write("$Type/$filename.pl");
1011         }
1012
1013         ##
1014         ## Build %Pat
1015         ##
1016         while (my ($Fuzzy, $Real) = each %{$FuzzyNames{$Type}})
1017         {
1018             my $File = $Exact{$Real};
1019
1020             if (not $File) {
1021                 die "$0: oops [$Real]";
1022             }
1023
1024             ## The prefix length of 2 is enough spread,
1025             ## and besides, we have 'Yi' as an In category.
1026             my $Prefix = lc(substr($Fuzzy, 0, 2));
1027             my $Regex = NameToRegex($Fuzzy);
1028
1029             if ($Pat{$Prefix}->{$Regex}) {
1030                 warn "WHOA, conflict with /$Regex/: $Pat{$Prefix}->{$Regex} vs $File\n";
1031             }
1032
1033             $Pat{$Prefix}->{$Regex} = $File;
1034         }
1035
1036         ##
1037         ## Since the fuzzy method will provide for a way to match $Fuzzy,
1038         ## there's no need for $Fuzzy to be in %Exact as well.
1039         ## This can't be done in the loop above because there could be
1040         ## multiple $Fuzzys pointing at the same $Real, and we don't want
1041         ## the first to delete the exact mapping out from under the second.
1042         ##
1043         for my $Fuzzy (keys %{$FuzzyNames{$Type}})
1044         {
1045             delete $Exact{$Fuzzy};
1046         }
1047
1048
1049
1050         ##
1051         ## Now write In.pl / Is.pl
1052         ##
1053         if (not open OUT, ">$Type.pl") {
1054             die "$0: $Type.pl: $!\n";
1055         }
1056         print OUT $HEADER;
1057         print OUT "##\n";
1058         print OUT "## Data in this file used by ../utf8_heavy.pl\n";
1059         print OUT "##\n";
1060         print OUT "\n";
1061         print OUT "## Mapping from name to filename in ./$Type\n";
1062         print OUT "%utf8::$Type = (\n";
1063         for my $Name (sort keys %Exact)
1064         {
1065             my $File = $Exact{$Name};
1066             printf OUT "  %-41s => %s,\n", "'$Name'", "'$File'";
1067         }
1068         print OUT ");\n\n";
1069
1070         print OUT "## Mappings from regex to filename in ./$Type/\n";
1071         print OUT "%utf8::${Type}Pat = (\n";
1072         for my $Prefix (sort keys %Pat)
1073         {
1074             print OUT " '$Prefix' => {\n";
1075             while (my ($Regex, $File) = each %{ $Pat{$Prefix} }) {
1076                 print OUT "\t'$Regex' => '$File',\n";
1077             }
1078             print OUT " },\n";
1079         }
1080         print OUT ");\n";
1081
1082         close(OUT);
1083     }
1084 }
1085
1086 sub SpecCase_txt()
1087 {
1088     #
1089     # Read in the special cases.
1090     #
1091
1092     my %CaseInfo;
1093
1094     if (not open IN, "SpecCase.txt") {
1095         die "$0: SpecCase.txt: $!\n";
1096     }
1097     while (<IN>) {
1098         next unless /^[0-9A-Fa-f]+;/;
1099         s/\#.*//;
1100         s/\s+$//;
1101
1102         my ($code, $lower, $title, $upper, $condition) = split(/\s*;\s*/);
1103
1104         if ($condition) { # not implemented yet
1105             print "# SKIPPING $_\n" if $Verbose;
1106             next;
1107         }
1108
1109         # Wait until all the special cases have been read since
1110         # they are not listed in numeric order.
1111         my $ix = hex($code);
1112         push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ];
1113         push @{$CaseInfo{Title}}, [ $ix, $code, $title ];
1114         push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ];
1115     }
1116     close IN;
1117
1118     # Now write out the special cases properties in their code point order.
1119     # Prepend them to the To/{Upper,Lower,Title}.pl.
1120
1121     for my $case (qw(Lower Title Upper))
1122     {
1123         my $NormalCase = do "To/$case.pl" || die "$0: $@\n";
1124         if (not open OUT, ">To/$case.pl") {
1125             die "$0: To/$case.txt: $!";
1126         }
1127
1128         print OUT $HEADER, "\n";
1129         print OUT "%utf8::ToSpec$case =\n(\n";
1130
1131         for my $prop (sort { $a->[0] <=> $b->[0] } @{$CaseInfo{$case}}) {
1132             my ($ix, $code, $to) = @$prop;
1133             my $tostr =
1134               join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
1135             printf OUT qq['%04X' => "$tostr",\n], $ix;
1136         }
1137         print OUT ");\n\n";
1138         print OUT "return <<'END';\n";
1139         print OUT $NormalCase;
1140         print OUT "END\n";
1141         close OUT;
1142     }
1143 }
1144
1145 #
1146 # Read in the case foldings.
1147 #
1148 # We will do full case folding, C + F + I (see CaseFold.txt).
1149 #
1150 sub CaseFold_txt()
1151 {
1152     if (not open IN, "CaseFold.txt") {
1153         die "$0: To/Fold.pl: $!\n";
1154     }
1155
1156     my $Fold = Table->New();
1157     my %Fold;
1158
1159     while (<IN>) {
1160         # Skip status 'S', simple case folding
1161         next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/;
1162
1163         my ($code, $status, $fold) = (hex($1), $2, $3);
1164
1165         if ($status eq 'C') { # Common: one-to-one folding
1166             # No append() since several codes may fold into one.
1167             $Fold->RawAppendRange($code, $code, $fold);
1168         } else { # F: full, or I: dotted uppercase I -> dotless lowercase I
1169             $Fold{$code} = $fold;
1170         }
1171     }
1172     close IN;
1173
1174     $Fold->Write("To/Fold.pl");
1175
1176     #
1177     # Prepend the special foldings to the common foldings.
1178     #
1179
1180     my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n";
1181     if (not open OUT, ">To/Fold.pl") {
1182         die "$0: To/Fold.pl: $!\n";
1183     }
1184     print OUT $HEADER, "\n";
1185     print OUT "%utf8::ToSpecFold =\n(\n";
1186     for my $code (sort { $a <=> $b } keys %Fold) {
1187         my $foldstr =
1188           join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
1189         printf OUT qq['%04X' => "$foldstr",\n], $code;
1190     }
1191     print OUT ");\n\n";
1192     print OUT "return <<'END';\n";
1193     print OUT $CommonFold;
1194     print OUT "END\n";
1195     close OUT;
1196 }
1197
1198 ## Do it....
1199
1200 Unicode_Txt();
1201 Make_GC_Aliases();
1202 PropList_txt();
1203
1204 Scripts_txt();
1205 Blocks_txt();
1206
1207 LineBrk_Txt();
1208 ArabShap_txt();
1209 Jamo_txt();
1210 SpecCase_txt();
1211
1212 WriteAllMappings();
1213
1214 CaseFold_txt();
1215
1216 # That's all, folks!
1217
1218 __END__