Upgrade to CPAN-1.88_53.
[p5sagit/p5-mst-13.2.git] / lib / unicore / mktables
index 28f0948..006b9ef 100644 (file)
@@ -1,3 +1,6 @@
+## !!!!!!!!!!!!!!       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;
@@ -19,22 +22,18 @@ use File::Spec;
 ##    whereby the case distinctions, whitespace, hyphens, and underbar
 ##    are ignored.
 
-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': $!";
-}
-
 ## Base names already used in lib/gc_sc (for avoiding 8.3 conflicts)
 my %BaseNames;
 
-
 ##
 ## Process any args.
 ##
 my $Verbose        = 0;
 my $MakeTestScript = 0;
+my $AlwaysWrite    = 0;
+my $UseDir         = "";
+my $FileList       = "$0.lst";
+my $MakeList       = 0;
 
 while (@ARGV)
 {
@@ -43,11 +42,114 @@ 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] [-maketest]";
+        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.
@@ -87,7 +189,7 @@ sub WriteIfChanged($\@)
         close IN;
         if ($PreviousText eq $TextToWrite) {
             print "$file unchanged.\n" if $Verbose;
-            return;
+            return unless $AlwaysWrite;
         }
     }
     force_unlink ($file);
@@ -152,10 +254,15 @@ sub Build_Aliases()
 {
     ##
     ## Most of the work with aliases doesn't occur here,
-    ## but rather in utf8_heavy.pl, which uses utf8_pva.pl,
-    ## which contains just this function.  However, this one
-    ## 
-    ##   -- japhy (2004/04/13)
+    ## 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: $!";
@@ -168,6 +275,12 @@ sub Build_Aliases()
         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;
 
@@ -189,8 +302,23 @@ sub Build_Aliases()
            $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};
+
 }
 
 
@@ -270,32 +398,15 @@ sub Table::New
     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];
 }
 
 ##
@@ -314,6 +425,8 @@ sub Table::Replace($$)
 ## 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
@@ -323,7 +436,21 @@ sub Table::Extend
 
     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];
 }
 
 ##
@@ -361,13 +488,14 @@ sub Table::Append
     ## 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
     {
@@ -465,7 +593,7 @@ sub Table::Merge
         if ($start > $New->Max) {
             $New->AppendRange($start, $end);
         } elsif ($end > $New->Max) {
-            $New->Extend($end);
+            $New->ExtendNoCheck($end);
         }
     }
 
@@ -542,7 +670,7 @@ sub Table::InvalidCode
 {
     my $Table = shift; #self
 
-    return 0x1234 if $Table->IsEmpty();
+    return 0x1234 if not @$Table;
 
     for my $set (@$Table)
     {
@@ -621,6 +749,33 @@ 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 UnicodeData.txt (Categories, etc.)
 ##
@@ -957,6 +1112,19 @@ sub UnicodeData_Txt()
     ##
     $Name->Write("Name.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(
@@ -1097,14 +1265,18 @@ sub EastAsianWidth_txt()
 
     while (<IN>)
     {
-       next unless /^[0-9A-Fa-f]+;/;
+       next unless /^[0-9A-Fa-f]+(\.\.[0-9A-Fa-f]+)?;/;
        s/#.*//;
        s/\s+$//;
 
-       my ($hexcode, $pv) = split(/\s*;\s*/);
-        my $code = hex($hexcode);
+       my ($hexcodes, $pv) = split(/\s*;\s*/);
         $EAW{$pv} ||= Table->New(Is => "EastAsianWidth$pv");
-        $EAW{$pv}->Append($code);
+      my ($start, $end) = split(/\.\./, $hexcodes);
+      if (defined $end) {
+        $EAW{$pv}->AppendRange(hex($start), hex($end));
+      } else {
+        $EAW{$pv}->Append(hex($start));
+      }
     }
     close IN;
 
@@ -1920,6 +2092,63 @@ Jamo_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.
+#
+
+# 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);
 
 ## TRAILING CODE IS USED BY MakePropTestScript()