+## !!!!!!!!!!!!!! IF YOU MODIFY THIS FILE !!!!!!!!!!!!!!!!!!!!!!!!!
+## Any files created or read by this program should be listed in 'mktables.lst'
+
#!/usr/bin/perl -w
+require 5.008; # Needs pack "U". Probably safest to run on 5.8.x
use strict;
use Carp;
+use File::Spec;
+
##
## mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl)
## from the Unicode database files (lib/unicore/*.txt).
##
-mkdir("In", 0755);
-mkdir("Is", 0755);
-mkdir("To", 0755);
+## "Fuzzy" means this section in Unicode TR18:
+##
+## The recommended names for UCD properties and property values are in
+## PropertyAliases.txt [Prop] and PropertyValueAliases.txt
+## [PropValue]. There are both abbreviated names and longer, more
+## descriptive names. It is strongly recommended that both names be
+## recognized, and that loose matching of property names be used,
+## whereby the case distinctions, whitespace, hyphens, and underbar
+## are ignored.
+
+## Base names already used in lib/gc_sc (for avoiding 8.3 conflicts)
+my %BaseNames;
##
## Process any args.
##
-my $Verbose = 0;
+my $Verbose = 0;
+my $MakeTestScript = 0;
+my $AlwaysWrite = 0;
+my $UseDir = "";
+my $FileList = "$0.lst";
+my $MakeList = 0;
while (@ARGV)
{
$Verbose = 1;
} elsif ($arg eq '-q') {
$Verbose = 0;
+ } elsif ($arg eq '-w') {
+ $AlwaysWrite = 1; # update the files even if they havent changed
+ $FileList = "";
+ } elsif ($arg eq '-check') {
+ my $this = shift @ARGV;
+ my $ok = shift @ARGV;
+ if ($this ne $ok) {
+ print "Skipping as check params are not the same.\n";
+ exit(0);
+ }
+ } elsif ($arg eq '-maketest') {
+ $MakeTestScript = 1;
+ } elsif ($arg eq '-makelist') {
+ $MakeList = 1;
+ } elsif ($arg eq '-C' && defined ($UseDir = shift)) {
+ -d $UseDir or die "Unknown directory '$UseDir'";
+ } elsif ($arg eq '-L' && defined ($FileList = shift)) {
+ -e $FileList or die "Filelist '$FileList' doesn't appear to exist!";
} else {
- die "usage: $0 [-v|-q]";
+ die "usage: $0 [-v|-q|-w|-C dir|-L filelist] [-maketest] [-makelist]\n",
+ " -v : Verbose Mode\n",
+ " -q : Quiet Mode\n",
+ " -w : Write files regardless\n",
+ " -maketest : Make test script\n",
+ " -makelist : Rewrite the file list based on current setup\n",
+ " -L filelist : Use this file list, (defaults to $0)\n",
+ " -C dir : Change to this directory before proceeding\n",
+ " -check A B : Executes only if A and B are the same\n";
+ }
+}
+
+if ($FileList) {
+ print "Reading file list '$FileList'\n"
+ if $Verbose;
+ open my $fh,"<",$FileList or die "Failed to read '$FileList':$!";
+ my @input;
+ my @output;
+ for my $list ( \@input, \@output ) {
+ while (<$fh>) {
+ s/^ \s+ | \s+ $//xg;
+ next if /^ \s* (?: \# .* )? $/x;
+ last if /^ =+ $/x;
+ my ( $file ) = split /\t/, $_;
+ push @$list, $file;
+ }
+ my %dupe;
+ @$list = grep !$dupe{ $_ }++, @$list;
+ }
+ close $fh;
+ die "No input or output files in '$FileList'!"
+ if !@input or !@output;
+ if ( $MakeList ) {
+ foreach my $file (@output) {
+ unlink $file;
+ }
+ }
+ if ( $Verbose ) {
+ print "Expecting ".scalar( @input )." input files. ",
+ "Checking ".scalar( @output )." output files.\n";
+ }
+ # we set maxtime to be the youngest input file, including $0 itself.
+ my $maxtime = -M $0; # do this before the chdir!
+ if ($UseDir) {
+ chdir $UseDir or die "Failed to chdir to '$UseDir':$!";
+ }
+ foreach my $in (@input) {
+ my $time = -M $in;
+ die "Missing input file '$in'" unless defined $time;
+ $maxtime = $time if $maxtime < $time;
+ }
+
+ # now we check to see if any output files are older than maxtime, if
+ # they are we need to continue on, otherwise we can presumably bail.
+ my $ok = 1;
+ foreach my $out (@output) {
+ if ( ! -e $out ) {
+ print "'$out' is missing.\n"
+ if $Verbose;
+ $ok = 0;
+ last;
+ }
+ if ( -M $out > $maxtime ) {
+ print "'$out' is too old.\n"
+ if $Verbose;
+ $ok = 0;
+ last;
+ }
+ }
+ if ($ok) {
+ print "Files seem to be ok, not bothering to rebuild.\n";
+ exit(0);
+ }
+ print "Must rebuild tables.\n"
+ if $Verbose;
+} else {
+ if ($Verbose) {
+ print "Not checking filelist.\n";
+ }
+ if ($UseDir) {
+ chdir $UseDir or die "Failed to chdir to '$UseDir':$!";
}
}
+foreach my $lib ('To', 'lib',
+ map {File::Spec->catdir("lib",$_)}
+ qw(gc_sc dt bc hst ea jt lb nt ccc)) {
+ next if -d $lib;
+ mkdir $lib, 0755 or die "mkdir '$lib': $!";
+}
+
my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
my $HEADER=<<"EOF";
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by $0 from e.g. Unicode.txt.
+# This file is built by $0 from e.g. UnicodeData.txt.
# Any changes made here will be lost!
EOF
+sub force_unlink {
+ my $filename = shift;
+ return unless -e $filename;
+ return if CORE::unlink($filename);
+ # We might need write permission
+ chmod 0777, $filename;
+ CORE::unlink($filename) or die "Couldn't unlink $filename: $!\n";
+}
+
+##
+## Given a filename and a reference to an array of lines,
+## write the lines to the file only if the contents have not changed.
+## Filename can be given as an arrayref of directory names
+##
+sub WriteIfChanged($\@)
+{
+ my $file = shift;
+ my $lines = shift;
+
+ $file = File::Spec->catfile(@$file) if ref $file;
+
+ my $TextToWrite = join '', @$lines;
+ if (open IN, $file) {
+ local($/) = undef;
+ my $PreviousText = <IN>;
+ close IN;
+ if ($PreviousText eq $TextToWrite) {
+ print "$file unchanged.\n" if $Verbose;
+ return unless $AlwaysWrite;
+ }
+ }
+ force_unlink ($file);
+ if (not open OUT, ">$file") {
+ die "$0: can't open $file for output: $!\n";
+ }
+ print "$file written.\n" if $Verbose;
+
+ print OUT $TextToWrite;
+ close OUT;
+}
+
##
## The main datastructure (a "Table") represents a set of code points that
## are part of a particular quality (that are part of \pL, \p{InGreek},
my %TableDesc;
my %FuzzyNames;
my %AliasInfo;
+my %CanonicalToOrig;
##
## Turn something like
## OLD-ITALIC
-## to
+## into
## OldItalic
##
sub CanonicalName($)
{
- my $name = lc shift;
+ my $orig = shift;
+ my $name = lc $orig;
$name =~ s/(?<![a-z])(\w)/\u$1/g;
- $name =~ s/[_\W]+//g;
+ $name =~ s/[-_\s]+//g;
+
+ $CanonicalToOrig{$name} = $orig if not $CanonicalToOrig{$name};
return $name;
}
+
##
-## Turn something like
-## OLD-ITALIC
-## to
-## Old_Italic
+## Store the alias definitions for later use.
##
-sub CanonicalNameForPattern($)
+my %PropertyAlias;
+my %PropValueAlias;
+
+my %PA_reverse;
+my %PVA_reverse;
+
+sub Build_Aliases()
{
- my $name = lc shift;
- $name =~ s/(?<![a-z])(\w)/\u$1/g;
- $name =~ s/[_\W]+/_/;
- return $name;
+ ##
+ ## Most of the work with aliases doesn't occur here,
+ ## but rather in utf8_heavy.pl, which uses PVA.pl,
+
+ # Placate the warnings about used only once. (They are used again, but
+ # via a typeglob lookup)
+ %utf8::PropertyAlias = ();
+ %utf8::PA_reverse = ();
+ %utf8::PropValueAlias = ();
+ %utf8::PVA_reverse = ();
+ %utf8::PVA_abbr_map = ();
+
+ open PA, "< PropertyAliases.txt"
+ or confess "Can't open PropertyAliases.txt: $!";
+ while (<PA>) {
+ s/#.*//;
+ s/\s+$//;
+ next if /^$/;
+
+ my ($abbrev, $name) = split /\s*;\s*/;
+ next if $abbrev eq "n/a";
+ $PropertyAlias{$abbrev} = $name;
+ $PA_reverse{$name} = $abbrev;
+
+ # The %utf8::... versions use japhy's code originally from utf8_pva.pl
+ # However, it's moved here so that we build the tables at runtime.
+ tr/ _-//d for $abbrev, $name;
+ $utf8::PropertyAlias{lc $abbrev} = $name;
+ $utf8::PA_reverse{lc $name} = $abbrev;
+ }
+ close PA;
+
+ open PVA, "< PropValueAliases.txt"
+ or confess "Can't open PropValueAliases.txt: $!";
+ while (<PVA>) {
+ s/#.*//;
+ s/\s+$//;
+ next if /^$/;
+
+ my ($prop, @data) = split /\s*;\s*/;
+
+ if ($prop eq 'ccc') {
+ $PropValueAlias{$prop}{$data[1]} = [ @data[0,2] ];
+ $PVA_reverse{$prop}{$data[2]} = [ @data[0,1] ];
+ }
+ else {
+ next if $data[0] eq "n/a";
+ $PropValueAlias{$prop}{$data[0]} = $data[1];
+ $PVA_reverse{$prop}{$data[1]} = $data[0];
+ }
+
+ shift @data if $prop eq 'ccc';
+ next if $data[0] eq "n/a";
+
+ $data[1] =~ tr/ _-//d;
+ $utf8::PropValueAlias{$prop}{lc $data[0]} = $data[1];
+ $utf8::PVA_reverse{$prop}{lc $data[1]} = $data[0];
+
+ my $abbr_class = ($prop eq 'gc' or $prop eq 'sc') ? 'gc_sc' : $prop;
+ $utf8::PVA_abbr_map{$abbr_class}{lc $data[0]} = $data[0];
+ }
+ close PVA;
+
+ # backwards compatibility for L& -> LC
+ $utf8::PropValueAlias{gc}{'l&'} = $utf8::PropValueAlias{gc}{lc};
+ $utf8::PVA_abbr_map{gc_sc}{'l&'} = $utf8::PVA_abbr_map{gc_sc}{lc};
+
}
my $Fuzzy = delete $Args{Fuzzy};
my $Desc = delete $Args{Desc}; # description
- $Name = CanonicalNameForPattern($Name) if $Fuzzy;
+ $Name = CanonicalName($Name) if $Fuzzy;
## sanity check a few args
if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) {
return $Table;
}
-##
-## Returns true if the Table has no code points
-##
-sub Table::IsEmpty
-{
- my $Table = shift; #self
- return not @$Table;
-}
-
-##
-## Returns true if the Table has code points
-##
-sub Table::NotEmpty
-{
- my $Table = shift; #self
- return @$Table;
-}
##
## Returns the maximum code point currently in the table.
##
sub Table::Max
{
- my $Table = shift; #self
- confess "oops" if $Table->IsEmpty; ## must have code points to have a max
- return $Table->[-1]->[RANGE_END];
+ my $last = $_[0]->[-1]; ## last code point
+ confess "oops" unless $last; ## must have code points to have a max
+ return $last->[RANGE_END];
}
##
## Given a new code point, make the last range of the Table extend to
## include the new (and all intervening) code points.
##
+## Takes the time to make sure that the extension is valid.
+##
sub Table::Extend
{
my $Table = shift; #self
confess "oops ($codepoint <= $PrevMax)" if $codepoint <= $PrevMax;
- $Table->[-1]->[RANGE_END] = $codepoint;
+ $Table->ExtendNoCheck($codepoint);
+}
+
+
+##
+## Given a new code point, make the last range of the Table extend to
+## include the new (and all intervening) code points.
+##
+## Does NOT check that the extension is valid. Assumes that the caller
+## has already made this check.
+##
+sub Table::ExtendNoCheck
+{
+ ## Optmized adding: Assumes $Table and $codepoint as parms
+ $_[0]->[-1]->[RANGE_END] = $_[1];
}
##
## If we've already got a range working, and this code point is the next
## one in line, and if the name is the same, just extend the current range.
##
- if ($Table->NotEmpty
+ my $last = $Table->[-1];
+ if ($last
and
- $Table->Max == $codepoint - 1
+ $last->[RANGE_END] == $codepoint - 1
and
- $Table->[-1]->[RANGE_NAME] eq $name)
+ $last->[RANGE_NAME] eq $name)
{
- $Table->Extend($codepoint);
+ $Table->ExtendNoCheck($codepoint);
}
else
{
if ($start > $New->Max) {
$New->AppendRange($start, $end);
} elsif ($end > $New->Max) {
- $New->Extend($end);
+ $New->ExtendNoCheck($end);
}
}
##
## Given a filename, write a representation of the Table to a file.
## May have an optional comment as a 2nd arg.
+## Filename may actually be an arrayref of directories
##
sub Table::Write
{
my $filename = shift;
my $comment = shift;
- print "$filename\n" if $Verbose;
-
- if (not open(OUT, ">$filename")) {
- die "$0: can't write $filename: $!\n";
- }
-
- print OUT $HEADER;
+ my @OUT = $HEADER;
if (defined $comment) {
$comment =~ s/\s+\Z//;
$comment =~ s/^/# /gm;
- print OUT "#\n$comment\n#\n";
+ push @OUT, "#\n$comment\n#\n";
}
- print OUT "return <<'END';\n";
+ push @OUT, "return <<'END';\n";
for my $set (@$Table)
{
my $name = $set->[RANGE_NAME];
if ($start == $end) {
- printf OUT "%04X\t\t%s\n", $start, $name;
+ push @OUT, sprintf "%04X\t\t%s\n", $start, $name;
} else {
- printf OUT "%04X\t%04X\t%s\n", $start, $end, $name;
+ push @OUT, sprintf "%04X\t%04X\t%s\n", $start, $end, $name;
}
}
- print OUT "END\n";
- close OUT;
+ push @OUT, "END\n";
+
+ WriteIfChanged($filename, @OUT);
+}
+
+## This used only for making the test script.
+## helper function
+sub IsUsable($)
+{
+ my $code = shift;
+ return 0 if $code <= 0x0000; ## don't use null
+ return 0 if $code >= $LastUnicodeCodepoint; ## keep in range
+ return 0 if ($code >= 0xD800 and $code <= 0xDFFF); ## no surrogates
+ return 0 if ($code >= 0xFDD0 and $code <= 0xFDEF); ## utf8.c says no good
+ return 0 if (($code & 0xFFFF) == 0xFFFE); ## utf8.c says no good
+ return 0 if (($code & 0xFFFF) == 0xFFFF); ## utf8.c says no good
+ return 1;
+}
+
+## Return a code point that's part of the table.
+## Returns nothing if the table is empty (or covers only surrogates).
+## This used only for making the test script.
+sub Table::ValidCode
+{
+ my $Table = shift; #self
+ for my $set (@$Table) {
+ return $set->[RANGE_END] if IsUsable($set->[RANGE_END]);
+ }
+ return ();
+}
+
+## Return a code point that's not part of the table
+## Returns nothing if the table covers all code points.
+## This used only for making the test script.
+sub Table::InvalidCode
+{
+ my $Table = shift; #self
+
+ return 0x1234 if not @$Table;
+
+ for my $set (@$Table)
+ {
+ if (IsUsable($set->[RANGE_END] + 1))
+ {
+ return $set->[RANGE_END] + 1;
+ }
+
+ if (IsUsable($set->[RANGE_START] - 1))
+ {
+ return $set->[RANGE_START] - 1;
+ }
+ }
+ return ();
}
###########################################################################
confess "$0: bad args to New_Alias"
}
- if (not $TableInfo{$Type}->{$Name}) {
- confess "$0: don't have orignial $Type => $Name to make alias"
+ $Alias = CanonicalName($Alias) if $Fuzzy;
+
+ if (not $TableInfo{$Type}->{$Name})
+ {
+ my $CName = CanonicalName($Name);
+ if ($TableInfo{$Type}->{$CName}) {
+ confess "$0: Use canonical form '$CName' instead of '$Name' for alias.";
+ } else {
+ confess "$0: don't have original $Type => $Name to make alias\n";
+ }
}
if ($TableInfo{$Alias}) {
confess "$0: already have original $Type => $Alias; can't make alias";
## All assigned code points
my $Assigned = Table->New(Is => 'Assigned',
Desc => "All assigned code points",
- Fuzzy => 1);
+ Fuzzy => 0);
my $Name = Table->New(); ## all characters, individually by name
my $General = Table->New(); ## all characters, grouped by category
my %General;
my %Cat;
+## Simple Data::Dumper alike. Good enough for our needs. We can't use the real
+## thing as we have to run under miniperl
+sub simple_dumper {
+ my @lines;
+ my $item;
+ foreach $item (@_) {
+ if (ref $item) {
+ if (ref $item eq 'ARRAY') {
+ push @lines, "[\n", simple_dumper (@$item), "],\n";
+ } elsif (ref $item eq 'HASH') {
+ push @lines, "{\n", simple_dumper (%$item), "},\n";
+ } else {
+ die "Can't cope with $item";
+ }
+ } else {
+ if (defined $item) {
+ my $copy = $item;
+ $copy =~ s/([\'\\])/\\$1/gs;
+ push @lines, "'$copy',\n";
+ } else {
+ push @lines, "undef,\n";
+ }
+ }
+ }
+ @lines;
+}
+
##
-## Process Unicode.txt (Categories, etc.)
+## Process UnicodeData.txt (Categories, etc.)
##
-sub Unicode_Txt()
+sub UnicodeData_Txt()
{
my $Bidi = Table->New();
my $Deco = Table->New();
my $Comb = Table->New();
my $Number = Table->New();
- my $Mirrored = Table->New(Is => 'Mirrored',
- Desc => "Mirrored in bidirectional text",
- Fuzzy => 0);
+ my $Mirrored = Table->New();#Is => 'Mirrored',
+ #Desc => "Mirrored in bidirectional text",
+ #Fuzzy => 0);
my %DC;
my %Bidi;
- my %Deco;
- $Deco{Canon} = Table->New(Is => 'Canon',
- Desc => 'Decomposes to multiple characters',
- Fuzzy => 0);
- $Deco{Compat} = Table->New(Is => 'Compat',
- Desc => 'Compatible with a more-basic character',
- Fuzzy => 0);
+ my %Number;
+ $DC{can} = Table->New();
+ $DC{com} = Table->New();
## Initialize Perl-generated categories
- ## (Categories from Unicode.txt are auto-initialized in gencat)
- $Cat{Alnum} = Table->New(Is => 'Alnum', Desc => "[[:Alnum:]]", Fuzzy => 0);
- $Cat{Alpha} = Table->New(Is => 'Alpha', Desc => "[[:Alpha:]]", Fuzzy => 0);
- $Cat{ASCII} = Table->New(Is => 'ASCII', Desc => "[[:ASCII:]]", Fuzzy => 0);
- $Cat{Blank} = Table->New(Is => 'Blank', Desc => "[[:Blank:]]", Fuzzy => 0);
- $Cat{Cntrl} = Table->New(Is => 'Cntrl', Desc => "[[:Cntrl:]]", Fuzzy => 0);
- $Cat{Digit} = Table->New(Is => 'Digit', Desc => "[[:Digit:]]", Fuzzy => 0);
- $Cat{Graph} = Table->New(Is => 'Graph', Desc => "[[:Graph:]]", Fuzzy => 0);
- $Cat{Lower} = Table->New(Is => 'Lower', Desc => "[[:Lower:]]", Fuzzy => 0);
- $Cat{Print} = Table->New(Is => 'Print', Desc => "[[:Print:]]", Fuzzy => 0);
- $Cat{Punct} = Table->New(Is => 'Punct', Desc => "[[:Punct:]]", Fuzzy => 0);
- $Cat{Space} = Table->New(Is => 'Space', Desc => "[[:Space:]]", Fuzzy => 0);
- $Cat{Title} = Table->New(Is => 'Title', Desc => "[[:Title:]]", Fuzzy => 0);
- $Cat{Upper} = Table->New(Is => 'Upper', Desc => "[[:Upper:]]", Fuzzy => 0);
- $Cat{XDigit} = Table->New(Is => 'XDigit', Desc => "[[:XDigit:]]", Fuzzy => 0);
- $Cat{Word} = Table->New(Is => 'Word', Desc => "[[:Word:]]", Fuzzy => 0);
- $Cat{SpacePerl} = Table->New(Is => 'SpacePerl', Desc => '\s', Fuzzy => 0);
+ ## (Categories from UnicodeData.txt are auto-initialized in gencat)
+ $Cat{Alnum} =
+ Table->New(Is => 'Alnum', Desc => "[[:Alnum:]]", Fuzzy => 0);
+ $Cat{Alpha} =
+ Table->New(Is => 'Alpha', Desc => "[[:Alpha:]]", Fuzzy => 0);
+ $Cat{ASCII} =
+ Table->New(Is => 'ASCII', Desc => "[[:ASCII:]]", Fuzzy => 0);
+ $Cat{Blank} =
+ Table->New(Is => 'Blank', Desc => "[[:Blank:]]", Fuzzy => 0);
+ $Cat{Cntrl} =
+ Table->New(Is => 'Cntrl', Desc => "[[:Cntrl:]]", Fuzzy => 0);
+ $Cat{Digit} =
+ Table->New(Is => 'Digit', Desc => "[[:Digit:]]", Fuzzy => 0);
+ $Cat{Graph} =
+ Table->New(Is => 'Graph', Desc => "[[:Graph:]]", Fuzzy => 0);
+ $Cat{Lower} =
+ Table->New(Is => 'Lower', Desc => "[[:Lower:]]", Fuzzy => 0);
+ $Cat{Print} =
+ Table->New(Is => 'Print', Desc => "[[:Print:]]", Fuzzy => 0);
+ $Cat{Punct} =
+ Table->New(Is => 'Punct', Desc => "[[:Punct:]]", Fuzzy => 0);
+ $Cat{Space} =
+ Table->New(Is => 'Space', Desc => "[[:Space:]]", Fuzzy => 0);
+ $Cat{Title} =
+ Table->New(Is => 'Title', Desc => "[[:Title:]]", Fuzzy => 0);
+ $Cat{Upper} =
+ Table->New(Is => 'Upper', Desc => "[[:Upper:]]", Fuzzy => 0);
+ $Cat{XDigit} =
+ Table->New(Is => 'XDigit', Desc => "[[:XDigit:]]", Fuzzy => 0);
+ $Cat{Word} =
+ Table->New(Is => 'Word', Desc => "[[:Word:]]", Fuzzy => 0);
+ $Cat{SpacePerl} =
+ Table->New(Is => 'SpacePerl', Desc => '\s', Fuzzy => 0);
my %To;
$To{Upper} = Table->New();
($General{$name} ||= Table->New)->$op($code, $name);
# 005F: SPACING UNDERSCORE
- $Cat{Word}->$op($code) if $cat =~ /^[LMN]/ || $code == 0x005F;
- $Cat{Alnum}->$op($code) if $cat =~ /^[LMN]/;
+ $Cat{Word}->$op($code) if $cat =~ /^[LMN]|Pc/;
+ $Cat{Alnum}->$op($code) if $cat =~ /^[LM]|Nd/;
$Cat{Alpha}->$op($code) if $cat =~ /^[LM]/;
-
-
- $Cat{Space}->$op($code) if $cat =~ /^Z/
+ my $isspace =
+ ($cat =~ /Zs|Zl|Zp/ &&
+ $code != 0x200B) # 200B is ZWSP which is for line break control
+ # and therefore it is not part of "space" even while it is "Zs".
|| $code == 0x0009 # 0009: HORIZONTAL TAB
|| $code == 0x000A # 000A: LINE FEED
|| $code == 0x000B # 000B: VERTICAL TAB
|| $code == 0x000C # 000C: FORM FEED
- || $code == 0x000D; # 000D: CARRIAGE RETURN
+ || $code == 0x000D # 000D: CARRIAGE RETURN
+ || $code == 0x0085 # 0085: NEL
+ ;
- $Cat{SpacePerl}->$op($code) if $cat =~ /^Z/
- || $code == 0x0009 # 0009: HORIZONTAL TAB
- || $code == 0x000A # 000A: LINE FEED
- || $code == 0x000C # 000C: FORM FEED
- || $code == 0x000D # 000D: CARRIAGE RETURN
- || $code == 0x0085 # 0085: <NEXT LINE>
- || $code == 0x2028 # 2028: LINE SEPARATOR
- || $code == 0x2029;# 2029: PARAGRAPH SEP.
+ $Cat{Space}->$op($code) if $isspace;
- $Cat{Blank}->$op($code) if $cat =~ /^Z[^lp]$/
- || $code == 0x0009 # 0009: HORIZONTAL TAB
- || $code == 0x0020; # 0020: SPACE
+ $Cat{SpacePerl}->$op($code) if $isspace
+ && $code != 0x000B; # Backward compat.
+
+ $Cat{Blank}->$op($code) if $isspace
+ && !($code == 0x000A ||
+ $code == 0x000B ||
+ $code == 0x000C ||
+ $code == 0x000D ||
+ $code == 0x0085 ||
+ $cat =~ /^Z[lp]/);
$Cat{Digit}->$op($code) if $cat eq "Nd";
$Cat{Upper}->$op($code) if $cat eq "Lu";
$Cat{Title}->$op($code) if $cat eq "Lt";
$Cat{ASCII}->$op($code) if $code <= 0x007F;
$Cat{Cntrl}->$op($code) if $cat =~ /^C/;
- $Cat{Graph}->$op($code) if $cat =~ /^([LMNPS]|Co)/;
- $Cat{Print}->$op($code) if $cat =~ /^([LMNPS]|Co|Zs)/;
+ my $isgraph = !$isspace && $cat !~ /Cc|Cs|Cn/;
+ $Cat{Graph}->$op($code) if $isgraph;
+ $Cat{Print}->$op($code) if $isgraph || $isspace;
$Cat{Punct}->$op($code) if $cat =~ /^P/;
$Cat{XDigit}->$op($code) if ($code >= 0x30 && $code <= 0x39) ## 0..9
}
## open ane read file.....
- if (not open IN, "Unicode.txt") {
- die "$0: Unicode.txt: $!\n";
+ if (not open IN, "UnicodeData.txt") {
+ die "$0: UnicodeData.txt: $!\n";
}
##
$title, ## titlecase mapping
) = split(/\s*;\s*/);
+ # Note that in Unicode 3.2 there will be names like
+ # LINE FEED (LF), which probably means that \N{} needs
+ # to cope also with LINE FEED and LF.
+ $name = $unicode10 if $name eq '<control>' && $unicode10 ne '';
+
my $code = hex($hexcode);
if ($comb and $comb == 230) {
$Comb->Append($code, $comb) if $comb;
$Number->Append($code, $number) if length $number;
+ length($decimal) and ($Number{De} ||= Table->New())->Append($code)
+ or
+ length($digit) and ($Number{Di} ||= Table->New())->Append($code)
+ or
+ length($number) and ($Number{Nu} ||= Table->New())->Append($code);
+
$Mirrored->Append($code) if $mirrored eq "Y";
- $Bidi{$bidi} ||= Table->New(Is => "Bidi$bidi",
- Desc => "Bi-directional category '$bidi'",
- Fuzzy => 0);
+ $Bidi{$bidi} ||= Table->New();#Is => "bt/$bidi",
+ #Desc => "Bi-directional category '$bidi'",
+ #Fuzzy => 0);
$Bidi{$bidi}->Append($code);
if ($deco)
$Deco->Append($code, $deco);
if ($deco =~/^<(\w+)>/)
{
- $Deco{Compat}->Append($code);
+ my $dshort = $PVA_reverse{dt}{ucfirst lc $1};
+ $DC{com}->Append($code);
- $DC{$1} ||= Table->New(Is => "DC$1",
- Desc => "Compatible with '$1'",
- Fuzzy => 0);
- $DC{$1}->Append($code);
+ $DC{$dshort} ||= Table->New();
+ $DC{$dshort}->Append($code);
}
else
{
- $Deco{Canon}->Append($code);
+ $DC{can}->Append($code);
}
}
}
Fuzzy => 0);
## Unassigned is the same as 'Cn'
- New_Alias(Is => 'Unassigned', SameAs => 'Cn', Fuzzy => 1);
+ New_Alias(Is => 'Unassigned', SameAs => 'Cn', Fuzzy => 0);
$Cat{C}->Replace($Cat{C}->Merge($Cat{Cn})); ## Now merge in Cn into C
- # L& is Ll, Lu, and Lt.
- New_Prop(Is => 'L&',
+ # LC is Ll, Lu, and Lt.
+ # (used to be L& or L_, but PropValueAliases.txt defines it as LC)
+ New_Prop(Is => 'LC',
Table->Merge(@Cat{qw[Ll Lu Lt]}),
Desc => '[\p{Ll}\p{Lu}\p{Lt}]',
Fuzzy => 0);
my $Any = Table->New(Is => 'Any',
Desc => sprintf("[\\x{0000}-\\x{%X}]",
$LastUnicodeCodepoint),
- Fuzzy => 1);
+ Fuzzy => 0);
$Any->RawAppendRange(0, $LastUnicodeCodepoint);
- New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 1);
+ New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 0);
##
## Build special properties for Perl's internal case-folding needs:
## Now dump the files.
##
$Name->Write("Name.pl");
- $Bidi->Write("Bidirectional.pl");
+
+ {
+ my @PVA = $HEADER;
+ foreach my $name (qw (PropertyAlias PA_reverse PropValueAlias
+ PVA_reverse PVA_abbr_map)) {
+ # Should I really jump through typeglob hoops just to avoid a
+ # symbolic reference? (%{"utf8::$name})
+ push @PVA, "\n", "\%utf8::$name = (\n",
+ simple_dumper (%{$utf8::{$name}}), ");\n";
+ }
+ push @PVA, "1;\n";
+ WriteIfChanged("PVA.pl", @PVA);
+ }
+
+ # $Bidi->Write("Bidirectional.pl");
+ for (keys %Bidi) {
+ $Bidi{$_}->Write(
+ ["lib","bc","$_.pl"],
+ "BidiClass category '$PropValueAlias{bc}{$_}'"
+ );
+ }
+
$Comb->Write("CombiningClass.pl");
+ for (keys %{ $PropValueAlias{ccc} }) {
+ my ($code, $name) = @{ $PropValueAlias{ccc}{$_} };
+ (my $c = Table->New())->Append($code);
+ $c->Write(
+ ["lib","ccc","$_.pl"],
+ "CombiningClass category '$name'"
+ );
+ }
+
$Deco->Write("Decomposition.pl");
- $Number->Write("Number.pl");
- $General->Write("Category.pl");
+ for (keys %DC) {
+ $DC{$_}->Write(
+ ["lib","dt","$_.pl"],
+ "DecompositionType category '$PropValueAlias{dt}{$_}'"
+ );
+ }
+
+ # $Number->Write("Number.pl");
+ for (keys %Number) {
+ $Number{$_}->Write(
+ ["lib","nt","$_.pl"],
+ "NumericType category '$PropValueAlias{nt}{$_}'"
+ );
+ }
+
+ # $General->Write("Category.pl");
for my $to (sort keys %To) {
- $To{$to}->Write("To/$to.pl");
+ $To{$to}->Write(["To","$to.pl"]);
+ }
+
+ for (keys %{ $PropValueAlias{gc} }) {
+ New_Alias(Is => $PropValueAlias{gc}{$_}, SameAs => $_, Fuzzy => 1);
}
}
##
-## Process LineBrk.txt
+## Process LineBreak.txt
##
-sub LineBrk_Txt()
+sub LineBreak_Txt()
{
- if (not open IN, "LineBrk.txt") {
- die "$0: LineBrk.txt: $!\n";
+ if (not open IN, "LineBreak.txt") {
+ die "$0: LineBreak.txt: $!\n";
}
my $Lbrk = Table->New();
$Lbrk->Append($first, $lbrk);
- $Lbrk{$lbrk} ||= Table->New(Is => "Lbrk$lbrk",
- Desc => "Linebreak category '$lbrk'",
- Fuzzy => 0);
+ $Lbrk{$lbrk} ||= Table->New();
$Lbrk{$lbrk}->Append($first);
if ($last) {
}
close IN;
- $Lbrk->Write("Lbrk.pl");
+ # $Lbrk->Write("Lbrk.pl");
+
+
+ for (keys %Lbrk) {
+ $Lbrk{$_}->Write(
+ ["lib","lb","$_.pl"],
+ "Linebreak category '$PropValueAlias{lb}{$_}'"
+ );
+ }
}
##
-## Process ArabShap.txt.
+## Process ArabicShaping.txt.
##
-sub ArabShap_txt()
+sub ArabicShaping_txt()
{
- if (not open IN, "ArabShap.txt") {
- die "$0: ArabShap.txt: $!\n";
+ if (not open IN, "ArabicShaping.txt") {
+ die "$0: ArabicShaping.txt: $!\n";
}
my $ArabLink = Table->New();
my $ArabLinkGroup = Table->New();
+ my %JoinType;
+
while (<IN>)
{
next unless /^[0-9A-Fa-f]+;/;
my $code = hex($hexcode);
$ArabLink->Append($code, $link);
$ArabLinkGroup->Append($code, $linkgroup);
+
+ $JoinType{$link} ||= Table->New(Is => "JoinType$link");
+ $JoinType{$link}->Append($code);
+ }
+ close IN;
+
+ # $ArabLink->Write("ArabLink.pl");
+ # $ArabLinkGroup->Write("ArabLnkGrp.pl");
+
+
+ for (keys %JoinType) {
+ $JoinType{$_}->Write(
+ ["lib","jt","$_.pl"],
+ "JoiningType category '$PropValueAlias{jt}{$_}'"
+ );
+ }
+}
+
+##
+## Process EastAsianWidth.txt.
+##
+sub EastAsianWidth_txt()
+{
+ if (not open IN, "EastAsianWidth.txt") {
+ die "$0: EastAsianWidth.txt: $!\n";
+ }
+
+ my %EAW;
+
+ while (<IN>)
+ {
+ next unless /^[0-9A-Fa-f]+(\.\.[0-9A-Fa-f]+)?;/;
+ s/#.*//;
+ s/\s+$//;
+
+ my ($hexcodes, $pv) = split(/\s*;\s*/);
+ $EAW{$pv} ||= Table->New(Is => "EastAsianWidth$pv");
+ my ($start, $end) = split(/\.\./, $hexcodes);
+ if (defined $end) {
+ $EAW{$pv}->AppendRange(hex($start), hex($end));
+ } else {
+ $EAW{$pv}->Append(hex($start));
+ }
}
close IN;
- $ArabLink->Write("ArabLink.pl");
- $ArabLinkGroup->Write("ArabLnkGrp.pl");
+
+ for (keys %EAW) {
+ $EAW{$_}->Write(
+ ["lib","ea","$_.pl"],
+ "EastAsianWidth category '$PropValueAlias{ea}{$_}'"
+ );
+ }
+}
+
+##
+## Process HangulSyllableType.txt.
+##
+sub HangulSyllableType_txt()
+{
+ if (not open IN, "HangulSyllableType.txt") {
+ die "$0: HangulSyllableType.txt: $!\n";
+ }
+
+ my %HST;
+
+ while (<IN>)
+ {
+ next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/;
+ my ($first, $last, $pv) = (hex($1), hex($2||""), $3);
+
+ $HST{$pv} ||= Table->New(Is => "HangulSyllableType$pv");
+ $HST{$pv}->Append($first);
+
+ if ($last) { $HST{$pv}->Extend($last) }
+ }
+ close IN;
+
+ for (keys %HST) {
+ $HST{$_}->Write(
+ ["lib","hst","$_.pl"],
+ "HangulSyllableType category '$PropValueAlias{hst}{$_}'"
+ );
+ }
}
##
$Short->Append($code, $short);
}
close IN;
- $Short->Write("JamoShort.pl");
+ # $Short->Write("JamoShort.pl");
}
##
}
}
- $Scripts->Write("Scripts.pl");
+ # $Scripts->Write("Scripts.pl");
## Common is everything not explicitly assigned to a Script
##
}
close IN;
- $Blocks->Write("Blocks.pl");
+ # $Blocks->Write("Blocks.pl");
}
##
## Read in the PropList.txt. It contains extended properties not
-## listed in the Unicode.txt, such as 'Other_Alphabetic':
+## listed in the UnicodeData.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.
}
}
+ for (keys %Prop) {
+ (my $file = $PA_reverse{$_}) =~ tr/_//d;
+ # XXX I'm assuming that the names from %Prop don't suffer 8.3 clashes.
+ $BaseNames{lc $file}++;
+ $Prop{$_}->Write(
+ ["lib","gc_sc","$file.pl"],
+ "Binary property '$_'"
+ );
+ }
+
# Alphabetic is L and Other_Alphabetic.
New_Prop(Is => 'Alphabetic',
Table->Merge($Cat{L}, $Prop{Other_Alphabetic}),
Fuzzy => 1);
}
-sub Make_GC_Aliases()
+
+##
+## These are used in:
+## MakePropTestScript()
+## WriteAllMappings()
+## for making the test script.
+##
+my %FuzzyNameToTest;
+my %ExactNameToTest;
+
+
+## This used only for making the test script
+sub GenTests($$$$)
+{
+ my $FH = shift;
+ my $Prop = shift;
+ my $MatchCode = shift;
+ my $FailCode = shift;
+
+ if (defined $MatchCode) {
+ printf $FH qq/Expect(1, "\\x{%04X}", '\\p{$Prop}' );\n/, $MatchCode;
+ printf $FH qq/Expect(0, "\\x{%04X}", '\\p{^$Prop}');\n/, $MatchCode;
+ printf $FH qq/Expect(0, "\\x{%04X}", '\\P{$Prop}' );\n/, $MatchCode;
+ printf $FH qq/Expect(1, "\\x{%04X}", '\\P{^$Prop}');\n/, $MatchCode;
+ }
+ if (defined $FailCode) {
+ printf $FH qq/Expect(0, "\\x{%04X}", '\\p{$Prop}' );\n/, $FailCode;
+ printf $FH qq/Expect(1, "\\x{%04X}", '\\p{^$Prop}');\n/, $FailCode;
+ printf $FH qq/Expect(1, "\\x{%04X}", '\\P{$Prop}' );\n/, $FailCode;
+ printf $FH qq/Expect(0, "\\x{%04X}", '\\P{^$Prop}');\n/, $FailCode;
+ }
+}
+
+## This used only for making the test script
+sub ExpectError($$)
+{
+ my $FH = shift;
+ my $prop = shift;
+
+ print $FH qq/Error('\\p{$prop}');\n/;
+ print $FH qq/Error('\\P{$prop}');\n/;
+}
+
+## This used only for making the test script
+my @GoodSeps = (
+ " ",
+ "-",
+ " \t ",
+ "",
+ "",
+ "_",
+ );
+my @BadSeps = (
+ "--",
+ "__",
+ " _",
+ "/"
+ );
+
+## This used only for making the test script
+sub RandomlyFuzzifyName($;$)
+{
+ my $Name = shift;
+ my $WantError = shift; ## if true, make an error
+
+ my @parts;
+ for my $part (split /[-\s_]+/, $Name)
+ {
+ if (@parts) {
+ if ($WantError and rand() < 0.3) {
+ push @parts, $BadSeps[rand(@BadSeps)];
+ $WantError = 0;
+ } else {
+ push @parts, $GoodSeps[rand(@GoodSeps)];
+ }
+ }
+ my $switch = int rand(4);
+ if ($switch == 0) {
+ push @parts, uc $part;
+ } elsif ($switch == 1) {
+ push @parts, lc $part;
+ } elsif ($switch == 2) {
+ push @parts, ucfirst $part;
+ } else {
+ push @parts, $part;
+ }
+ }
+ my $new = join('', @parts);
+
+ if ($WantError) {
+ if (rand() >= 0.5) {
+ $new .= $BadSeps[rand(@BadSeps)];
+ } else {
+ $new = $BadSeps[rand(@BadSeps)] . $new;
+ }
+ }
+ return $new;
+}
+
+## This used only for making the test script
+sub MakePropTestScript()
{
+ ## this written directly -- it's huge.
+ force_unlink ("TestProp.pl");
+ if (not open OUT, ">TestProp.pl") {
+ die "$0: TestProp.pl: $!\n";
+ }
+ print OUT <DATA>;
+
+ while (my ($Name, $Table) = each %ExactNameToTest)
+ {
+ GenTests(*OUT, $Name, $Table->ValidCode, $Table->InvalidCode);
+ ExpectError(*OUT, uc $Name) if uc $Name ne $Name;
+ ExpectError(*OUT, lc $Name) if lc $Name ne $Name;
+ }
+
+
+ while (my ($Name, $Table) = each %FuzzyNameToTest)
+ {
+ my $Orig = $CanonicalToOrig{$Name};
+ my %Names = (
+ $Name => 1,
+ $Orig => 1,
+ RandomlyFuzzifyName($Orig) => 1
+ );
+
+ for my $N (keys %Names) {
+ GenTests(*OUT, $N, $Table->ValidCode, $Table->InvalidCode);
+ }
+
+ ExpectError(*OUT, RandomlyFuzzifyName($Orig, 'ERROR'));
+ }
+
+ print OUT "Finished();\n";
+ close OUT;
+}
+
+
+##
+## These are used only in:
+## RegisterFileForName()
+## WriteAllMappings()
+##
+my %Exact; ## will become %utf8::Exact;
+my %Canonical; ## will become %utf8::Canonical;
+my %CaComment; ## Comment for %Canonical entry of same key
+
+##
+## Given info about a name and a datafile that it should be associated with,
+## register that assocation in %Exact and %Canonical.
+sub RegisterFileForName($$$$)
+{
+ my $Type = shift;
+ my $Name = shift;
+ my $IsFuzzy = shift;
+ my $filename = shift;
+
##
- ## 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. Unicode 3.2 will assumedly correct this.
+ ## Now in details for the mapping. $Type eq 'Is' has the
+ ## Is removed, as it will be removed in utf8_heavy when this
+ ## data is being checked. In keeps its "In", but a second
+ ## sans-In record is written if it doesn't conflict with
+ ## anything already there.
##
- 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',
- );
-
- ## make the aliases....
- while (my ($Alias, $Name) = each %Is) {
- New_Alias(Is => $Alias, SameAs => $Name, Fuzzy => 1);
+ if (not $IsFuzzy)
+ {
+ if ($Type eq 'Is') {
+ die "oops[$Name]" if $Exact{$Name};
+ $Exact{$Name} = $filename;
+ } else {
+ die "oops[$Type$Name]" if $Exact{"$Type$Name"};
+ $Exact{"$Type$Name"} = $filename;
+ $Exact{$Name} = $filename if not $Exact{$Name};
+ }
+ }
+ else
+ {
+ my $CName = lc $Name;
+ if ($Type eq 'Is') {
+ die "oops[$CName]" if $Canonical{$CName};
+ $Canonical{$CName} = $filename;
+ $CaComment{$CName} = $Name if $Name =~ tr/A-Z// >= 2;
+ } else {
+ die "oops[$Type$CName]" if $Canonical{lc "$Type$CName"};
+ $Canonical{lc "$Type$CName"} = $filename;
+ $CaComment{lc "$Type$CName"} = "$Type$Name";
+ if (not $Canonical{$CName}) {
+ $Canonical{$CName} = $filename;
+ $CaComment{$CName} = "$Type$Name";
+ }
+ }
}
}
{
my @MAP;
- for my $Type ('In', 'Is')
+ ## 'Is' *MUST* come first, so its names have precidence over 'In's
+ for my $Type ('Is', 'In')
{
- my %Filenames;
- my %NameToFile;
+ my %RawNameToFile; ## a per-$Type cache
- my %Exact; ## will become %utf8::Is or %utf8::In
- my %Pat; ## will become %utf8::IsPat or %utf8::InPat
-
- ##
- ## First write all the files to the $Type/ directory
- ##
- for my $Name (sort { length $a <=> length $b } keys %{$TableInfo{$Type}})
+ for my $Name (sort {length $a <=> length $b} keys %{$TableInfo{$Type}})
{
+ ## Note: $Name is already canonical
my $Table = $TableInfo{$Type}->{$Name};
+ my $IsFuzzy = $FuzzyNames{$Type}->{$Name};
## Need an 8.3 safe filename (which means "an 8 safe" $filename)
- my $filename = $FuzzyNames{$Type}->{$Name} ? CanonicalName($Name): $Name;
- $filename =~ s/[^\w_]+/_/g; # "L&" -> "L_"
- substr($filename, 8) = '' if length($filename) > 8;
-
- ##
- ## Make sure the filename doesn't conflict with something we
- ## might have already written. If we have, say,
- ## GreekExtended1
- ## GreekExtended2
- ## they become
- ## GreekExt
- ## GreekEx2
- ##
- while (my $num = $Filenames{lc $filename}++)
+ my $filename;
{
- $num++; ## so filenames with numbers start with '2', which
- ## just looks more natural.
- ## Want to append $num, but if it'll make the filename longer
- ## than 8 characters, pre-truncate $filename so that the result
- ## is acceptable.
- my $delta = length($filename) + length($num) - 8;
- if ($delta > 0) {
- substr($filename, -$delta) = $num;
- } else {
- $filename .= $num;
+ ## 'Is' items lose 'Is' from the basename.
+ $filename = $Type eq 'Is' ?
+ ($PVA_reverse{sc}{$Name} || $Name) :
+ "$Type$Name";
+
+ $filename =~ s/[^\w_]+/_/g; # "L&" -> "L_"
+ substr($filename, 8) = '' if length($filename) > 8;
+
+ ##
+ ## Make sure the basename doesn't conflict with something we
+ ## might have already written. If we have, say,
+ ## InGreekExtended1
+ ## InGreekExtended2
+ ## they become
+ ## InGreekE
+ ## InGreek2
+ ##
+ while (my $num = $BaseNames{lc $filename}++)
+ {
+ $num++; ## so basenames with numbers start with '2', which
+ ## just looks more natural.
+ ## Want to append $num, but if it'll make the basename longer
+ ## than 8 characters, pre-truncate $filename so that the result
+ ## is acceptable.
+ my $delta = length($filename) + length($num) - 8;
+ if ($delta > 0) {
+ substr($filename, -$delta) = $num;
+ } else {
+ $filename .= $num;
+ }
}
- }
-
- $Exact{$Name} = $filename;
+ };
##
## Construct a nice comment to add to the file, and build data
for my $N (@Supported)
{
my $IsFuzzy = $FuzzyNames{$Type}->{$N};
- my $CName = $IsFuzzy ? CanonicalName($N): $N;
- my $Prop = "\\p{$TypeToShow$CName}";
+ my $Prop = "\\p{$TypeToShow$Name}";
$OrigProp = $Prop if not $OrigProp; #cache for aliases
if ($IsFuzzy) {
$Comment .= "\t$Prop (and fuzzy permutations)\n";
##
## Okay, write the file...
##
- $Table->Write("$Type/$filename.pl", $Comment);
- }
-
- ##
- ## Write out the map
- ##
- if (not open MAP, ">Properties") {
- die "$0: can't write Properties: $!\n";
- }
- print MAP "##\n";
- print MAP "## This file created by $0\n";
- print MAP "## List of built-in \\p{...}/\\P{...} properties.\n";
- print MAP "##\n";
- print MAP "## '*' means name may be 'fuzzy'\n";
- print MAP "##\n";
- print MAP "\n";
- print MAP sort { substr($a,2) cmp substr($b, 2) } @MAP;
- close MAP;
+ $Table->Write(["lib","gc_sc","$filename.pl"], $Comment);
- ##
- ## Build %Pat
- ##
- while (my ($Fuzzy, $Real) = each %{$FuzzyNames{$Type}})
- {
- my $File = $Exact{$Real};
+ ## and register it
+ $RawNameToFile{$Name} = $filename;
+ RegisterFileForName($Type => $Name, $IsFuzzy, $filename);
- if (not $File) {
- die "$0: oops [$Real]";
- }
-
- ## The prefix length of 2 is enough spread,
- ## and besides, we have 'Yi' as an In category.
- my $Prefix = lc(substr($Fuzzy, 0, 2));
- my $Regex = NameToRegex($Fuzzy);
-
- if ($Pat{$Prefix}->{$Regex}) {
- warn "WHOA, conflict with /$Regex/: $Pat{$Prefix}->{$Regex} vs $File\n";
+ if ($IsFuzzy)
+ {
+ my $CName = CanonicalName($Type . '_'. $Name);
+ $FuzzyNameToTest{$Name} = $Table if !$FuzzyNameToTest{$Name};
+ $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
+ } else {
+ $ExactNameToTest{$Name} = $Table;
}
- $Pat{$Prefix}->{$Regex} = $File;
}
- ##
- ## Since the fuzzy method will provide for a way to match $Fuzzy,
- ## there's no need for $Fuzzy to be in %Exact as well.
- ## This can't be done in the loop above because there could be
- ## multiple $Fuzzys pointing at the same $Real, and we don't want
- ## the first to delete the exact mapping out from under the second.
- ##
- for my $Fuzzy (keys %{$FuzzyNames{$Type}})
+ ## Register aliase info
+ for my $Name (sort {length $a <=> length $b} keys %{$AliasInfo{$Type}})
{
- delete $Exact{$Fuzzy};
+ my $Alias = $AliasInfo{$Type}->{$Name};
+ my $IsFuzzy = $FuzzyNames{$Type}->{$Alias};
+ my $filename = $RawNameToFile{$Name};
+ die "oops [$Alias]->[$Name]" if not $filename;
+ RegisterFileForName($Type => $Alias, $IsFuzzy, $filename);
+
+ my $Table = $TableInfo{$Type}->{$Name};
+ die "oops" if not $Table;
+ if ($IsFuzzy)
+ {
+ my $CName = CanonicalName($Type .'_'. $Alias);
+ $FuzzyNameToTest{$Alias} = $Table if !$FuzzyNameToTest{$Alias};
+ $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
+ } else {
+ $ExactNameToTest{$Alias} = $Table;
+ }
}
+ }
+ ##
+ ## Write out the property list
+ ##
+ {
+ my @OUT = (
+ "##\n",
+ "## This file created by $0\n",
+ "## List of built-in \\p{...}/\\P{...} properties.\n",
+ "##\n",
+ "## '*' means name may be 'fuzzy'\n",
+ "##\n\n",
+ sort { substr($a,2) cmp substr($b, 2) } @MAP,
+ );
+ WriteIfChanged('Properties', @OUT);
+ }
+ use Text::Tabs (); ## using this makes the files about half the size
- ##
- ## Now write In.pl / Is.pl
- ##
- if (not open OUT, ">$Type.pl") {
- die "$0: $Type.pl: $!\n";
- }
- print OUT $HEADER;
- print OUT "##\n";
- print OUT "## Data in this file used by ../utf8_heavy.pl\n";
- print OUT "##\n";
- print OUT "\n";
- print OUT "## Mapping from name to filename in ./$Type\n";
- print OUT "%utf8::$Type = (\n";
+ ## Write Exact.pl
+ {
+ my @OUT = (
+ $HEADER,
+ "##\n",
+ "## Data in this file used by ../utf8_heavy.pl\n",
+ "##\n\n",
+ "## Mapping from name to filename in ./lib/gc_sc\n",
+ "%utf8::Exact = (\n",
+ );
+
+ $Exact{InGreek} = 'InGreekA'; # this is evil kludge
for my $Name (sort keys %Exact)
{
my $File = $Exact{$Name};
- printf OUT " %-41s => %s,\n", "'$Name'", "'$File'";
+ $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
+ my $Text = sprintf("%-15s => %s,\n", $Name, qq/'$File'/);
+ push @OUT, Text::Tabs::unexpand($Text);
}
- print OUT ");\n\n";
+ push @OUT, ");\n1;\n";
+
+ WriteIfChanged('Exact.pl', @OUT);
+ }
- print OUT "## Mappings from regex to filename in ./$Type/\n";
- print OUT "%utf8::${Type}Pat = (\n";
- for my $Prefix (sort keys %Pat)
+ ## Write Canonical.pl
+ {
+ my @OUT = (
+ $HEADER,
+ "##\n",
+ "## Data in this file used by ../utf8_heavy.pl\n",
+ "##\n\n",
+ "## Mapping from lc(canonical name) to filename in ./lib\n",
+ "%utf8::Canonical = (\n",
+ );
+ my $Trail = ""; ## used just to keep the spacing pretty
+ for my $Name (sort keys %Canonical)
{
- print OUT " '$Prefix' => {\n";
- while (my ($Regex, $File) = each %{ $Pat{$Prefix} }) {
- print OUT "\t'$Regex' => '$File',\n";
+ my $File = $Canonical{$Name};
+ if ($CaComment{$Name}) {
+ push @OUT, "\n" if not $Trail;
+ push @OUT, " # $CaComment{$Name}\n";
+ $Trail = "\n";
+ } else {
+ $Trail = "";
}
- print OUT " },\n";
+ $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
+ my $Text = sprintf(" %-41s => %s,\n$Trail", $Name, qq/'$File'/);
+ push @OUT, Text::Tabs::unexpand($Text);
}
- print OUT ");\n";
-
- close(OUT);
+ push @OUT, ");\n1\n";
+ WriteIfChanged('Canonical.pl', @OUT);
}
+
+ MakePropTestScript() if $MakeTestScript;
}
-sub SpecCase_txt()
+
+sub SpecialCasing_txt()
{
#
# Read in the special cases.
my %CaseInfo;
- if (not open IN, "SpecCase.txt") {
- die "$0: SpecCase.txt: $!\n";
+ if (not open IN, "SpecialCasing.txt") {
+ die "$0: SpecialCasing.txt: $!\n";
}
while (<IN>) {
next unless /^[0-9A-Fa-f]+;/;
# Wait until all the special cases have been read since
# they are not listed in numeric order.
my $ix = hex($code);
- push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ];
- push @{$CaseInfo{Title}}, [ $ix, $code, $title ];
- push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ];
+ push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ]
+ unless $code eq $lower;
+ push @{$CaseInfo{Title}}, [ $ix, $code, $title ]
+ unless $code eq $title;
+ push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ]
+ unless $code eq $upper;
}
close IN;
for my $case (qw(Lower Title Upper))
{
my $NormalCase = do "To/$case.pl" || die "$0: $@\n";
- if (not open OUT, ">To/$case.pl") {
- die "$0: To/$case.txt: $!";
- }
- print OUT $HEADER, "\n";
- print OUT "%utf8::ToSpec$case =\n(\n";
+ my @OUT =
+ (
+ $HEADER, "\n",
+ "# The key UTF-8 _bytes_, the value UTF-8 (speed hack)\n",
+ "%utf8::ToSpec$case =\n(\n",
+ );
for my $prop (sort { $a->[0] <=> $b->[0] } @{$CaseInfo{$case}}) {
my ($ix, $code, $to) = @$prop;
my $tostr =
join "", map { sprintf "\\x{%s}", $_ } split ' ', $to;
- printf OUT qq['%04X' => "$tostr",\n], $ix;
+ push @OUT, sprintf qq["%s" => "$tostr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $ix)));
+ # Remove any single-character mappings for
+ # the same character since we are going for
+ # the special casing rules.
+ $NormalCase =~ s/^$code\t\t\w+\n//m;
}
- print OUT ");\n\n";
- print OUT "return <<'END';\n";
- print OUT $NormalCase;
- print OUT "END\n";
- close OUT;
+ push @OUT, (
+ ");\n\n",
+ "return <<'END';\n",
+ $NormalCase,
+ "END\n"
+ );
+ WriteIfChanged(["To","$case.pl"], @OUT);
}
}
#
# Read in the case foldings.
#
-# We will do full case folding, C + F + I (see CaseFold.txt).
+# We will do full case folding, C + F + I (see CaseFolding.txt).
#
-sub CaseFold_txt()
+sub CaseFolding_txt()
{
- if (not open IN, "CaseFold.txt") {
- die "$0: To/Fold.pl: $!\n";
+ if (not open IN, "CaseFolding.txt") {
+ die "$0: CaseFolding.txt: $!\n";
}
my $Fold = Table->New();
#
# Prepend the special foldings to the common foldings.
#
-
my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n";
- if (not open OUT, ">To/Fold.pl") {
- die "$0: To/Fold.pl: $!\n";
- }
- print OUT $HEADER, "\n";
- print OUT "%utf8::ToSpecFold =\n(\n";
+
+ my @OUT =
+ (
+ $HEADER, "\n",
+ "# The ke UTF-8 _bytes_, the value UTF-8 (speed hack)\n",
+ "%utf8::ToSpecFold =\n(\n",
+ );
for my $code (sort { $a <=> $b } keys %Fold) {
my $foldstr =
join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code};
- printf OUT qq['%04X' => "$foldstr",\n], $code;
+ push @OUT, sprintf qq["%s" => "$foldstr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $code)));
}
- print OUT ");\n\n";
- print OUT "return <<'END';\n";
- print OUT $CommonFold;
- print OUT "END\n";
- close OUT;
+ push @OUT, (
+ ");\n\n",
+ "return <<'END';\n",
+ $CommonFold,
+ "END\n",
+ );
+
+ WriteIfChanged(["To","Fold.pl"], @OUT);
}
## Do it....
-Unicode_Txt();
-Make_GC_Aliases();
+Build_Aliases();
+UnicodeData_Txt();
PropList_txt();
Scripts_txt();
Blocks_txt();
-LineBrk_Txt();
-ArabShap_txt();
+WriteAllMappings();
+
+LineBreak_Txt();
+ArabicShaping_txt();
+EastAsianWidth_txt();
+HangulSyllableType_txt();
Jamo_txt();
-SpecCase_txt();
+SpecialCasing_txt();
+CaseFolding_txt();
+
+if ( $FileList and $MakeList ) {
+
+ print "Updating '$FileList'\n"
+ if ($Verbose);
+
+ open my $ofh,">",$FileList
+ or die "Can't write to '$FileList':$!";
+ print $ofh <<"EOFHEADER";
+#
+# mktables.lst -- File list for mktables.
+#
+# Autogenerated on @{[scalar localtime]}
+#
+# - First section is input files
+# (mktables itself is automatically included)
+# - Section seperator is /^=+\$/
+# - Second section is a list of output files.
+# - Lines matching /^\\s*#/ are treated as comments
+# which along with blank lines are ignored.
+#
-WriteAllMappings();
+# Input files:
+
+EOFHEADER
+ my @input=("version",glob('*.txt'));
+ print $ofh "$_\n" for
+ @input,
+ "\n=================================\n",
+ "# Output files:\n",
+ # special files
+ "Properties";
+
+
+ require File::Find;
+ my $count=0;
+ File::Find::find({
+ no_chdir=>1,
+ wanted=>sub {
+ if (/\.pl$/) {
+ s!^\./!!;
+ print $ofh "$_\n";
+ $count++;
+ }
+ },
+ },".");
+
+ print $ofh "\n# ",scalar(@input)," input files\n",
+ "# ",scalar($count+1)," output files\n\n",
+ "# End list\n";
+ close $ofh
+ or warn "Failed to close $ofh: $!";
+
+ print "Filelist has ",scalar(@input)," input files and ",
+ scalar($count+1)," output files\n"
+ if $Verbose;
+}
+print "All done\n" if $Verbose;
+exit(0);
-CaseFold_txt();
+## TRAILING CODE IS USED BY MakePropTestScript()
+__DATA__
+use strict;
+use warnings;
-# That's all, folks!
+my $Tests = 0;
+my $Fails = 0;
-__END__
+sub Expect($$$)
+{
+ my $Expect = shift;
+ my $String = shift;
+ my $Regex = shift;
+ my $Line = (caller)[2];
+
+ $Tests++;
+ my $RegObj;
+ my $result = eval {
+ $RegObj = qr/$Regex/;
+ $String =~ $RegObj ? 1 : 0
+ };
+
+ if (not defined $result) {
+ print "couldn't compile /$Regex/ on $0 line $Line: $@\n";
+ $Fails++;
+ } elsif ($result ^ $Expect) {
+ print "bad result (expected $Expect) on $0 line $Line: $@\n";
+ $Fails++;
+ }
+}
+
+sub Error($)
+{
+ my $Regex = shift;
+ $Tests++;
+ if (eval { 'x' =~ qr/$Regex/; 1 }) {
+ $Fails++;
+ my $Line = (caller)[2];
+ print "expected error for /$Regex/ on $0 line $Line: $@\n";
+ }
+}
+
+sub Finished()
+{
+ if ($Fails == 0) {
+ print "All $Tests tests passed.\n";
+ exit(0);
+ } else {
+ print "$Tests tests, $Fails failed!\n";
+ exit(-1);
+ }
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff