diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Unicode/Collate.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Unicode/Collate.pm | 190 |
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 |