[p5sagit/p5-mst-13.2.git] / lib / unicore / mktables

#!/usr/bin/perl -w

#
# mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl)
# from the Unicode database files (lib/unicore/*.txt).
#

use strict;

my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.

mkdir("In", 0755);
mkdir("Is", 0755);
mkdir("To", 0755);

sub extend {
    my ($table, $last) = @_;

    $table->[-1]->[1] = $last;
}

sub append {
    my ($table, $code, $name) = @_;
    if (@$table &&
	hex($table->[-1]->[1]) == hex($code) - 1 &&
	(!defined $name || $table->[-1]->[2] eq $name)) {
	extend($table, $code);
    } else {
	push @$table, [$code, $code, $name];
    }
}

sub inverse {
    my ($table) = @_;
    my $inverse = [];
    my ($first, $last);
    if ($table->[0]->[0]) {
	$last = hex($table->[0]->[0]);
	push @$inverse, [ "0000",
			  sprintf("%04X", $last - 1) ];
    }
    for my $i (0..$#$table-1) {
	$first = defined $table->[$i    ]->[1] ?
	             hex($table->[$i    ]->[1]) : 0;
	$last  = defined $table->[$i + 1]->[0] ?
	             hex($table->[$i + 1]->[0]) : $first;
	push @$inverse, [ sprintf("%04X", $first + 1),
			  sprintf("%04X", $last  - 1) ]
			      unless $first + 1 == $last;
    }
    return $inverse;
}

sub header {
    my $fh = shift;

    print $fh <<EOT;
# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
# This file is built by $0 from e.g. Unicode.txt.
# Any changes made here will be lost!
EOT
}

sub begin {
    my $fh = shift;

    print $fh <<EOT;
return <<'END';
EOT
}

sub end {
    my $fh = shift;
    
    print $fh <<EOT;
END
EOT
}

sub flush {
    my ($table, $file) = @_;
    print "$file\n";
    if (open(my $fh, ">$file")) {
	header($fh);
	begin($fh);
	for my $i (@$table) {
	    print $fh $i->[0], "\t",
                      $i->[1] ne $i->[0] ? $i->[1] : "", "\t",
                      defined $i->[2] ? $i->[2] : "", "\n";
	}
	end($fh);
	close($fh);
    } else {
	die "$0: $file: $!\n";
    }
}

#
# The %In contains the mapping of the script/block name into a number.
#

my %In;
my $InId = 0;
my %InIn;

my %InScript;
my %InBlock;

#
# Read in the Unicode.txt, the main Unicode database.
#

my %Cat;
my %General;
my @General;

if (open(my $Unicode, "Unicode.txt")) {
    my @Name;
    my @Bidi;
    my %Bidi;
    my @Comb;
    my @Deco;
    my %Deco;
    my %DC;
    my @Number;
    my @Mirrored;
    my %To;
    while (<$Unicode>) {
	next unless /^[0-9A-Fa-f]+;/;
	s/\s+$//;

	my ($code, $name, $cat, $comb, $bidi, $deco,
	    $decimal, $digit, $number,
	    $mirrored, $unicode10, $comment,
	    $upper, $lower, $title) = split(/\s*;\s*/);

	if ($name =~ /^<(.+), (First|Last)>$/) {
	    $name = $1;
	    if ($2 eq 'First') {
		append($General{$name} ||= [], $code, $name);
	    } else {
		extend($General{$name}       , $code);
	    }
	    unless (defined $In{$name}) {
		$In{$name}   = $InId++;
		$InIn{$name} = $General{$name};
	    }
	    append($Cat{$cat}       ||= [], $code);
	    append($Cat{substr($cat, 0, 1)}
		                    ||= [], $code);
	} else {
	    append(\@Name,                  $code, $name);

	    append(\@General,               $code, $cat);

	    append($Cat{$cat}       ||= [], $code);
	    append($Cat{substr($cat, 0, 1)}
		                    ||= [], $code);
	    # 005F: SPACING UNDERSCORE
	    append($Cat{Word}       ||= [], $code)
		if $cat =~ /^[LMN]/ or $code eq "005F";
	    append($Cat{Alnum}      ||= [], $code)
		if $cat =~ /^[LMN]/;
	    append($Cat{Alpha}      ||= [], $code)
		if $cat =~ /^[LM]/;
	    # 0009: HORIZONTAL TABULATION
	    # 000A: LINE FEED
	    # 000B: VERTICAL TABULATION
	    # 000C: FORM FEED
	    # 000D: CARRIAGE RETURN
	    # 0020: SPACE
	    append($Cat{Space}      ||= [], $code)
		if $cat  =~ /^Z/ ||
		    $code =~ /^(0009|000A|000B|000C|000D)$/;
	    append($Cat{SpacePerl}  ||= [], $code)
		if $cat  =~ /^Z/ ||
		    $code =~ /^(0009|000A|000C|000D)$/;
	    append($Cat{Blank}      ||= [], $code)
		if $code =~ /^(0020|0009)$/ ||
		    $cat  =~ /^Z[^lp]$/;
	    append($Cat{Digit}      ||= [], $code) if $cat eq "Nd";
	    append($Cat{Upper}      ||= [], $code) if $cat eq "Lu";
	    append($Cat{Lower}      ||= [], $code) if $cat eq "Ll";
	    append($Cat{Title}      ||= [], $code) if $cat eq "Lt";
	    append($Cat{ASCII}      ||= [], $code) if $code le "007F";
	    append($Cat{Cntrl}      ||= [], $code) if $cat =~ /^C/;
	    append($Cat{Graph}      ||= [], $code) if $cat =~ /^([LMNPS]|Co)/;
	    append($Cat{Print}      ||= [], $code) if $cat =~ /^([LMNPS]|Co|Zs)/;
	    append($Cat{Punct}      ||= [], $code) if $cat =~ /^P/;
	    # 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f
	    append($Cat{XDigit}     ||= [], $code)
		if $code =~ /^00(3[0-9]|[46][1-6])$/;
	    
	    append($To{Upper}       ||= [], $code, $upper)   if $upper;
	    append($To{Lower}       ||= [], $code, $lower)   if $lower;
	    append($To{Title}       ||= [], $code, $title)   if $title;
	    append($To{Digit}       ||= [], $code, $decimal) if $decimal;
	    
	    append(\@Bidi,                  $code, $bidi);
	    append($Bidi{$bidi}     ||= [], $code);
	    
	    append(\@Comb,                  $code, $comb) if $comb;
	    
	    if ($deco) {
		append(\@Deco,                  $code, $deco);
		if ($deco =~/^<(\w+)>/) {
		    append($Deco{Compat} ||= [], $code);
		    append($DC{$1}       ||= [], $code);
		} else {
		    append($Deco{Canon}  ||= [], $code);
		}
	    }
	    
	    append(\@Number,                     $code, $number) if $number;
	    
	    append(\@Mirrored,                   $code) if $mirrored eq "Y";
	}
    }

    flush(\@Name, "Name.pl");

    foreach my $cat (sort keys %Cat) {
	flush($Cat{$cat}, "Is/$cat.pl");
    }

    foreach my $to (sort keys %To) {
	flush($To{$to}, "To/$to.pl");
    }

    flush(\@Bidi, "Bidirectional.pl");
    foreach my $bidi (sort keys %Bidi) {
	flush($Bidi{$bidi}, "Is/Bidi$bidi.pl");
    }

    flush(\@Comb, "CombiningClass.pl");

    flush(\@Deco, "Decomposition.pl");
    foreach my $deco (sort keys %Deco) {
	flush($Deco{$deco}, "Is/Deco$deco.pl");
    }
    foreach my $dc (sort keys %DC) {
	flush($DC{$dc}, "Is/DC$dc.pl");
    }

    flush(\@Number, "Number.pl");

    flush(\@Mirrored, "Is/Mirrored.pl");
} else {
    die "$0: Unicode.txt: $!\n";
}

#  The general cateory can be written out already now.

flush(\@General, "Category.pl");

#
# Read in the LineBrk.txt.
#

if (open(my $LineBrk, "LineBrk.txt")) {
    my @Lbrk;
    my %Lbrk;

    while (<$LineBrk>) {
        next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;

	my ($first, $last, $lbrk) = ($1, $2, $3);

	append(\@Lbrk,              $first, $lbrk);
	append($Lbrk{$lbrk} ||= [], $first);
	if (defined $last) {
	    extend(\@Lbrk,          $last);
	    extend($Lbrk{$lbrk},    $last);
	}
    }

    flush(\@Lbrk, "Lbrk.pl");
    foreach my $lbrk (sort keys %Lbrk) {
	flush($Lbrk{$lbrk}, "Is/Lbrk$lbrk.pl");
    }
} else {
    die "$0: LineBrk.txt: $!\n";
}

#
# Read in the ArabShap.txt.
#

if (open(my $ArabShap, "ArabShap.txt")) {
    my @ArabLink;
    my @ArabLinkGroup;

    while (<$ArabShap>) {
	next unless /^[0-9A-Fa-f]+;/;
	s/\s+$//;

	my ($code, $name, $link, $linkgroup) = split(/\s*;\s*/);

	append(\@ArabLink,      $code, $link);
	append(\@ArabLinkGroup, $code, $linkgroup);
    }

    flush(\@ArabLink,      "ArabLink.pl");
    flush(\@ArabLinkGroup, "ArabLnkGrp.pl");
} else {
    die "$0: ArabShap.txt: $!\n";
}

#
# Read in the Jamo.txt.
#

if (open(my $Jamo, "Jamo.txt")) {
    my @Short;

    while (<$Jamo>) {
	next unless /^([0-9A-Fa-f]+)\s*;\s*(\w*)/;

	my ($code, $short) = ($1, $2);

	append(\@Short, $code, $short);
    }

    flush(\@Short, "JamoShort.pl");
} else {
    die "$0: Jamo.txt: $!\n";
}

#
# Read in the Scripts.txt.
#

my @Scripts;

if (open(my $Scripts, "Scripts.txt")) {
    while (<$Scripts>) {
	next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;

	# Wait until all the scripts have been read since
	# they are not listed in numeric order.
	push @Scripts, [ hex($1), $1, $2, $3 ];
    }
} else {
    die "$0: Scripts.txt: $!\n";
}

# Now append the scripts properties in their code point order.

my %Script;
my $Scripts = [];

for my $script (sort { $a->[0] <=> $b->[0] } @Scripts) {
    my ($code, $first, $last, $name) = @$script;
    append($Scripts,              $first, $name);
    append($Script{$name} ||= [], $first, $name);
    if (defined $last) {
	extend($Scripts,       $last);
	extend($Script{$name}, $last);
    }
    unless (defined $In{$name}) {
	$InScript{$InId} = $name;
	$In{$name}       = $InId++;
	$InIn{$name}     = $Script{$name};
    }
}

# Scripts.pl can be written out already now.

flush(\@Scripts, "Scripts.pl");

# Common is everything not explicitly assigned to a Script

$In{Common} = $InId++;
my $Common = inverse($Scripts);
$InIn{Common} = $Common;

#
# Read in the Blocks.txt.
#

my @Blocks;
my %Blocks;

if (open(my $Blocks, "Blocks.txt")) {
    while (<$Blocks>) {
	next unless /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s*;\s*(.+?)\s*$/;
	
	my ($first, $last, $name) = ($1, $2, $3);
	my $origname = $name;

	# If there's a naming conflict (the script names are
	# in uppercase), the name of the block has " Block"
	# appended to it.
	my $pat = $name;
	$pat =~ s/([- _])/(?:[-_]|\\s+)?/g;
	for my $i (values %InScript) {
	    if ($i =~ /^$pat$/i) {
		$name .= " Block";
		last;
	    }
	}

	append(\@Blocks,              $first, $name);
	append($Blocks{$name} ||= [], $first, $name);
	if (defined $last) {
	    extend(\@Blocks,       $last);
	    extend($Blocks{$name}, $last);
	}
	unless (defined $In{$name}) {
	    $InBlock{$InId} = $origname;
	    $In{$name}      = $InId++;
	    $InIn{$name}    = $Blocks{$name};
	}
    }
} else {
    die "$0: Blocks.txt: $!\n";
}

# Blocks.pl can be written out already now.

flush(\@Blocks, "Blocks.pl");

#
# Read in the PropList.txt.  It contains extended properties not
# listed in the Unicode.txt, such as 'Other_Alphabetic':
# alphabetic but not of the general category L; many modifiers
# belong to this extended property category: while they are not
# alphabets, they are alphabetic in nature.
#

my @Props;

if (open(my $Props, "PropList.txt")) {
    while (<$Props>) {
	next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/;

	# Wait until all the extended properties have been read since
	# they are not listed in numeric order.
	push @Props, [ hex($1), $1, $2, $3 ];
    }
} else {
    die "$0: PropList.txt: $!\n";
}

# Now append the extended properties in their code point order.

my %Prop;
my $Props = [];

for my $prop (sort { $a->[0] <=> $b->[0] } @Props) {
    my ($code, $first, $last, $name) = @$prop;
    append($Props,              $first, $name);
    append($Prop{$name} ||= [], $first, $name);
    if (defined $last) {
	extend($Props,       $last);
	extend($Prop{$name}, $last);
    }
    unless (defined $In{$name}) {
	$In{$name}   = $InId++;
	$InIn{$name} = $Prop{$name};
    }
}

# Assigned is everything not Cn aka Noncharacter_Code_Point

$In{Assigned} = $InId++;
my $Assigned = inverse($Prop{Noncharacter_Code_Point});
$InIn{Assigned} = $Assigned;

sub merge_general_and_extended {
    my ($name, $general, $extended) = @_;
    my $merged;

    push @$merged,
         map { pop @{$_}; $_ }
             sort { $a->[2] <=> $b->[2] }
                  map { [ $_->[0], $_->[1], hex($_->[0]) ] }
                      ($general ?
		         map { ref $_ ? @$_ : $_ }
                             @Cat {ref $general  ? @$general  : $general } :
		         (),
                       $extended ?
		         map { ref $_ ? @$_ : $_ }
                             @Prop{ref $extended ? @$extended : $extended} :
		         ());

    $In{$name}   = $InId++;
    $InIn{$name} = $merged;
    
    return $merged;
}

# Alphabetic is L and Other_Alphabetic.

my $Alphabetic =
    merge_general_and_extended('Alphabetic', 'L', 'Other_Alphabetic');

# Lowercase is Ll and Other_Lowercase.

my $Lowercase =
    merge_general_and_extended('Lowercase', 'Ll', 'Other_Lowercase');

# Uppercase is Lu and Other_Uppercase.

my $Uppercase =
    merge_general_and_extended('Uppercase', 'Lu', 'Other_Uppercase');

# Math is Sm and Other_Math.

my $Math =
    merge_general_and_extended('Math', 'Sm', 'Other_Math');

# Lampersand is Ll, Lu, and Lt.

my $Lampersand =
    merge_general_and_extended('Lampersand', [ qw(Ll Lu Lt) ]);

# ID_Start is Ll, Lu, Lt, Lm, Lo, and Nl.

my $ID_Start =
    merge_general_and_extended('ID_Start', [ qw(Ll Lu Lt Lm Lo Nl) ]);

# ID_Continue is ID_Start, Mn, Mc, Nd, and Pc.

my $ID_Continue =
    merge_general_and_extended('ID_Continue', [ qw(Ll Lu Lt Lm Lo Nl
						   Mn Mc Nd Pc) ]);

#
# Any is any.
#

$In{Any} = $InId++;
my $Any = [ [ 0, sprintf("%04X", $LastUnicodeCodepoint) ] ];
$InIn{Any} = $Any;

#
# mapping() will be used to write out the In and Is virtual mappings.
#

sub mapping {
    my ($map, $name) = @_;

    if (open(my $fh, ">$name.pl")) {
	print "$name.pl\n";
	header($fh);

	# The %pat will hold a hash that maps the first two
	# lowercased letters of a class to a 'fuzzified' regular
	# expression that points to the real mapping.

	my %pat;

	# But first write out the offical name to real name
	# (the filename) mapping.

	print $fh <<EOT;
%utf8::${name} =
(
EOT
        for my $i (sort { lc $a cmp lc $b } keys %$map) {
	    my $pat = $i;
	    # Here is the 'fuzzification': accept any space,
	    # dash, or underbar where in the official name
	    # there is space or a dash (or underbar, but
	    # there never is).
	    $pat =~ s/([- _])/(?:[-_]|\\s+)?/g;
	    # The prefix length of 2 is enough spread,
	    # and besides, we have 'Yi' as an In category.
	    push @{$pat{lc(substr($i, 0, 2))}}, [ $i, $pat ];
	    printf $fh "%-45s => '$map->{$i}',\n", "'$i'";
	}
        print $fh <<EOT;
);
EOT

	# Now write out the %pat mapping.

        print $fh <<EOT;
%utf8::${name}Pat =
(
EOT
        foreach my $prefix (sort keys %pat) {
	    print $fh "'$prefix' => {\n";
	    foreach my $ipat (@{$pat{$prefix}}) {
		my ($i, $pat) = @$ipat;
		print $fh "\t'$pat' => '$map->{$i}',\n";
	    }
	    print $fh "},\n";
	}
        print $fh <<EOT;
);
EOT

        close($fh);
    } else {
        die "$0: $name.pl: $!\n";
    }
}

#
# Write out the virtual In mappings.
#

mapping(\%In, "In");

#
# Append the InScript and InBlock mappings.
# These are needed only if Script= and Block= syntaxes are used.
#

if (open(my $In, ">>In.pl")) {
    print $In <<EOT;

%utf8::InScript =
(
EOT
    for my $i (sort { $a <=> $b } keys %InScript) {
	printf $In "%4d => '$InScript{$i}',\n", $i;
    }
    print $In <<EOT;
);
EOT

    print $In <<EOT;

%utf8::InBlock =
(
EOT
    for my $i (sort { $a <=> $b } keys %InBlock) {
	printf $In "%4d => '$InBlock{$i}',\n", $i;
    }
    print $In <<EOT;
);
EOT
} else {
    die "$0: In.pl: $!\n";
}

# Easy low-calorie cheat.
use File::Copy;
copy("In/$In{Noncharacter_Code_Point}.pl", "Is/Cn.pl");

#
# Write out the real In mappings
# (the In.pl written out just above has the virtual In mappings)
#

foreach my $in (sort { $In{$a} <=> $In{$b} } keys %In) {
    flush($InIn{$in}, "In/$In{$in}.pl");
}

#
# The mapping from General Category long forms to short forms is
# currently hardwired here since no simple data file in the UCD
# seems to do that.
#

my %Is = (
	'Letter'			=>	'L',
	'Uppercase_Letter'		=>	'Lu',
	'Lowercase_Letter'		=>	'Ll',
	'Titlecase_Letter'		=>	'Lt',
	'Modifier_Letter'		=>	'Lm',
	'Other_Letter'			=>	'Lo',

	'Mark'				=>	'M',
	'Non_Spacing_Mark'		=>	'Mn',
	'Spacing_Mark'			=>	'Mc',
	'Enclosing_Mark'		=>	'Me',

	'Separator'			=>	'Z',
	'Space_Separator'		=>	'Zs',
	'Line_Separator'		=>	'Zl',
	'Paragraph_Separator'		=>	'Zp',

	'Number'			=>	'N',
	'Decimal_Number'		=>	'Nd',
	'Letter_Number'			=>	'Nl',
	'Other_Number'			=>	'No',

	'Punctuation'			=>	'P',
	'Connector_Punctuation'		=>	'Pc',
	'Dash_Punctuation'		=>	'Pd',
	'Open_Punctuation'		=>	'Ps',
	'Close_Punctuation'		=>	'Pe',
	'Initial_Punctuation'		=>	'Pi',
	'Final_Punctuation'		=>	'Pf',
	'Other_Punctuation'		=>	'Po',

	'Symbol'			=>	'S',
	'Math_Symbol'			=>	'Sm',
	'Currency_Symbol'		=>	'Sc',
	'Modifier_Symbol'		=>	'Sk',
	'Other_Symbol'			=>	'So',

	'Other'				=>	'C',
	'Control'			=>	'Cc',
	'Format'			=>	'Cf',
	'Surrogate'			=>	'Cs',
	'Private Use'			=>	'Co',
	'Unassigned'			=>	'Cn',
);

