#!/usr/bin/perl -w
use strict;
use Carp;
+
##
## 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);
+mkdir("lib", 0755);
+mkdir("To", 0755);
##
## Process any args.
##
-my $Verbose = 0;
+my $Verbose = 0;
+my $MakeTestScript = 0;
while (@ARGV)
{
$Verbose = 1;
} elsif ($arg eq '-q') {
$Verbose = 0;
+ } elsif ($arg eq '-maketest') {
+ $MakeTestScript = 1;
} else {
- die "usage: $0 [-v|-q]";
+ die "usage: $0 [-v|-q] [-maketest]";
}
}
my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 3.1.1.
-my $now = localtime;
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!
-# Built $now.
EOF
+
+##
+## Given a filename and a reference to an array of lines,
+## write the lines to the file only if the contents have not changed.
+##
+sub WriteIfChanged($\@)
+{
+ my $file = shift;
+ my $lines = shift;
+
+ 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;
+ }
+ }
+ 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},
sub RANGE_END() { 1 } ## index into range element
sub RANGE_NAME() { 2 } ## index into range element
+## Conceptually, these should really be folded into the 'Table' objects
my %TableInfo;
+my %TableDesc;
my %FuzzyNames;
my %AliasInfo;
+my %CanonicalToOrig;
+
+##
+## Turn something like
+## OLD-ITALIC
+## into
+## OldItalic
+##
+sub CanonicalName($)
+{
+ my $orig = shift;
+ my $name = lc $orig;
+ $name =~ s/(?<![a-z])(\w)/\u$1/g;
+ $name =~ s/[-_\s]+//g;
+
+ $CanonicalToOrig{$name} = $orig if not $CanonicalToOrig{$name};
+ return $name;
+}
##
## Associates a property ("Greek", "Lu", "Assigned",...) with a Table.
##
## Called like:
-## New_Prop(In => 'Greek', $Table, AllowFuzzy => 1);
+## New_Prop(In => 'Greek', $Table, Desc => 'Greek Block', Fuzzy => 1);
##
## Normally, these parameters are set when the Table is created (when the
## Table->New constructor is called), but there are times when it needs to
## remaining args are optional key/val
my %Args = @_;
- my $AllowFuzzy = delete $Args{AllowFuzzy};
+ my $Fuzzy = delete $Args{Fuzzy};
+ my $Desc = delete $Args{Desc}; # description
+
+ $Name = CanonicalName($Name) if $Fuzzy;
## sanity check a few args
if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) {
if (not $TableInfo{$Type}->{$Name})
{
$TableInfo{$Type}->{$Name} = $Table;
- if ($AllowFuzzy) {
+ $TableDesc{$Type}->{$Name} = $Desc;
+ if ($Fuzzy) {
$FuzzyNames{$Type}->{$Name} = $Name;
}
}
## Creates a new Table object.
##
## Args are key/value pairs:
-## In => Name -- Name of "In" property to be associated with
-## Is => Name -- Name of "Is" property to be associated with
-## AllowFuzzy => Boolean -- True if name can be accessed "fuzzily"
+## In => Name -- Name of "In" property to be associated with
+## Is => Name -- Name of "Is" property to be associated with
+## Fuzzy => Boolean -- True if name can be accessed "fuzzily"
+## Desc => String -- Description of the property
##
## No args are required.
##
my $Table = bless [], $class;
- my $AllowFuzzy = delete $Args{AllowFuzzy};
+ my $Fuzzy = delete $Args{Fuzzy};
+ my $Desc = delete $Args{Desc};
for my $Type ('Is', 'In')
{
if (my $Name = delete $Args{$Type}) {
- New_Prop($Type => $Name, $Table, AllowFuzzy => $AllowFuzzy);
+ New_Prop($Type => $Name, $Table, Desc => $Desc, Fuzzy => $Fuzzy);
}
}
## Merges any number of other tables with $self, returning the new table.
## (existing tables are not modified)
##
+##
+## Args may be Tables, or individual code points (as integers).
+##
## Can be called as either a constructor or a method.
##
sub Table::Merge
## Accumulate all records from all tables
my @Records;
- for my $Table (@Tables) {
- push @Records, @$Table;
+ for my $Arg (@Tables)
+ {
+ if (ref $Arg) {
+ ## arg is a table -- get its ranges
+ push @Records, @$Arg;
+ } else {
+ ## arg is a codepoint, make a range
+ push @Records, [ $Arg, $Arg ]
+ }
}
## sort by range start, with longer ranges coming first.
##
## Given a filename, write a representation of the Table to a file.
+## May have an optional comment as a 2nd arg.
##
sub Table::Write
{
- my $Table = shift; #self
+ my $Table = shift; #self
my $filename = shift;
+ my $comment = shift;
- print "$filename\n" if $Verbose;
-
- if (not open(OUT, ">$filename")) {
- die "$0: can't write $filename: $!\n";
+ my @OUT = $HEADER;
+ if (defined $comment) {
+ $comment =~ s/\s+\Z//;
+ $comment =~ s/^/# /gm;
+ push @OUT, "#\n$comment\n#\n";
}
-
- print OUT $HEADER;
- 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 $Table->IsEmpty();
+
+ 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 ();
}
###########################################################################
##
## Called like:
-## New_Alias(Is => 'All', SameAs => 'Any', AllowFuzzy => 1);
+## New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 1);
##
-## The args must be in that order, although the AllowFuzzy pair may be omitted.
+## The args must be in that order, although the Fuzzy pair may be omitted.
##
## This creates 'IsAll' as an alias for 'IsAny'
##
{
my $Type = shift; ## "Is" or "In"
my $Alias = shift;
- my $SameAs = shift;
+ my $SameAs = shift; # expecting "SameAs" -- just ignored
my $Name = shift;
## remaining args are optional key/val
my %Args = @_;
- my $AllowFuzzy = delete $Args{AllowFuzzy};
+ my $Fuzzy = delete $Args{Fuzzy};
## sanity check a few args
if (%Args or ($Type ne 'Is' and $Type ne 'In') or $SameAs ne 'SameAs') {
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 orignial $Type => $Name to make alias";
+ }
}
if ($TableInfo{$Alias}) {
confess "$0: already have original $Type => $Alias; can't make alias";
}
$AliasInfo{$Type}->{$Name} = $Alias;
- if ($AllowFuzzy) {
+ if ($Fuzzy) {
$FuzzyNames{$Type}->{$Alias} = $Name;
}
}
-##
-## Turn something like
-## OLD-ITALIC
-## to
-## Old_Italic
-##
-sub CanonicalName($)
-{
- my $name = lc shift;
- $name =~ s/\W+/_/;
- $name =~ s/(?<![a-z])(\w)/\u$1/g;
- return $name;
-}
-
## All assigned code points
-my $Assigned = Table->New(Is => 'Assigned', AllowFuzzy => 1);
+my $Assigned = Table->New(Is => 'Assigned',
+ Desc => "All assigned code points",
+ Fuzzy => 0);
my $Name = Table->New(); ## all characters, individually by name
my $General = Table->New(); ## all characters, grouped by category
my %Cat;
##
-## 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', AllowFuzzy => 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', AllowFuzzy => 0);
- $Deco{Compat} = Table->New(Is => 'Compat', AllowFuzzy => 0);
+ $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);
## Initialize Perl-generated categories
- $Cat{Alnum} = Table->New(Is => 'Alnum', AllowFuzzy => 0);
- $Cat{Alpha} = Table->New(Is => 'Alpha', AllowFuzzy => 0);
- $Cat{ASCII} = Table->New(Is => 'ASCII', AllowFuzzy => 0);
- $Cat{Blank} = Table->New(Is => 'Blank', AllowFuzzy => 0);
- $Cat{Cntrl} = Table->New(Is => 'Cntrl', AllowFuzzy => 0);
- $Cat{Digit} = Table->New(Is => 'Digit', AllowFuzzy => 0);
- $Cat{Graph} = Table->New(Is => 'Graph', AllowFuzzy => 0);
- $Cat{Lower} = Table->New(Is => 'Lower', AllowFuzzy => 0);
- $Cat{Print} = Table->New(Is => 'Print', AllowFuzzy => 0);
- $Cat{Punct} = Table->New(Is => 'Punct', AllowFuzzy => 0);
- $Cat{SpacePerl} = Table->New(Is => 'SpacePerl', AllowFuzzy => 0);
- $Cat{Space} = Table->New(Is => 'Space', AllowFuzzy => 0);
- $Cat{Title} = Table->New(Is => 'Title', AllowFuzzy => 0);
- $Cat{Upper} = Table->New(Is => 'Upper', AllowFuzzy => 0);
- $Cat{Word} = Table->New(Is => 'Word' , AllowFuzzy => 0);
- $Cat{XDigit} = Table->New(Is => 'XDigit', AllowFuzzy => 0);
- ## Categories from Unicode.txt are auto-initialized in gencat()
+ ## (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->$op($code, $cat);
## add to the sub category (e.g. "Lu", "Nd", "Cf", ..)
- $Cat{$cat} ||= Table->New(Is => $cat, AllowFuzzy => 0);
+ $Cat{$cat} ||= Table->New(Is => $cat,
+ Desc => "General Category '$cat'",
+ Fuzzy => 0);
$Cat{$cat}->$op($code);
## add to the major category (e.g. "L", "N", "C", ...)
- $Cat{$MajorCat} ||= Table->New(Is => $MajorCat, AllowFuzzy => 0);
+ $Cat{$MajorCat} ||= Table->New(Is => $MajorCat,
+ Desc => "Major Category '$MajorCat'",
+ Fuzzy => 0);
$Cat{$MajorCat}->$op($code);
($General{$name} ||= Table->New)->$op($code, $name);
}
## 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";
}
+ ##
+ ## For building \p{_CombAbove} and \p{_CanonDCIJ}
+ ##
+ my %_Above_HexCodes; ## Hexcodes for chars with $comb == 230 ("ABOVE")
+
+ my %CodeToDeco; ## Maps code to decomp. list for chars with first
+ ## decomp. char an "i" or "j" (for \p{_CanonDCIJ})
+
+ ## This is filled in as we go....
+ my $CombAbove = Table->New(Is => '_CombAbove',
+ Desc => '(for internal casefolding use)',
+ Fuzzy => 0);
+
while (<IN>)
{
next unless /^[0-9A-Fa-f]+;/;
$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) {
+ $CombAbove->Append($code);
+ $_Above_HexCodes{$hexcode} = 1;
+ }
+
+ ## Used in building \p{_CanonDCIJ}
+ if ($deco and $deco =~ m/^006[9A]\b/) {
+ $CodeToDeco{$code} = $deco;
+ }
+
##
## There are a few pairs of lines like:
## AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;;
{
$name = $1;
gencat($name, $cat, $code, $2 eq 'First' ? 'Append' : 'Extend');
- #New_Prop(In => $name, $General{$name}, AllowFuzzy => 1);
+ #New_Prop(In => $name, $General{$name}, Fuzzy => 1);
}
else
{
$Mirrored->Append($code) if $mirrored eq "Y";
- $Bidi{$bidi} ||= Table->New(Is => "Bidi$bidi", AllowFuzzy => 0);
+ $Bidi{$bidi} ||= Table->New(Is => "Bidi$bidi",
+ Desc => "Bi-directional category '$bidi'",
+ Fuzzy => 0);
$Bidi{$bidi}->Append($code);
if ($deco)
{
$Deco{Compat}->Append($code);
- $DC{$1} ||= Table->New(Is => "DC$1", AllowFuzzy => 0);
+ $DC{$1} ||= Table->New(Is => "DC$1",
+ Desc => "Compatible with '$1'",
+ Fuzzy => 0);
$DC{$1}->Append($code);
}
else
##
$Cat{Cn} = $Assigned->Invert; ## Cn is everything that doesn't exist
- New_Prop(Is => 'Cn', $Cat{Cn}, AllowFuzzy => 0);
+ New_Prop(Is => 'Cn',
+ $Cat{Cn},
+ Desc => "General Category 'Cn' [not functional in Perl]",
+ Fuzzy => 0);
## Unassigned is the same as 'Cn'
- New_Alias(Is => 'Unassigned', SameAs => 'Cn', AllowFuzzy => 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&',
Table->Merge(@Cat{qw[Ll Lu Lt]}),
- AllowFuzzy => 0);
+ Desc => '[\p{Ll}\p{Lu}\p{Lt}]',
+ Fuzzy => 0);
## Any and All are all code points.
- my $Any = Table->New(Is => 'Any', AllowFuzzy => 1);
+ my $Any = Table->New(Is => 'Any',
+ Desc => sprintf("[\\x{0000}-\\x{%X}]",
+ $LastUnicodeCodepoint),
+ Fuzzy => 0);
$Any->RawAppendRange(0, $LastUnicodeCodepoint);
- New_Alias(Is => 'All', SameAs => 'Any', AllowFuzzy => 1);
+ New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 0);
+
+ ##
+ ## Build special properties for Perl's internal case-folding needs:
+ ## \p{_CaseIgnorable}
+ ## \p{_CanonDCIJ}
+ ## \p{_CombAbove}
+ ## _CombAbove was built above. Others are built here....
+ ##
+
+ ## \p{_CaseIgnorable} is [\p{Mn}\0x00AD\x2010]
+ New_Prop(Is => '_CaseIgnorable',
+ Table->Merge($Cat{Mn},
+ 0x00AD, #SOFT HYPHEN
+ 0x2010), #HYPHEN
+ Desc => '(for internal casefolding use)',
+ Fuzzy => 0);
+
+
+ ## \p{_CanonDCIJ} is fairly complex...
+ my $CanonCDIJ = Table->New(Is => '_CanonDCIJ',
+ Desc => '(for internal casefolding use)',
+ Fuzzy => 0);
+ ## It contains the ASCII 'i' and 'j'....
+ $CanonCDIJ->Append(0x0069); # ASCII ord("i")
+ $CanonCDIJ->Append(0x006A); # ASCII ord("j")
+ ## ...and any character with a decomposition that starts with either of
+ ## those code points, but only if the decomposition does not have any
+ ## combining character with the "ABOVE" canonical combining class.
+ for my $code (sort { $a <=> $b} keys %CodeToDeco)
+ {
+ ## Need to ensure that all decomposition characters do not have
+ ## a %HexCodeToComb in %AboveCombClasses.
+ my $want = 1;
+ for my $deco_hexcode (split / /, $CodeToDeco{$code})
+ {
+ if (exists $_Above_HexCodes{$deco_hexcode}) {
+ ## one of the decmposition chars has an ABOVE combination
+ ## class, so we're not interested in this one
+ $want = 0;
+ last;
+ }
+ }
+ if ($want) {
+ $CanonCDIJ->Append($code);
+ }
+ }
+
##
}
##
-## 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", AllowFuzzy => 0);
+ $Lbrk{$lbrk} ||= Table->New(Is => "Lbrk$lbrk",
+ Desc => "Linebreak category '$lbrk'",
+ Fuzzy => 0);
$Lbrk{$lbrk}->Append($first);
if ($last) {
}
##
-## 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 ($first, $last, $name) = @$script;
$Scripts->Append($first, $name);
- $Script{$name} ||= Table->New(Is => CanonicalName($name),
- AllowFuzzy => 1);
+ $Script{$name} ||= Table->New(Is => $name,
+ Desc => "Script '$name'",
+ Fuzzy => 1);
$Script{$name}->Append($first, $name);
if ($last) {
##
## ***shouldn't this be intersected with \p{Assigned}? ******
##
- New_Prop(Is => 'Common', $Scripts->Invert, AllowFuzzy => 1);
+ New_Prop(Is => 'Common',
+ $Scripts->Invert,
+ Desc => 'Pseudo-Script of codepoints not in other Unicode scripts',
+ Fuzzy => 1);
}
##
$Blocks->Append($first, $name);
- $Blocks{$name} ||= Table->New(In=>CanonicalName($name), AllowFuzzy=>1);
+ $Blocks{$name} ||= Table->New(In => $name,
+ Desc => "Block '$name'",
+ Fuzzy => 1);
$Blocks{$name}->Append($first, $name);
if ($last and $last != $first) {
##
## 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.
my ($first, $last, $name) = @$prop;
$Props->Append($first, $name);
- $Prop{$name} ||= Table->New(Is => $name, AllowFuzzy => 1);
+ $Prop{$name} ||= Table->New(Is => $name,
+ Desc => "Extended property '$name'",
+ Fuzzy => 1);
$Prop{$name}->Append($first, $name);
if ($last) {
}
# Alphabetic is L and Other_Alphabetic.
- New_Prop(Is => 'Alphabetic',
+ New_Prop(Is => 'Alphabetic',
Table->Merge($Cat{L}, $Prop{Other_Alphabetic}),
- AllowFuzzy => 1);
+ Desc => '[\p{L}\p{OtherAlphabetic}]', # use canonical names here
+ Fuzzy => 1);
# Lowercase is Ll and Other_Lowercase.
- New_Prop(Is => 'Lowercase',
+ New_Prop(Is => 'Lowercase',
Table->Merge($Cat{Ll}, $Prop{Other_Lowercase}),
- AllowFuzzy => 1);
+ Desc => '[\p{Ll}\p{OtherLowercase}]', # use canonical names here
+ Fuzzy => 1);
# Uppercase is Lu and Other_Uppercase.
New_Prop(Is => 'Uppercase',
Table->Merge($Cat{Lu}, $Prop{Other_Uppercase}),
- AllowFuzzy => 1);
+ Desc => '[\p{Lu}\p{Other_Uppercase}]', # use canonical names here
+ Fuzzy => 1);
# Math is Sm and Other_Math.
New_Prop(Is => 'Math',
Table->Merge($Cat{Sm}, $Prop{Other_Math}),
- AllowFuzzy => 1);
+ Desc => '[\p{Sm}\p{OtherMath}]', # use canonical names here
+ Fuzzy => 1);
# ID_Start is Ll, Lu, Lt, Lm, Lo, and Nl.
New_Prop(Is => 'ID_Start',
Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl]}),
- AllowFuzzy => 1);
+ Desc => '[\p{Ll}\p{Lu}\p{Lt}\p{Lm}\p{Lo}\p{Nl}]',
+ Fuzzy => 1);
# ID_Continue is ID_Start, Mn, Mc, Nd, and Pc.
New_Prop(Is => 'ID_Continue',
Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl Mn Mc Nd Pc ]}),
- AllowFuzzy => 1);
+ Desc => '[\p{ID_Start}\p{Mn}\p{Mc}\p{Nd}\p{Pc}]',
+ Fuzzy => 1);
}
sub Make_GC_Aliases()
## make the aliases....
while (my ($Alias, $Name) = each %Is) {
- New_Alias(Is => $Alias, SameAs => $Name, AllowFuzzy => 1);
+ New_Alias(Is => $Alias, SameAs => $Name, Fuzzy => 1);
+ }
+}
+
+
+##
+## 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.
+ 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;
+
+ ##
+ ## 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.
+ ##
+ 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";
+ }
+ }
}
}
##
sub WriteAllMappings()
{
- for my $Type ('In', 'Is')
- {
- my %Filenames;
- my %NameToFile;
+ my @MAP;
- my %Exact; ## will become %utf8::Is or %utf8::In
- my %Pat; ## will become %utf8::IsPat or %utf8::InPat
+ my %BaseNames; ## Base names already used (for avoiding 8.3 conflicts)
- ##
- ## First write all the files to the $Type/ directory
- ##
- while (my ($Name, $Table) = each %{$TableInfo{$Type}})
+ ## 'Is' *MUST* come first, so its names have precidence over 'In's
+ for my $Type ('Is', 'In')
+ {
+ my %RawNameToFile; ## a per-$Type cache
+
+ for my $Name (sort {length $a <=> length $b} keys %{$TableInfo{$Type}})
{
- ## Need an 8.3 safe filename.
- my $filename = $Name;
- $filename =~ s/[_\W]+(\w*)/\u$1/g;
- substr($filename, 8) = '' if length($filename) > 8;
+ ## Note: $Name is already canonical
+ my $Table = $TableInfo{$Type}->{$Name};
+ my $IsFuzzy = $FuzzyNames{$Type}->{$Name};
- ##
- ## Make sure the filename doesn't conflict with something we
- ## might have already written. If we have, say,
- ## Greek_Extended1
- ## Greek_Extended2
- ## they become
- ## Greek_Ex
- ## Greek_E2
- ##
- while (my $num = $Filenames{lc $filename}++)
+ ## Need an 8.3 safe filename (which means "an 8 safe" $filename)
+ my $filename;
{
- $num++; ## so filenames with numbers start with '2', which
- ## just looks more natural.
- substr($filename, -length($num)) = $num;
- }
+ ## 'Is' items lose 'Is' from the basename.
+ $filename = $Type eq 'Is' ? $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;
+ }
+ }
+ };
##
- ## Okay, write the file...
+ ## Construct a nice comment to add to the file, and build data
+ ## for the "./Properties" file along the way.
##
- $Exact{$Name} = $filename;
- $Table->Write("$Type/$filename.pl");
- }
+ 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;
+ }
+ }
- ##
- ## Build %Pat
- ##
- while (my ($Fuzzy, $Real) = each %{$FuzzyNames{$Type}})
- {
- my $File = $Exact{$Real};
+ 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";
+ }
- if (not $File) {
- die "$0: oops [$Real]";
}
+ ##
+ ## Okay, write the file...
+ ##
+ $Table->Write("lib/$filename.pl", $Comment);
- ## 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);
+ ## and register it
+ $RawNameToFile{$Name} = $filename;
+ RegisterFileForName($Type => $Name, $IsFuzzy, $filename);
- 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
+
+ ## 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\n",
+ "%utf8::Exact = (\n",
+ );
- ##
- ## 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";
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";
- print OUT "## Mappings from regex to filename in ./$Type/\n";
- print OUT "%utf8::${Type}Pat = (\n";
- for my $Prefix (sort keys %Pat)
+ 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)
{
- 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",
+ "%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['%04X' => "$tostr",\n], $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",
+ "%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['%04X' => "$foldstr",\n], $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();
+UnicodeData_Txt();
Make_GC_Aliases();
PropList_txt();
Scripts_txt();
Blocks_txt();
-LineBrk_Txt();
-ArabShap_txt();
+WriteAllMappings();
+
+LineBreak_Txt();
+ArabicShaping_txt();
Jamo_txt();
-SpecCase_txt();
+SpecialCasing_txt();
+CaseFolding_txt();
-WriteAllMappings();
+exit(0);
-CaseFold_txt();
+## 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++;
+ }
+}
-# That's all, folks!
+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";
+ }
+}
-__END__
+sub Finished()
+{
+ if ($Fails == 0) {
+ print "All $Tests tests passed.\n";
+ exit(0);
+ } else {
+ print "$Tests tests, $Fails failed!\n";
+ exit(-1);
+ }
+}
https://perl5.git.perl.org / perl5.git / blobdiff