summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Unicode/Collate.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-11-20 18:08:54 +0000
committerKarl Berry <karl@freefriends.org>2012-11-20 18:08:54 +0000
commitc5add2ea5067382269ae6f19e345fda0b9a7bd21 (patch)
tree02f512fda46d93079c9dc59c0d76f0e398150f83 /Master/tlpkg/tlperl/lib/Unicode/Collate.pm
parent6c35e87bdc5a3f64833dbbc42e7d42e683db9d5b (diff)
perl 5.16.2, compiled without optimization for Windows (from siep)
git-svn-id: svn://tug.org/texlive/trunk@28315 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Unicode/Collate.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Unicode/Collate.pm190
1 files changed, 133 insertions, 57 deletions
diff --git a/Master/tlpkg/tlperl/lib/Unicode/Collate.pm b/Master/tlpkg/tlperl/lib/Unicode/Collate.pm
index 0c9646f77a9..da362c15b43 100644
--- a/Master/tlpkg/tlperl/lib/Unicode/Collate.pm
+++ b/Master/tlpkg/tlperl/lib/Unicode/Collate.pm
@@ -14,12 +14,14 @@ use File::Spec;
no warnings 'utf8';
-our $VERSION = '0.73';
+our $VERSION = '0.89';
our $PACKAGE = __PACKAGE__;
+### begin XS only ###
require DynaLoader;
our @ISA = qw(DynaLoader);
bootstrap Unicode::Collate $VERSION;
+### end XS only ###
my @Path = qw(Unicode Collate);
my $KeyFile = "allkeys.txt";
@@ -69,6 +71,7 @@ use constant LEVEL_SEP => "\0\0";
# This character must not be included in any stringified
# representation of an integer.
use constant CODE_SEP => ';';
+ # NOTE: in regex /;/ is used for $jcps!
# boolean values of variable weights
use constant NON_VAR => 0; # Non-Variable character
@@ -81,9 +84,9 @@ use constant Hangul_SFin => 0xD7A3;
# Logical_Order_Exception in PropList.txt
my $DefaultRearrange = [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ];
-sub UCA_Version { "22" }
+sub UCA_Version { "24" }
-sub Base_Unicode_Version { "6.0.0" }
+sub Base_Unicode_Version { "6.1.0" }
######
@@ -100,19 +103,19 @@ my (%VariableOK);
our @ChangeOK = qw/
alternate backwards level normalization rearrange
- katakana_before_hiragana upper_before_lower
+ katakana_before_hiragana upper_before_lower ignore_level2
overrideHangul overrideCJK preprocess UCA_Version
hangul_terminator variable
/;
our @ChangeNG = qw/
entry mapping table maxlength contraction
- ignoreChar ignoreName undefChar undefName variableTable
- versionTable alternateTable backwardsTable forwardsTable rearrangeTable
+ ignoreChar ignoreName undefChar undefName rewrite
+ versionTable alternateTable backwardsTable forwardsTable
+ rearrangeTable variableTable
derivCode normCode rearrangeHash backwardsFlag
suppress suppressHash
- __useXS
- /;
+ __useXS /; ### XS only
# The hash key 'ignored' is deleted at v 0.21.
# The hash key 'isShift' is deleted at v 0.23.
# The hash key 'combining' is deleted at v 0.24.
@@ -172,6 +175,7 @@ my %DerivCode = (
18 => \&_derivCE_18,
20 => \&_derivCE_20,
22 => \&_derivCE_22,
+ 24 => \&_derivCE_24,
);
sub checkCollator {
@@ -245,11 +249,15 @@ sub new
my $class = shift;
my $self = bless { @_ }, $class;
- if (! exists $self->{table} &&
+### begin XS only ###
+ if (! exists $self->{table} && !defined $self->{rewrite} &&
!defined $self->{undefName} && !defined $self->{ignoreName} &&
!defined $self->{undefChar} && !defined $self->{ignoreChar}) {
$self->{__useXS} = \&_fetch_simple;
- } # XS only
+ } else {
+ $self->{__useXS} = undef;
+ }
+### end XS only ###
# keys of $self->{suppressHash} are $self->{suppress}.
if ($self->{suppress} && @{ $self->{suppress} }) {
@@ -262,7 +270,7 @@ sub new
if ($self->{entry}) {
while ($self->{entry} =~ /([^\n]+)/g) {
- $self->parseEntry($1);
+ $self->parseEntry($1, TRUE);
}
}
@@ -313,6 +321,7 @@ sub parseAtmark {
sub read_table {
my $self = shift;
+### begin XS only ###
if ($self->{__useXS}) {
my @rest = _fetch_rest(); # complex matter need to parse
for my $line (@rest) {
@@ -326,6 +335,7 @@ sub read_table {
}
return;
}
+### end XS only ###
my($f, $fh);
foreach my $d (@INC) {
@@ -358,8 +368,13 @@ sub parseEntry
{
my $self = shift;
my $line = shift;
+ my $tailoring = shift;
my($name, $entry, @uv, @key);
+ if (defined $self->{rewrite}) {
+ $line = $self->{rewrite}->($line);
+ }
+
return if $line !~ /^\s*[0-9A-Fa-f]/;
# removes comment and gets name
@@ -374,7 +389,7 @@ sub parseEntry
@uv = _getHexArray($e);
return if !@uv;
- return if @uv > 1 && $self->{suppressHash} &&
+ return if @uv > 1 && $self->{suppressHash} && !$tailoring &&
exists $self->{suppressHash}{$uv[0]};
$entry = join(CODE_SEP, @uv); # in JCPS
@@ -448,7 +463,7 @@ sub splitEnt
my $reH = $self->{rearrangeHash};
my $vers = $self->{UCA_Version};
my $ver9 = $vers >= 9 && $vers <= 11;
- my $uXS = $self->{__useXS};
+ my $uXS = $self->{__useXS}; ### XS only
my ($str, @buf);
@@ -487,9 +502,11 @@ sub splitEnt
} elsif ($ver9) {
$src[$i] = undef if $map->{ $src[$i] } &&
@{ $map->{ $src[$i] } } == 0;
+### begin XS only ###
if ($uXS) {
$src[$i] = undef if _ignorable_simple($src[$i]);
}
+### end XS only ###
}
}
@@ -569,7 +586,7 @@ sub splitEnt
}
# skip completely ignorable
- if ($uXS && $jcps =~ /^[0-9]+\z/ && _ignorable_simple($jcps) ||
+ if ($uXS && $jcps !~ /;/ && _ignorable_simple($jcps) || ### XS only
$map->{$jcps} && @{ $map->{$jcps} } == 0) {
if ($wLen && @buf) {
$buf[-1][2] = $i + 1;
@@ -606,16 +623,17 @@ sub getWt
{
my $self = shift;
my $u = shift;
- my $vbl = $self->{variable};
my $map = $self->{mapping};
my $der = $self->{derivCode};
- my $uXS = $self->{__useXS};
+ my $uXS = $self->{__useXS}; ### XS only
return if !defined $u;
- return map(_varCE($vbl, $_), @{ $map->{$u} })
+ return map($self->varCE($_), @{ $map->{$u} })
if $map->{$u};
- return map(_varCE($vbl, $_), _fetch_simple($u))
+### begin XS only ###
+ return map($self->varCE($_), _fetch_simple($u))
if $uXS && _exists_simple($u);
+### end XS only ###
# JCPS must not be a contraction, then it's a code point.
if (Hangul_SIni <= $u && $u <= Hangul_SFin) {
@@ -652,22 +670,22 @@ sub getWt
@hangulCE = map({
$map->{$_} ? @{ $map->{$_} } :
- $uXS && _exists_simple($_) ? _fetch_simple($_) :
+ $uXS && _exists_simple($_) ? _fetch_simple($_) : ### XS only
$der->($_);
} @decH);
}
- return map _varCE($vbl, $_), @hangulCE;
+ return map $self->varCE($_), @hangulCE;
} else {
my $cjk = $self->{overrideCJK};
my $vers = $self->{UCA_Version};
if ($cjk && _isUIdeo($u, $vers)) {
my @cjkCE = map _pack_override($_, $u, $der), $cjk->($u);
- return map _varCE($vbl, $_), @cjkCE;
+ return map $self->varCE($_), @cjkCE;
}
if ($vers == 8 && defined $cjk && _isUIdeo($u, 0)) {
- return map _varCE($vbl, $_), _uideoCE_8($u);
+ return map $self->varCE($_), _uideoCE_8($u);
}
- return map _varCE($vbl, $_), $der->($u);
+ return map $self->varCE($_), $der->($u);
}
}
@@ -680,13 +698,12 @@ sub getSortKey
my $self = shift;
my $rEnt = $self->splitEnt(shift); # get an arrayref of JCPS
my $vers = $self->{UCA_Version};
- my $vbl = $self->{variable};
my $term = $self->{hangul_terminator};
my @buf; # weight arrays
if ($term) {
my $preHST = '';
- my $termCE = _varCE($vbl, pack(VCE_TEMPLATE, NON_VAR, $term, 0,0,0));
+ my $termCE = $self->varCE(pack(VCE_TEMPLATE, NON_VAR, $term, 0,0,0));
foreach my $jcps (@$rEnt) {
# weird things like VL, TL-contraction are not considered!
my $curHST = join '', map getHST($_, $vers), split /;/, $jcps;
@@ -706,7 +723,7 @@ sub getSortKey
}
}
- return $self->mk_SortKey(\@buf);
+ return $self->mk_SortKey(\@buf); ### XS only
}
@@ -773,9 +790,9 @@ sub _eqArray($$$)
##
## (int position, int length)
-## int position = index(string, substring, position, [undoc'ed grobal])
+## int position = index(string, substring, position, [undoc'ed global])
##
-## With "grobal" (only for the list context),
+## With "global" (only for the list context),
## returns list of arrayref[position, length].
##
sub index
@@ -786,7 +803,7 @@ sub index
my $subE = $self->splitEnt(shift);
my $pos = @_ ? shift : 0;
$pos = 0 if $pos < 0;
- my $grob = shift;
+ my $glob = shift;
my $lev = $self->{level};
my $v2i = $self->{UCA_Version} >= 9 &&
@@ -794,7 +811,7 @@ sub index
if (! @$subE) {
my $temp = $pos <= 0 ? 0 : $len <= $pos ? $len : $pos;
- return $grob
+ return $glob
? map([$_, 0], $temp..$len)
: wantarray ? ($temp,0) : $temp;
}
@@ -880,7 +897,7 @@ sub index
_eqArray(\@strWt, \@subWt, $lev)) {
my $temp = $iniPos[0] + $pos;
- if ($grob) {
+ if ($glob) {
push @g_ret, [$temp, $finPos[$#subWt] - $iniPos[0]];
splice @strWt, 0, $#subWt;
splice @iniPos, 0, $#subWt;
@@ -898,7 +915,7 @@ sub index
}
}
- return $grob
+ return $glob
? @g_ret
: wantarray ? () : NOMATCHPOS;
}
@@ -1019,6 +1036,7 @@ with no parameters, the collator should do the default collation.
hangul_terminator => $term_primary_weight,
ignoreName => qr/$ignoreName/,
ignoreChar => qr/$ignoreChar/,
+ ignore_level2 => $bool,
katakana_before_hiragana => $bool,
level => $collationLevel,
normalization => $normalization_form,
@@ -1026,6 +1044,7 @@ with no parameters, the collator should do the default collation.
overrideHangul => \&overrideHangul,
preprocess => \&preprocess,
rearrange => \@charList,
+ rewrite => \&rewrite,
suppress => \@charList,
table => $filename,
undefName => qr/$undefName/,
@@ -1042,7 +1061,7 @@ If the revision (previously "tracking version") number of UCA is given,
behavior of that revision is emulated on collating.
If omitted, the return value of C<UCA_Version()> is used.
-The following revisions are supported. The default is 22.
+The following revisions are supported. The default is 24.
UCA Unicode Standard DUCET (@version)
-------------------------------------------------------
@@ -1054,6 +1073,7 @@ The following revisions are supported. The default is 22.
18 5.1.0 5.1.0 (5.1.0)
20 5.2.0 5.2.0 (5.2.0)
22 6.0.0 6.0.0 (6.0.0)
+ 24 6.1.0 6.1.0 (6.1.0)
* Noncharacters (e.g. U+FFFF) are not ignored, and can be overridden
since C<UCA_Version> 22.
@@ -1180,6 +1200,18 @@ will be ignored.
E.g. when 'a' and 'e' are ignorable,
'element' is equal to 'lament' (or 'lmnt').
+=item ignore_level2
+
+-- see 5.1 Parametric Tailoring, UTS #10.
+
+By default, case-sensitive comparison (that is level 3 difference)
+won't ignore accents (that is level 2 difference).
+
+If the parameter is made true, accents (and other primary ignorable
+characters) are ignored, even though cases are taken into account.
+
+B<NOTE>: C<level> should be 3 or greater.
+
=item katakana_before_hiragana
-- see 7.3.1 Tertiary Weight Table, UTS #10.
@@ -1259,10 +1291,11 @@ order, but those in the CJK Unified Ideographs block are lesser than
those in the CJK Unified Ideographs Extension A etc.
In the CJK Unified Ideographs block:
- U+4E00..U+9FA5 if UCA_Version is 8 to 11.
- U+4E00..U+9FBB if UCA_Version is 14 to 16.
+ U+4E00..U+9FA5 if UCA_Version is 8, 9 or 11.
+ U+4E00..U+9FBB if UCA_Version is 14 or 16.
U+4E00..U+9FC3 if UCA_Version is 18.
- U+4E00..U+9FCB if UCA_Version is 20 or greater.
+ U+4E00..U+9FCB if UCA_Version is 20 or 22.
+ U+4E00..U+9FCC if UCA_Version is 24.
In the CJK Unified Ideographs Extension blocks:
Ext.A (U+3400..U+4DB5) and Ext.B (U+20000..U+2A6D6) in any UCA_Version.
@@ -1342,7 +1375,7 @@ in C<table> or C<entry> is still valid.
-- see 5.1 Preprocessing, UTS #10.
-If specified, the coderef is used to preprocess
+If specified, the coderef is used to preprocess each string
before the formation of sort keys.
ex. dropping English articles, such as "a" or "the".
@@ -1385,13 +1418,35 @@ If C<UCA_Version> is equal to or greater than 14, default is C<[]>
B<According to the version 9 of UCA, this parameter shall not be used;
but it is not warned at present.>
+=item rewrite
+
+If specified, the coderef is used to rewrite lines in C<table> or C<entry>.
+The coderef will get each line, and then should return a rewritten line
+according to the UCA file format.
+If the coderef returns an empty line, the line will be skipped.
+
+e.g. any primary ignorable characters into tertiary ignorable:
+
+ rewrite => sub {
+ my $line = shift;
+ $line =~ s/\[\.0000\..{4}\..{4}\./[.0000.0000.0000./g;
+ return $line;
+ },
+
+This example shows rewriting weights. C<rewrite> is allowed to
+affect code points, weights, and the name.
+
+B<NOTE>: C<table> is available to use another table file;
+preparing a modified table once would be more efficient than
+rewriting lines on reading an unmodified table every time.
+
=item suppress
-- see suppress contractions in 5.14.11 Special-Purpose Commands,
UTS #35 (LDML).
Contractions beginning with the specified characters are suppressed,
-even if those contractions are defined in C<table> or C<entry>.
+even if those contractions are defined in C<table>.
An example for Russian and some languages using the Cyrillic script:
@@ -1399,6 +1454,8 @@ An example for Russian and some languages using the Cyrillic script:
where 0x0400 stands for C<U+0400>, CYRILLIC CAPITAL LETTER IE WITH GRAVE.
+B<NOTE>: Contractions via C<entry> are not be suppressed.
+
=item table
-- see 3.2 Default Unicode Collation Element Table, UTS #10.
@@ -1416,8 +1473,8 @@ may be better to avoid namespace conflict.
B<NOTE>: When XSUB is used, the DUCET is compiled on building this
module, and it may save time at the run time.
Explicit saying C<table =E<gt> 'allkeys.txt'> (or using another table),
-or using C<ignoreChar>, C<ignoreName>, C<undefChar>, or C<undefName>
-will prevent this module from using the compiled DUCET.
+or using C<ignoreChar>, C<ignoreName>, C<undefChar>, C<undefName> or
+C<rewrite> will prevent this module from using the compiled DUCET.
If C<undef> is passed explicitly as the value for this key,
no file is read (but you can define collation elements via C<entry>).
@@ -1482,7 +1539,7 @@ this parameter doesn't work validly.
-- see 3.2.2 Variable Weighting, UTS #10.
-This key allows to variable weighting for variable collation elements,
+This key allows for variable weighting of variable collation elements,
which are marked with an ASTERISK in the table
(NOTE: Many punctuation marks and symbols are variable in F<allkeys.txt>).
@@ -1572,17 +1629,19 @@ If C<UCA_Version> is 8, the output is slightly different.
=head2 Methods for Searching
-B<DISCLAIMER:> If C<preprocess> or C<normalization> parameter is true
-for C<$Collator>, calling these methods (C<index>, C<match>, C<gmatch>,
-C<subst>, C<gsubst>) is croaked,
-as the position and the length might differ
-from those on the specified string.
-(And C<rearrange> and C<hangul_terminator> parameters are neglected.)
-
The C<match>, C<gmatch>, C<subst>, C<gsubst> methods work
like C<m//>, C<m//g>, C<s///>, C<s///g>, respectively,
but they are not aware of any pattern, but only a literal substring.
+B<DISCLAIMER:> If C<preprocess> or C<normalization> parameter is true
+for C<$Collator>, calling these methods (C<index>, C<match>, C<gmatch>,
+C<subst>, C<gsubst>) is croaked, as the position and the length might
+differ from those on the specified string.
+
+C<rearrange> and C<hangul_terminator> parameters are neglected.
+C<katakana_before_hiragana> and C<upper_before_lower> don't affect
+matching and searching, as it doesn't matter whether greater or lesser.
+
=over 4
=item C<$position = $Collator-E<gt>index($string, $substring[, $position])>
@@ -1654,7 +1713,7 @@ returns an empty list.
If C<$substring> matches a part of C<$string>,
the first occurrence of the matching part is replaced by C<$replacement>
-(C<$string> is modified) and return C<$count> (always equals to C<1>).
+(C<$string> is modified) and C<$count> (always equals to C<1>) is returned.
C<$replacement> can be a C<CODEREF>,
taking the matching part as an argument,
@@ -1664,8 +1723,8 @@ and returning a string to replace the matching part
=item C<$count = $Collator-E<gt>gsubst($string, $substring, $replacement)>
If C<$substring> matches a part of C<$string>,
-all the occurrences of the matching part is replaced by C<$replacement>
-(C<$string> is modified) and return C<$count>.
+all the occurrences of the matching part are replaced by C<$replacement>
+(C<$string> is modified) and C<$count> is returned.
C<$replacement> can be a C<CODEREF>,
taking the matching part as an argument,
@@ -1676,12 +1735,29 @@ e.g.
my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
# (normalization => undef) is REQUIRED.
- my $str = "Camel donkey zebra came\x{301}l CAMEL horse cAm\0E\0L...";
+ my $str = "Camel donkey zebra came\x{301}l CAMEL horse cam\0e\0l...";
$Collator->gsubst($str, "camel", sub { "<b>$_[0]</b>" });
- # now $str is "<b>Camel</b> donkey zebra <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cAm\0E\0L</b>...";
+ # now $str is "<b>Camel</b> donkey zebra <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cam\0e\0l</b>...";
# i.e., all the camels are made bold-faced.
+ Examples: levels and ignore_level2 - what does camel match?
+ ---------------------------------------------------------------------------
+ level ignore_level2 | camel Camel came\x{301}l c-a-m-e-l cam\0e\0l
+ -----------------------|---------------------------------------------------
+ 1 false | yes yes yes yes yes
+ 2 false | yes yes no yes yes
+ 3 false | yes no no yes yes
+ 4 false | yes no no no yes
+ -----------------------|---------------------------------------------------
+ 1 true | yes yes yes yes yes
+ 2 true | yes yes yes yes yes
+ 3 true | yes no yes yes yes
+ 4 true | yes no yes no yes
+ ---------------------------------------------------------------------------
+ note: if variable => non-ignorable, camel doesn't match c-a-m-e-l
+ at any level.
+
=back
=head2 Other Methods
@@ -1692,7 +1768,7 @@ e.g.
=item C<$modified_collator = $Collator-E<gt>change(%new_tailoring)>
-Change the value of specified keys and returns the changed part.
+Changes the value of specified keys and returns the changed part.
$Collator = Unicode::Collate->new(level => 4);
@@ -1792,15 +1868,15 @@ B<Unicode::Normalize is required to try The Conformance Test.>
=head1 AUTHOR, COPYRIGHT AND LICENSE
The Unicode::Collate module for perl was written by SADAHIRO Tomoyuki,
-<SADAHIRO@cpan.org>. This module is Copyright(C) 2001-2011,
+<SADAHIRO@cpan.org>. This module is Copyright(C) 2001-2012,
SADAHIRO Tomoyuki. Japan. All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
The file Unicode/Collate/allkeys.txt was copied verbatim
-from L<http://www.unicode.org/Public/UCA/6.0.0/allkeys.txt>.
-This file is Copyright (c) 1991-2010 Unicode, Inc. All rights reserved.
+from L<http://www.unicode.org/Public/UCA/6.1.0/allkeys.txt>.
+For this file, Copyright (c) 2001-2011 Unicode, Inc.
Distributed under the Terms of Use in L<http://www.unicode.org/copyright.html>.
=head1 SEE ALSO