#
# Write out the virtual Is mappings.
#

mapping(\%Is, "Is");

#
# Read in the special cases.
#

my %Case;

if (open(my $SpecCase, "SpecCase.txt")) {
    while (<$SpecCase>) {
	next unless /^[0-9A-Fa-f]+;/;
	s/\#.*//;
	s/\s+$//;

	my ($code, $lower, $title, $upper, $condition) = split(/\s*;\s*/);

	if ($condition) { # not implemented yet
	    print "# SKIPPING $_\n";
	    next;
	}

	# Wait until all the special cases have been read since
	# they are not listed in numeric order.
	my $ix = hex($code);
	push @{$Case{Lower}}, [ $ix, $code, $lower ];
	push @{$Case{Title}}, [ $ix, $code, $title ];
	push @{$Case{Upper}}, [ $ix, $code, $upper ];
    }
} else {
    die "$0: SpecCase.txt: $!\n";
}

# Now write out the special cases properties in their code point order.
# Prepend them to the To/{Upper,Lower,Title}.pl.

for my $case (qw(Lower Title Upper)) {
    my $NormalCase = do "To/$case.pl" || die "$0: To/$case.pl: $!\n";
    if (open(my $Case, ">To/$case.pl")) {
	header($Case);
	print $Case <<EOT;

%utf8::ToSpec$case = (
EOT
        for my $prop (sort { $a->[0] <=> $b->[0] } @{$Case{$case}}) {
	    my ($ix, $code, $to) = @$prop;
	    my $tostr =
		join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
	    printf $Case qq['%04X' => "$tostr",\n], $ix;
	}
	print $Case <<EOT;
);

EOT
	begin($Case);
	print $Case $NormalCase;
	end($Case);
    } else {
	die "$0: To/$case.txt: $!\n";
    }
}

#
# Read in the case foldings.
#
# We will do full case folding, C + F + I (see CaseFold.txt).
#

if (open(my $CaseFold, "CaseFold.txt")) {
    my @Fold;
    my %Fold;

    while (<$CaseFold>) {
	next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/;

	my ($code, $status, $fold) = ($1, $2, $3);

	if ($status eq 'C') { # Common: one-to-one folding
	    append(\@Fold, $code, $fold);
	} else { # F: full, or I: dotted uppercase I -> dotless lowercase I
	    $Fold{hex($code)} = $fold;
	}
    }

    flush(\@Fold, "To/Fold.pl");

    #
    # Prepend the special foldings to the common foldings.
    #

    my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n";
    if (open(my $Fold, ">To/Fold.pl")) {
	header($Fold);
	print $Fold <<EOT;

%utf8::ToSpecFold = (
EOT
        for my $code (sort { $a <=> $b } keys %Fold) {
	    my $foldstr =
		join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
	    printf $Fold qq['%04X' => "$foldstr",\n], $code;
	}
	print $Fold <<EOT;
);

EOT
	begin($Fold);
	print $Fold $CommonFold;
	end($Fold);
    } else {
	die "$0: To/Fold.pl: $!\n";
    }
} else {
    die "$0: CaseFold.txt: $!\n";
}

# That's all, folks!
Commit	Line	Data
d73e5302	1	#!/usr/bin/perl -w
	2
	3	#
	4	# mktables -- create the runtime Perl Unicode files (lib/unicore/*/.pl)
	5	# from the Unicode database files (lib/unicore/*.txt).
	6	#
	7
d73e5302	8	use strict;
d73e5302	9
d2d499f5	10	my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
d2d499f5	11
d73e5302	12	mkdir("In", 0755);
	13	mkdir("Is", 0755);
	14	mkdir("To", 0755);
	15
	16	sub extend {
	17	my ($table, $last) = @_;
	18
	19	$table->[-1]->[1] = $last;
	20	}
	21
	22	sub append {
	23	my ($table, $code, $name) = @_;
	24	if (@$table &&
	25	hex($table->[-1]->[1]) == hex($code) - 1 &&
	26	(!defined $name \|\| $table->[-1]->[2] eq $name)) {
	27	extend($table, $code);
	28	} else {
	29	push @$table, [$code, $code, $name];
	30	}
	31	}
	32
	33	sub inverse {
	34	my ($table) = @_;
	35	my $inverse = [];
	36	my ($first, $last);
	37	if ($table->[0]->[0]) {
	38	$last = hex($table->[0]->[0]);
	39	push @$inverse, [ "0000",
	40	sprintf("%04X", $last - 1) ];
	41	}
	42	for my $i (0..$#$table-1) {
	43	$first = defined $table->[$i ]->[1] ?
	44	hex($table->[$i ]->[1]) : 0;
	45	$last = defined $table->[$i + 1]->[0] ?
	46	hex($table->[$i + 1]->[0]) : $first;
	47	push @$inverse, [ sprintf("%04X", $first + 1),
	48	sprintf("%04X", $last - 1) ]
	49	unless $first + 1 == $last;
	50	}
	51	return $inverse;
	52	}
	53
	54	sub header {
	55	my $fh = shift;
	56
	57	print $fh <<EOT;
	58	# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
	59	# This file is built by $0 from e.g. Unicode.txt.
	60	# Any changes made here will be lost!
	61	EOT
	62	}
	63
	64	sub begin {
	65	my $fh = shift;
	66
	67	print $fh <<EOT;
	68	return <<'END';
	69	EOT
	70	}
	71
	72	sub end {
	73	my $fh = shift;
	74
	75	print $fh <<EOT;
76	END
77	EOT
78	}
79
80	sub flush {
81	my ($table, $file) = @_;
82	print "$file\n";
83	if (open(my $fh, ">$file")) {
84	header($fh);
85	begin($fh);
86	for my $i (@$table) {
87	print $fh $i->[0], "\t",
88	$i->[1] ne $i->[0] ? $i->[1] : "", "\t",
89	defined $i->[2] ? $i->[2] : "", "\n";
90	}
91	end($fh);
92	close($fh);
93	} else {
94	die "$0: $file: $!\n";
95	}
96	}
97
98	#
99	# The %In contains the mapping of the script/block name into a number.
100	#
101
102	my %In;
103	my $InId = 0;
104	my %InIn;
105
71d929cb	106	my %InScript;
	107	my %InBlock;
	108
