mktables

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

            {
                ## '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;
                    }
                }
            };

            ##
            ## Construct a nice comment to add to the file, and build data
            ## for the "./Properties" file along the way.
            ##
            my $Comment;
            {
                my $Desc = $TableDesc{$Type}->{$Name} || "";
                ## get list of names this table is reference by
                my @Supported = $Name;
                while (my ($Orig, $Alias) = each %{ $AliasInfo{$Type} })
                {
                    if ($Orig eq $Name) {
                        push @Supported, $Alias;
                    }
                }

                my $TypeToShow = $Type eq 'Is' ? "" : $Type;
                my $OrigProp;

                $Comment = "This file supports:\n";
                for my $N (@Supported)
                {
                    my $IsFuzzy = $FuzzyNames{$Type}->{$N};
                    my $Prop    = "\\p{$TypeToShow$Name}";
                    $OrigProp = $Prop if not $OrigProp; #cache for aliases
                    if ($IsFuzzy) {
                        $Comment .= "\t$Prop (and fuzzy permutations)\n";
                    } else {
                        $Comment .= "\t$Prop\n";
                    }
                    my $MyDesc = ($N eq $Name) ? $Desc : "Alias for $OrigProp ($Desc)";

                    push @MAP, sprintf("%s %-42s %s\n",
                                       $IsFuzzy ? '*' : ' ', $Prop, $MyDesc);
                }
                if ($Desc) {
                    $Comment .= "\nMeaning: $Desc\n";
                }

            }
            ##
            ## Okay, write the file...
            ##
            $Table->Write(["lib","gc_sc","$filename.pl"], $Comment);

            ## and register it
            $RawNameToFile{$Name} = $filename;
            RegisterFileForName($Type => $Name, $IsFuzzy, $filename);

            if ($IsFuzzy)
            {
                my $CName = CanonicalName($Type . '_'. $Name);
                $FuzzyNameToTest{$Name}  = $Table if !$FuzzyNameToTest{$Name};
                $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName};
            } else {
                $ExactNameToTest{$Name} = $Table;
            }

        }

        ## Register aliase info
        for my $Name (sort {length $a <=> length $b} keys %{$AliasInfo{$Type}})
        {
            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

    ## 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};
            $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
            my $Text = sprintf("%-15s => %s,\n", $Name, qq/'$File'/);
            push @OUT, Text::Tabs::unexpand($Text);
        }
        push @OUT, ");\n1;\n";

        WriteIfChanged('Exact.pl', @OUT);
    }

    ## 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)
        {
            my $File = $Canonical{$Name};
            if ($CaComment{$Name}) {
                push @OUT, "\n" if not $Trail;
                push @OUT, " # $CaComment{$Name}\n";
                $Trail = "\n";
            } else {
                $Trail = "";
            }
            $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name ";
            my $Text = sprintf("  %-41s => %s,\n$Trail", $Name, qq/'$File'/);
            push @OUT, Text::Tabs::unexpand($Text);
        }
        push @OUT, ");\n1\n";
        WriteIfChanged('Canonical.pl', @OUT);
    }

    MakePropTestScript() if $MakeTestScript;
}


sub SpecialCasing_txt()
{
    #
    # Read in the special cases.
    #

    my %CaseInfo;

    if (not open IN, "SpecialCasing.txt") {
        die "$0: SpecialCasing.txt: $!\n";
    }
    while (<IN>) {
        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" if $Verbose;
            next;
        }

        # 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 ]
	    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;

    # 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: $@\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;
            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;
        }
        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 CaseFolding.txt).
#
sub CaseFolding_txt()
{
    if (not open IN, "CaseFolding.txt") {
	die "$0: CaseFolding.txt: $!\n";
    }

    my $Fold = Table->New();
    my %Fold;

    while (<IN>) {
	# Skip status 'S', simple case folding
	next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/;

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

	if ($status eq 'C') { # Common: one-to-one folding
	    # No append() since several codes may fold into one.
	    $Fold->RawAppendRange($code, $code, $fold);
	} else { # F: full, or I: dotted uppercase I -> dotless lowercase I
	    $Fold{$code} = $fold;
	}
    }
    close IN;

    $Fold->Write("To/Fold.pl");

    #
    # Prepend the special foldings to the common foldings.
    #
    my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\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};
        push @OUT, sprintf qq["%s" => "$foldstr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $code)));
    }
    push @OUT, (
                ");\n\n",
                "return <<'END';\n",
                $CommonFold,
                "END\n",
               );

    WriteIfChanged(["To","Fold.pl"], @OUT);
}

## Do it....

Build_Aliases();
UnicodeData_Txt();
PropList_txt();

Scripts_txt();
Blocks_txt();

WriteAllMappings();

LineBreak_Txt();
ArabicShaping_txt();
EastAsianWidth_txt();
HangulSyllableType_txt();
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()
__DATA__
use strict;
use warnings;

my $Tests = 0;
my $Fails = 0;

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);
   }
}