d73e5302	109	#
	110	# Read in the Unicode.txt, the main Unicode database.
	111	#
	112
	113	my %Cat;
	114	my %General;
	115	my @General;
	116
	117	if (open(my $Unicode, "Unicode.txt")) {
	118	my @Name;
	119	my @Bidi;
	120	my %Bidi;
	121	my @Comb;
	122	my @Deco;
	123	my %Deco;
	124	my %DC;
	125	my @Number;
	126	my @Mirrored;
	127	my %To;
	128	while (<$Unicode>) {
d2d499f5	129	next unless /^[0-9A-Fa-f]+;/;
d73e5302	130	s/\s+$//;
d2d499f5	131
d73e5302	132	my ($code, $name, $cat, $comb, $bidi, $deco,
	133	$decimal, $digit, $number,
	134	$mirrored, $unicode10, $comment,
	135	$upper, $lower, $title) = split(/\s;\s/);
	136
	137	if ($name =~ /^<(.+), (First\|Last)>$/) {
	138	$name = $1;
	139	if ($2 eq 'First') {
	140	append($General{$name} \|\|= [], $code, $name);
	141	} else {
	142	extend($General{$name} , $code);
	143	}
	144	unless (defined $In{$name}) {
	145	$In{$name} = $InId++;
	146	$InIn{$name} = $General{$name};
	147	}
	148	append($Cat{$cat} \|\|= [], $code);
	149	append($Cat{substr($cat, 0, 1)}
	150	\|\|= [], $code);
	151	} else {
	152	append(\@Name, $code, $name);
	153
	154	append(\@General, $code, $cat);
	155
	156	append($Cat{$cat} \|\|= [], $code);
	157	append($Cat{substr($cat, 0, 1)}
	158	\|\|= [], $code);
	159	# 005F: SPACING UNDERSCORE
	160	append($Cat{Word} \|\|= [], $code)
	161	if $cat =~ /^[LMN]/ or $code eq "005F";
	162	append($Cat{Alnum} \|\|= [], $code)
	163	if $cat =~ /^[LMN]/;
	164	append($Cat{Alpha} \|\|= [], $code)
	165	if $cat =~ /^[LM]/;
	166	# 0009: HORIZONTAL TABULATION
	167	# 000A: LINE FEED
	168	# 000B: VERTICAL TABULATION
	169	# 000C: FORM FEED
	170	# 000D: CARRIAGE RETURN
	171	# 0020: SPACE
	172	append($Cat{Space} \|\|= [], $code)
	173	if $cat =~ /^Z/ \|\|
	174	$code =~ /^(0009\|000A\|000B\|000C\|000D)$/;
	175	append($Cat{SpacePerl} \|\|= [], $code)
	176	if $cat =~ /^Z/ \|\|
	177	$code =~ /^(0009\|000A\|000C\|000D)$/;
	178	append($Cat{Blank} \|\|= [], $code)
	179	if $code =~ /^(0020\|0009)$/ \|\|
	180	$cat =~ /^Z[^lp]$/;
	181	append($Cat{Digit} \|\|= [], $code) if $cat eq "Nd";
	182	append($Cat{Upper} \|\|= [], $code) if $cat eq "Lu";
	183	append($Cat{Lower} \|\|= [], $code) if $cat eq "Ll";
	184	append($Cat{Title} \|\|= [], $code) if $cat eq "Lt";
	185	append($Cat{ASCII} \|\|= [], $code) if $code le "007F";
	186	append($Cat{Cntrl} \|\|= [], $code) if $cat =~ /^C/;
	187	append($Cat{Graph} \|\|= [], $code) if $cat =~ /^([LMNPS]\|Co)/;
	188	append($Cat{Print} \|\|= [], $code) if $cat =~ /^([LMNPS]\|Co\|Zs)/;
	189	append($Cat{Punct} \|\|= [], $code) if $cat =~ /^P/;
	190	# 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f
	191	append($Cat{XDigit} \|\|= [], $code)
	192	if $code =~ /^00(3[0-9]\|[46][1-6])$/;
	193
	194	append($To{Upper} \|\|= [], $code, $upper) if $upper;
	195	append($To{Lower} \|\|= [], $code, $lower) if $lower;
196	append($To{Title} \|\|= [], $code, $title) if $title;
197	append($To{Digit} \|\|= [], $code, $decimal) if $decimal;
198
199	append(\@Bidi, $code, $bidi);
200	append($Bidi{$bidi} \|\|= [], $code);
201
202	append(\@Comb, $code, $comb) if $comb;
203
204	if ($deco) {
205	append(\@Deco, $code, $deco);
206	if ($deco =~/^<(\w+)>/) {
207	append($Deco{Compat} \|\|= [], $code);
208	append($DC{$1} \|\|= [], $code);
209	} else {
210	append($Deco{Canon} \|\|= [], $code);
211	}
212	}
213
214	append(\@Number, $code, $number) if $number;
215
216	append(\@Mirrored, $code) if $mirrored eq "Y";
217	}
218	}
219
220	flush(\@Name, "Name.pl");
221
222	foreach my $cat (sort keys %Cat) {
223	flush($Cat{$cat}, "Is/$cat.pl");
224	}
225
226	foreach my $to (sort keys %To) {
227	flush($To{$to}, "To/$to.pl");
228	}
229
230	flush(\@Bidi, "Bidirectional.pl");
231	foreach my $bidi (sort keys %Bidi) {
232	flush($Bidi{$bidi}, "Is/Bidi$bidi.pl");
233	}
234
235	flush(\@Comb, "CombiningClass.pl");
236
237	flush(\@Deco, "Decomposition.pl");
238	foreach my $deco (sort keys %Deco) {
239	flush($Deco{$deco}, "Is/Deco$deco.pl");
240	}
241	foreach my $dc (sort keys %DC) {
242	flush($DC{$dc}, "Is/DC$dc.pl");
243	}
244
245	flush(\@Number, "Number.pl");
246
247	flush(\@Mirrored, "Is/Mirrored.pl");
248	} else {
249	die "$0: Unicode.txt: $!\n";
250	}
251
252	# The general cateory can be written out already now.
253
254	flush(\@General, "Category.pl");
255
256	#
257	# Read in the LineBrk.txt.
258	#
259
260	if (open(my $LineBrk, "LineBrk.txt")) {
261	my @Lbrk;
262	my %Lbrk;
263
264	while (<$LineBrk>) {
d2d499f5	265	next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s;\s(\w+)/;
d73e5302	266
	267	my ($first, $last, $lbrk) = ($1, $2, $3);
	268
	269	append(\@Lbrk, $first, $lbrk);
	270	append($Lbrk{$lbrk} \|\|= [], $first);
	271	if (defined $last) {
	272	extend(\@Lbrk, $last);
	273	extend($Lbrk{$lbrk}, $last);
	274	}
	275	}
	276
	277	flush(\@Lbrk, "Lbrk.pl");
	278	foreach my $lbrk (sort keys %Lbrk) {
	279	flush($Lbrk{$lbrk}, "Is/Lbrk$lbrk.pl");
	280	}
	281	} else {
	282	die "$0: LineBrk.txt: $!\n";
	283	}
	284
	285	#
	286	# Read in the ArabShap.txt.
	287	#
	288
	289	if (open(my $ArabShap, "ArabShap.txt")) {
	290	my @ArabLink;
	291	my @ArabLinkGroup;
	292
	293	while (<$ArabShap>) {
d2d499f5	294	next unless /^[0-9A-Fa-f]+;/;
d73e5302	295	s/\s+$//;
d2d499f5	296
d73e5302	297	my ($code, $name, $link, $linkgroup) = split(/\s;\s/);
	298
	299	append(\@ArabLink, $code, $link);
	300	append(\@ArabLinkGroup, $code, $linkgroup);
	301	}
	302
	303	flush(\@ArabLink, "ArabLink.pl");
	304	flush(\@ArabLinkGroup, "ArabLnkGrp.pl");
	305	} else {
	306	die "$0: ArabShap.txt: $!\n";
	307	}
	308
	309	#
	310	# Read in the Jamo.txt.
	311	#
	312
	313	if (open(my $Jamo, "Jamo.txt")) {
	314	my @Short;
	315
	316	while (<$Jamo>) {
d2d499f5	317	next unless /^([0-9A-Fa-f]+)\s;\s(\w*)/;
	318
	319	my ($code, $short) = ($1, $2);
d73e5302	320
	321	append(\@Short, $code, $short);
	322	}
	323
	324	flush(\@Short, "JamoShort.pl");
	325	} else {
	326	die "$0: Jamo.txt: $!\n";
	327	}
	328
	329	#
	330	# Read in the Scripts.txt.
	331	#
	332
	333	my @Scripts;
	334
	335	if (open(my $Scripts, "Scripts.txt")) {
	336	while (<$Scripts>) {
d2d499f5	337	next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s;\s(.+?)\s*\#/;
d73e5302	338
	339	# Wait until all the scripts have been read since
	340	# they are not listed in numeric order.
	341	push @Scripts, [ hex($1), $1, $2, $3 ];
	342	}
	343	} else {
	344	die "$0: Scripts.txt: $!\n";
	345	}
	346
	347	# Now append the scripts properties in their code point order.
	348
	349	my %Script;
	350	my $Scripts = [];
	351
	352	for my $script (sort { $a->[0] <=> $b->[0] } @Scripts) {
	353	my ($code, $first, $last, $name) = @$script;
	354	append($Scripts, $first, $name);
	355	append($Script{$name} \|\|= [], $first, $name);
	356	if (defined $last) {
	357	extend($Scripts, $last);
	358	extend($Script{$name}, $last);
	359	}
	360	unless (defined $In{$name}) {
71d929cb	361	$InScript{$InId} = $name;
	362	$In{$name} = $InId++;
	363	$InIn{$name} = $Script{$name};
d73e5302	364	}
	365	}
	366
	367	# Scripts.pl can be written out already now.
	368
	369	flush(\@Scripts, "Scripts.pl");
	370
	371	# Common is everything not explicitly assigned to a Script
	372
	373	$In{Common} = $InId++;
	374	my $Common = inverse($Scripts);
	375	$InIn{Common} = $Common;
	376
	377	#
	378	# Read in the Blocks.txt.
	379	#
	380
	381	my @Blocks;
	382	my %Blocks;
	383
	384	if (open(my $Blocks, "Blocks.txt")) {
	385	while (<$Blocks>) {
d2d499f5	386	next unless /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s;\s(.+?)\s*$/;
d2d499f5	387
d73e5302	388	my ($first, $last, $name) = ($1, $2, $3);
71d929cb	389	my $origname = $name;
d73e5302	390
	391	# If there's a naming conflict (the script names are
	392	# in uppercase), the name of the block has " Block"
	393	# appended to it.
71d929cb	394	my $pat = $name;
	395	$pat =~ s/([- _])/(?:[-_]\|\\s+)?/g;
	396	for my $i (values %InScript) {
	397	if ($i =~ /^$pat$/i) {
	398	$name .= " Block";
	399	last;
	400	}
	401	}
d73e5302	402
	403	append(\@Blocks, $first, $name);
	404	append($Blocks{$name} \|\|= [], $first, $name);
	405	if (defined $last) {
	406	extend(\@Blocks, $last);
	407	extend($Blocks{$name}, $last);
	408	}
	409	unless (defined $In{$name}) {
71d929cb	410	$InBlock{$InId} = $origname;
	411	$In{$name} = $InId++;
	412	$InIn{$name} = $Blocks{$name};
d73e5302	413	}
	414	}
	415	} else {
	416	die "$0: Blocks.txt: $!\n";
	417	}
	418
	419	# Blocks.pl can be written out already now.
	420
	421	flush(\@Blocks, "Blocks.pl");
	422
	423	#
	424	# Read in the PropList.txt. It contains extended properties not
	425	# listed in the Unicode.txt, such as 'Other_Alphabetic':
	426	# alphabetic but not of the general category L; many modifiers
	427	# belong to this extended property category: while they are not
	428	# alphabets, they are alphabetic in nature.
	429	#
	430
	431	my @Props;
	432
	433	if (open(my $Props, "PropList.txt")) {
	434	while (<$Props>) {
d2d499f5	435	next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s;\s(.+?)\s*\#/;
d73e5302	436
	437	# Wait until all the extended properties have been read since
	438	# they are not listed in numeric order.
	439	push @Props, [ hex($1), $1, $2, $3 ];
	440	}
	441	} else {
	442	die "$0: PropList.txt: $!\n";
	443	}
	444
	445	# Now append the extended properties in their code point order.
	446
	447	my %Prop;
	448	my $Props = [];
	449
	450	for my $prop (sort { $a->[0] <=> $b->[0] } @Props) {
	451	my ($code, $first, $last, $name) = @$prop;
	452	append($Props, $first, $name);
	453	append($Prop{$name} \|\|= [], $first, $name);
	454	if (defined $last) {
	455	extend($Props, $last);
	456	extend($Prop{$name}, $last);
	457	}
	458	unless (defined $In{$name}) {
	459	$In{$name} = $InId++;
	460	$InIn{$name} = $Prop{$name};
	461	}
	462	}
	463
	464	# Assigned is everything not Cn aka Noncharacter_Code_Point
	465
	466	$In{Assigned} = $InId++;
	467	my $Assigned = inverse($Prop{Noncharacter_Code_Point});
	468	$InIn{Assigned} = $Assigned;
	469
	470	sub merge_general_and_extended {
	471	my ($name, $general, $extended) = @_;
	472	my $merged;
	473
	474	push @$merged,
	475	map { pop @{$_}; $_ }
	476	sort { $a->[2] <=> $b->[2] }
	477	map { [ $_->[0], $_->[1], hex($_->[0]) ] }
	478	($general ?
	479	map { ref $_ ? @$_ : $_ }
	480	@Cat {ref $general ? @$general : $general } :
	481	(),
	482	$extended ?
	483	map { ref $_ ? @$_ : $_ }
	484	@Prop{ref $extended ? @$extended : $extended} :
	485	());
	486
	487	$In{$name} = $InId++;
	488	$InIn{$name} = $merged;
	489
	490	return $merged;
	491	}
	492
	493	# Alphabetic is L and Other_Alphabetic.
	494
	495	my $Alphabetic =
	496	merge_general_and_extended('Alphabetic', 'L', 'Other_Alphabetic');
	497
	498	# Lowercase is Ll and Other_Lowercase.
	499
500	my $Lowercase =
501	merge_general_and_extended('Lowercase', 'Ll', 'Other_Lowercase');
502
503	# Uppercase is Lu and Other_Uppercase.
504
505	my $Uppercase =
506	merge_general_and_extended('Uppercase', 'Lu', 'Other_Uppercase');
507
508	# Math is Sm and Other_Math.
509
510	my $Math =
511	merge_general_and_extended('Math', 'Sm', 'Other_Math');
512
513	# Lampersand is Ll, Lu, and Lt.
514
515	my $Lampersand =
516	merge_general_and_extended('Lampersand', [ qw(Ll Lu Lt) ]);
517
518	# ID_Start is Ll, Lu, Lt, Lm, Lo, and Nl.
519
520	my $ID_Start =
521	merge_general_and_extended('ID_Start', [ qw(Ll Lu Lt Lm Lo Nl) ]);
522
523	# ID_Continue is ID_Start, Mn, Mc, Nd, and Pc.
524
525	my $ID_Continue =
526	merge_general_and_extended('ID_Continue', [ qw(Ll Lu Lt Lm Lo Nl
527	Mn Mc Nd Pc) ]);
528
529	#
530	# Any is any.
531	#
532
533	$In{Any} = $InId++;
534	my $Any = [ [ 0, sprintf("%04X", $LastUnicodeCodepoint) ] ];
535	$InIn{Any} = $Any;
536
537	#
538	# mapping() will be used to write out the In and Is virtual mappings.
539	#
540
541	sub mapping {
542	my ($map, $name) = @_;
543
544	if (open(my $fh, ">$name.pl")) {
545	print "$name.pl\n";
546	header($fh);
547
548	# The %pat will hold a hash that maps the first two
549	# lowercased letters of a class to a 'fuzzified' regular
550	# expression that points to the real mapping.
551
552	my %pat;
553
554	# But first write out the offical name to real name
555	# (the filename) mapping.
556
557	print $fh <<EOT;
558	%utf8::${name} =
559	(
560	EOT
67765ba6	561	for my $i (sort { lc $a cmp lc $b } keys %$map) {
d73e5302	562	my $pat = $i;
	563	# Here is the 'fuzzification': accept any space,
	564	# dash, or underbar where in the official name
	565	# there is space or a dash (or underbar, but
	566	# there never is).
	567	$pat =~ s/([- _])/(?:[-_]\|\\s+)?/g;
	568	# The prefix length of 2 is enough spread,
	569	# and besides, we have 'Yi' as an In category.
	570	push @{$pat{lc(substr($i, 0, 2))}}, [ $i, $pat ];
67765ba6	571	printf $fh "%-45s => '$map->{$i}',\n", "'$i'";
d73e5302	572	}
	573	print $fh <<EOT;
	574	);
	575	EOT
	576
	577	# Now write out the %pat mapping.
	578
	579	print $fh <<EOT;
	580	%utf8::${name}Pat =
	581	(
	582	EOT
	583	foreach my $prefix (sort keys %pat) {
	584	print $fh "'$prefix' => {\n";
	585	foreach my $ipat (@{$pat{$prefix}}) {
	586	my ($i, $pat) = @$ipat;
	587	print $fh "\t'$pat' => '$map->{$i}',\n";
	588	}
	589	print $fh "},\n";
	590	}
	591	print $fh <<EOT;
	592	);
	593	EOT
	594
	595	close($fh);
	596	} else {
	597	die "$0: $name.pl: $!\n";
	598	}
	599	}
	600
	601	#
	602	# Write out the virtual In mappings.
	603	#
	604
	605	mapping(\%In, "In");
	606
71d929cb	607	#
	608	# Append the InScript and InBlock mappings.
	609	# These are needed only if Script= and Block= syntaxes are used.
	610	#
	611
	612	if (open(my $In, ">>In.pl")) {
	613	print $In <<EOT;
	614
	615	%utf8::InScript =
	616	(
	617	EOT
	618	for my $i (sort { $a <=> $b } keys %InScript) {
	619	printf $In "%4d => '$InScript{$i}',\n", $i;
	620	}
	621	print $In <<EOT;
	622	);
	623	EOT
	624
	625	print $In <<EOT;
	626
	627	%utf8::InBlock =
	628	(
	629	EOT
	630	for my $i (sort { $a <=> $b } keys %InBlock) {
	631	printf $In "%4d => '$InBlock{$i}',\n", $i;
	632	}
	633	print $In <<EOT;
	634	);
	635	EOT
	636	} else {
	637	die "$0: In.pl: $!\n";
	638	}
	639
d73e5302	640	# Easy low-calorie cheat.
	641	use File::Copy;
	642	copy("In/$In{Noncharacter_Code_Point}.pl", "Is/Cn.pl");
	643
	644	#
	645	# Write out the real In mappings
	646	# (the In.pl written out just above has the virtual In mappings)
	647	#
	648
	649	foreach my $in (sort { $In{$a} <=> $In{$b} } keys %In) {
	650	flush($InIn{$in}, "In/$In{$in}.pl");
	651	}
	652
	653	#
	654	# The mapping from General Category long forms to short forms is
	655	# currently hardwired here since no simple data file in the UCD
	656	# seems to do that.
	657	#
	658
	659	my %Is = (
	660	'Letter' => 'L',
e150c829	661	'Uppercase_Letter' => 'Lu',
	662	'Lowercase_Letter' => 'Ll',
	663	'Titlecase_Letter' => 'Lt',
	664	'Modifier_Letter' => 'Lm',
	665	'Other_Letter' => 'Lo',
d73e5302	666
d73e5302	667	'Mark' => 'M',
e150c829	668	'Non_Spacing_Mark' => 'Mn',
	669	'Spacing_Mark' => 'Mc',
	670	'Enclosing_Mark' => 'Me',
d73e5302	671
d73e5302	672	'Separator' => 'Z',
e150c829	673	'Space_Separator' => 'Zs',
	674	'Line_Separator' => 'Zl',
	675	'Paragraph_Separator' => 'Zp',
d73e5302	676
d73e5302	677	'Number' => 'N',
e150c829	678	'Decimal_Number' => 'Nd',
	679	'Letter_Number' => 'Nl',
	680	'Other_Number' => 'No',
d73e5302	681
d73e5302	682	'Punctuation' => 'P',
e150c829	683	'Connector_Punctuation' => 'Pc',
	684	'Dash_Punctuation' => 'Pd',
	685	'Open_Punctuation' => 'Ps',
	686	'Close_Punctuation' => 'Pe',
	687	'Initial_Punctuation' => 'Pi',
	688	'Final_Punctuation' => 'Pf',
	689	'Other_Punctuation' => 'Po',
d73e5302	690
d73e5302	691	'Symbol' => 'S',
e150c829	692	'Math_Symbol' => 'Sm',
	693	'Currency_Symbol' => 'Sc',
	694	'Modifier_Symbol' => 'Sk',
	695	'Other_Symbol' => 'So',
d73e5302	696
	697	'Other' => 'C',
	698	'Control' => 'Cc',
	699	'Format' => 'Cf',
	700	'Surrogate' => 'Cs',
	701	'Private Use' => 'Co',
e150c829	702	'Unassigned' => 'Cn',
d73e5302	703	);
	704
	705	#
	706	# Write out the virtual Is mappings.
	707	#
	708
	709	mapping(\%Is, "Is");
	710
d2d499f5	711	#
	712	# Read in the special cases.
	713	#
	714
	715	my %Case;
	716
	717	if (open(my $SpecCase, "SpecCase.txt")) {
	718	while (<$SpecCase>) {
	719	next unless /^[0-9A-Fa-f]+;/;
	720	s/\#.*//;
	721	s/\s+$//;
	722
	723	my ($code, $lower, $title, $upper, $condition) = split(/\s;\s/);
	724
	725	if ($condition) { # not implemented yet
	726	print "# SKIPPING $_\n";
	727	next;
	728	}
	729
	730	# Wait until all the special cases have been read since
	731	# they are not listed in numeric order.
	732	my $ix = hex($code);
	733	push @{$Case{Lower}}, [ $ix, $code, $lower ];
	734	push @{$Case{Title}}, [ $ix, $code, $title ];
	735	push @{$Case{Upper}}, [ $ix, $code, $upper ];
	736	}
	737	} else {
	738	die "$0: SpecCase.txt: $!\n";
	739	}
	740
	741	# Now write out the special cases properties in their code point order.
983ffd37	742	# Prepend them to the To/{Upper,Lower,Title}.pl.
d2d499f5	743
d2d499f5	744	for my $case (qw(Lower Title Upper)) {
c4051cc5	745	my $NormalCase = do "To/$case.pl" \|\| die "$0: To/$case.pl: $!\n";
983ffd37	746	if (open(my $Case, ">To/$case.pl")) {
	747	header($Case);
	748	print $Case <<EOT;
	749
	750	%utf8::ToSpec$case = (
	751	EOT
	752	for my $prop (sort { $a->[0] <=> $b->[0] } @{$Case{$case}}) {
	753	my ($ix, $code, $to) = @$prop;
	754	my $tostr =
	755	join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
6d47b937	756	printf $Case qq['%04X' => "$tostr",\n], $ix;
983ffd37	757	}
	758	print $Case <<EOT;
	759	);
	760
	761	EOT
	762	begin($Case);
	763	print $Case $NormalCase;
	764	end($Case);
	765	} else {
	766	die "$0: To/$case.txt: $!\n";
d2d499f5	767	}
d2d499f5	768	}
d2d499f5	769
c4051cc5	770	#
	771	# Read in the case foldings.
	772	#
	773	# We will do full case folding, C + F + I (see CaseFold.txt).
	774	#
	775
	776	if (open(my $CaseFold, "CaseFold.txt")) {
	777	my @Fold;
	778	my %Fold;
	779
	780	while (<$CaseFold>) {
	781	next unless /^([0-9A-Fa-f]+)\s;\s([CFI])\s;\s([0-9A-Fa-f]+(?: [0-9A-Fa-f]+))\s;/;
	782
	783	my ($code, $status, $fold) = ($1, $2, $3);
	784
	785	if ($status eq 'C') { # Common: one-to-one folding
	786	append(\@Fold, $code, $fold);
	787	} else { # F: full, or I: dotted uppercase I -> dotless lowercase I
	788	$Fold{hex($code)} = $fold;
	789	}
	790	}
	791
	792	flush(\@Fold, "To/Fold.pl");
	793
	794	#
	795	# Prepend the special foldings to the common foldings.
	796	#
	797
	798	my $CommonFold = do "To/Fold.pl" \|\| die "$0: To/Fold.pl: $!\n";
	799	if (open(my $Fold, ">To/Fold.pl")) {
	800	header($Fold);
	801	print $Fold <<EOT;
	802
	803	%utf8::ToSpecFold = (
	804	EOT
	805	for my $code (sort { $a <=> $b } keys %Fold) {
	806	my $foldstr =
	807	join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
6d47b937	808	printf $Fold qq['%04X' => "$foldstr",\n], $code;
c4051cc5	809	}
	810	print $Fold <<EOT;
	811	);
	812
	813	EOT
	814	begin($Fold);
	815	print $Fold $CommonFold;
	816	end($Fold);
	817	} else {
	818	die "$0: To/Fold.pl: $!\n";
	819	}
	820	} else {
	821	die "$0: CaseFold.txt: $!\n";
	822	}
	823
d73e5302	824	# That's all, folks!
d73e5302	825