package Unicode::Collate;
BEGIN {
- if (ord("A") == 193) {
- die "Unicode::Collate not ported to EBCDIC\n";
+ unless ("A" eq pack('U', 0x41) || "A" eq pack('U', ord("A"))) {
+ die "Unicode::Collate cannot stringify a Unicode code point\n";
}
}
require Exporter;
-our $VERSION = '0.21';
+our $VERSION = '0.24';
our $PACKAGE = __PACKAGE__;
our @ISA = qw(Exporter);
unless ($@) {
$UNICODE_VERSION = Unicode::UCD::UnicodeVersion();
}
-else { # XXX, Perl 5.6.1
+else { # Perl 5.6.1
my($f, $fh);
foreach my $d (@INC) {
$f = File::Spec->catfile($d, "unicode", "Unicode.301");
}
}
-our $getCombinClass; # coderef for combining class from Unicode::Normalize
-
-use constant Min2 => 0x20; # minimum weight at level 2
-use constant Min3 => 0x02; # minimum weight at level 3
-
-# format for pack
-use constant VCE_FORMAT => 'Cn4'; # for variable + CE with 4 levels
-
-# values of variable
+# Perl's boolean
+use constant TRUE => 1;
+use constant FALSE => "";
+use constant NOMATCHPOS => -1;
+
+# A coderef to get combining class imported from Unicode::Normalize
+# (i.e. \&Unicode::Normalize::getCombinClass).
+# This is also used as a HAS_UNICODE_NORMALIZE flag.
+our $getCombinClass;
+
+# Supported Levels
+use constant MinLevel => 1;
+use constant MaxLevel => 4;
+
+# Minimum weights at level 2 and 3, respectively
+use constant Min2Wt => 0x20;
+use constant Min3Wt => 0x02;
+
+# Shifted weight at 4th level
+use constant Shift4Wt => 0xFFFF;
+
+# Variable weight at 1st level.
+# This is a negative value but should be regarded as zero on collation.
+# This is for distinction of variable chars from level 3 ignorable chars.
+use constant Var1Wt => -1;
+
+
+# A boolean for Variable and 16-bit weights at 4 levels of Collation Element
+# PROBLEM: The Default Unicode Collation Element Table
+# has weights over 0xFFFF at the 4th level.
+# The tie-breaking in the variable weights
+# other than "shift" (as well as "shift-trimmed") is unreliable.
+use constant VCE_TEMPLATE => 'Cn4';
+
+# A sort key: 16-bit weights
+# See also the PROBLEM on VCE_TEMPLATE above.
+use constant KEY_TEMPLATE => 'n*';
+
+# Level separator in a sort key:
+# i.e. pack(KEY_TEMPLATE, 0)
+use constant LEVEL_SEP => "\0\0";
+
+# As Unicode code point separator for hash keys.
+# A joined code point string (denoted by JCPS below)
+# like "65;768" is used for internal processing
+# instead of Perl's Unicode string like "\x41\x{300}",
+# as the native code point is different from the Unicode code point
+# on EBCDIC platform.
+# This character must not be included in any stringified
+# representation of an integer.
+use constant CODE_SEP => ';';
+
+# boolean values of variable weights
use constant NON_VAR => 0; # Non-Variable character
use constant VAR => 1; # Variable character
+# Logical_Order_Exception in PropList.txt
+# TODO: synchronization with change of PropList.txt.
our $DefaultRearrange = [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ];
sub UCA_Version { "9" }
sub Base_Unicode_Version { $UNICODE_VERSION || 'unknown' }
+######
+
+use constant UNICODE_FOR_PACK => ("A" eq pack('U', 0x41));
+use constant NATIVE_FOR_PACK => ("A" eq pack('U', ord("A")));
+
+use constant UNICODE_FOR_UNPACK => (0x41 == unpack('U', "A"));
+use constant NATIVE_FOR_UNPACK => (ord("A") == unpack('U', "A"));
+
+sub pack_U {
+ return UNICODE_FOR_PACK
+ ? pack('U*', @_)
+ : NATIVE_FOR_PACK
+ ? pack('U*', map utf8::unicode_to_native($_), @_)
+ : die "$PACKAGE, a Unicode code point cannot be stringified.\n";
+}
+
+sub unpack_U {
+ return UNICODE_FOR_UNPACK
+ ? unpack('U*', shift)
+ : NATIVE_FOR_UNPACK
+ ? map(utf8::native_to_unicode($_), unpack 'U*', shift)
+ : die "$PACKAGE, a code point returned from unpack U " .
+ "cannot be converted into Unicode.\n";
+}
+
+######
+
my (%AlternateOK);
@AlternateOK{ qw/
blanked non-ignorable shifted shift-trimmed
/;
our @ChangeNG = qw/
- entry entries table combining maxlength
+ entry entries table maxlength
ignoreChar ignoreName undefChar undefName
versionTable alternateTable backwardsTable forwardsTable rearrangeTable
- derivCode normCode rearrangeHash isShift L3ignorable
+ derivCode normCode rearrangeHash L3_ignorable
+ backwardsFlag
/;
-# The hash key 'ignored' is deleted at VERSION 0.21.
+# 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.
my (%ChangeOK, %ChangeNG);
@ChangeOK{ @ChangeOK } = ();
return wantarray ? %old : $self;
}
+sub _checkLevel {
+ my $level = shift;
+ my $key = shift;
+ croak sprintf "Illegal level %d (in \$self->{%s}) lower than %d.",
+ $level, $key, MinLevel if MinLevel > $level;
+ croak sprintf "Unsupported level %d (in \$self->{%s}) higher than %d ",
+ $level, $key, MaxLevel if MaxLevel < $level;
+}
+
sub checkCollator {
my $self = shift;
- croak "Illegal level lower than 1 (passed $self->{level})."
- if $self->{level} < 1;
- croak "A level higher than 4 (passed $self->{level}) is not supported."
- if 4 < $self->{level};
+ _checkLevel($self->{level}, "level");
$self->{derivCode} =
- $self->{UCA_Version} == -1 ? \&broken_derivCE :
- $self->{UCA_Version} == 8 ? \&derivCE_8 :
- $self->{UCA_Version} == 9 ? \&derivCE_9 :
+ $self->{UCA_Version} == 8 ? \&_derivCE_8 :
+ $self->{UCA_Version} == 9 ? \&_derivCE_9 :
croak "Illegal UCA version (passed $self->{UCA_Version}).";
$self->{alternate} = lc($self->{alternate});
croak "$PACKAGE unknown alternate tag name: $self->{alternate}"
unless exists $AlternateOK{ $self->{alternate} };
- $self->{isShift} = $self->{alternate} eq 'shifted' ||
- $self->{alternate} eq 'shift-trimmed';
-
- $self->{backwards} = []
- if ! defined $self->{backwards};
- $self->{backwards} = [ $self->{backwards} ]
- if ! ref $self->{backwards};
+ if (! defined $self->{backwards}) {
+ $self->{backwardsFlag} = 0;
+ }
+ elsif (! ref $self->{backwards}) {
+ _checkLevel($self->{backwards}, "backwards");
+ $self->{backwardsFlag} = 1 << $self->{backwards};
+ }
+ else {
+ my %level;
+ $self->{backwardsFlag} = 0;
+ for my $b (@{ $self->{backwards} }) {
+ _checkLevel($b, "backwards");
+ $level{$b} = 1;
+ }
+ for my $v (sort keys %level) {
+ $self->{backwardsFlag} += 1 << $v;
+ }
+ }
$self->{rearrange} = []
if ! defined $self->{rearrange};
$self->parseEntry($_) foreach split /\n/, $self->{entry};
}
- $self->{level} ||= 4;
+ $self->{level} ||= MaxLevel;
$self->{UCA_Version} ||= UCA_Version();
$self->{overrideHangul} = ''
{
my $self = shift;
my $line = shift;
- my($name, $ele, @key);
+ my($name, $entry, @uv, @key);
return if $line !~ /^\s*[0-9A-Fa-f]/;
croak "Wrong Entry: <charList> must be separated by ';' from <collElement>"
if ! $k;
- my @e = _getHexArray($e);
- return if !@e;
+ @uv = _getHexArray($e);
+ return if !@uv;
+
+ $entry = join(CODE_SEP, @uv); # in JCPS
- $ele = pack('U*', @e);
- return if defined $self->{undefChar} && $ele =~ /$self->{undefChar}/;
+ if (defined $self->{undefChar} || defined $self->{ignoreChar}) {
+ my $ele = pack_U(@uv);
- my $combining = 1; # primary = 0, secondary != 0;
- my $level3ignore;
+ # regarded as if it were not entried in the table
+ return
+ if defined $self->{undefChar} && $ele =~ /$self->{undefChar}/;
- # replace with completely ignorable
- if (defined $self->{ignoreName} && $name =~ /$self->{ignoreName}/ ||
- defined $self->{ignoreChar} && $ele =~ /$self->{ignoreChar}/)
- {
- $k = '[.0000.0000.0000.0000]';
+ # replaced as completely ignorable
+ $k = '[.0000.0000.0000.0000]'
+ if defined $self->{ignoreChar} && $ele =~ /$self->{ignoreChar}/;
}
+ # replaced as completely ignorable
+ $k = '[.0000.0000.0000.0000]'
+ if defined $self->{ignoreName} && $name =~ /$self->{ignoreName}/;
+
+ my $is_L3_ignorable;
+
foreach my $arr ($k =~ /\[([^\[\]]+)\]/g) { # SPACEs allowed
my $var = $arr =~ /\*/; # exactly /^\*/ but be lenient.
- my @arr = _getHexArray($arr);
- push @key, pack(VCE_FORMAT, $var, @arr);
- $combining = 0 unless $arr[0] == 0 && $arr[1] != 0;
- $level3ignore = 1 if $arr[0] == 0 && $arr[1] == 0 && $arr[2] == 0;
+ my @wt = _getHexArray($arr);
+ push @key, pack(VCE_TEMPLATE, $var, @wt);
+ $is_L3_ignorable = TRUE
+ if $wt[0] + $wt[1] + $wt[2] == 0;
+ # if $arr !~ /[1-9A-Fa-f]/; NG
+ # Conformance Test shows L3-ignorable is completely ignorable.
}
- $self->{entries}{$ele} = \@key;
+ $self->{entries}{$entry} = \@key;
- $self->{combining}{$ele} = 1
- if $combining;
+ $self->{L3_ignorable}{$uv[0]} = TRUE
+ if @uv == 1 && $is_L3_ignorable;
- $self->{L3ignorable}{$e[0]} = 1
- if @e == 1 && $level3ignore;
-
- $self->{maxlength}{ord $ele} = scalar @e if @e > 1;
+ # Contraction is to be considered in the range of this maxlength.
+ $self->{maxlength}{$uv[0]} = scalar @uv
+ if @uv > 1;
}
+
##
-## arrayref CE = altCE(bool variable?, list[num] weights)
+## arrayref[weights] = altCE(VCE)
##
sub altCE
{
my $self = shift;
- my($var, @c) = unpack(VCE_FORMAT, shift);
+ my($var, @wt) = unpack(VCE_TEMPLATE, shift);
$self->{alternate} eq 'blanked' ?
- $var ? [0,0,0,$c[3]] : \@c :
+ $var ? [Var1Wt, 0, 0, $wt[3]] : \@wt :
$self->{alternate} eq 'non-ignorable' ?
- \@c :
+ \@wt :
$self->{alternate} eq 'shifted' ?
- $var ? [0,0,0,$c[0] ] : [ @c[0..2], $c[0]+$c[1]+$c[2] ? 0xFFFF : 0 ] :
+ $var ? [Var1Wt, 0, 0, $wt[0] ]
+ : [ @wt[0..2], $wt[0]+$wt[1]+$wt[2] ? Shift4Wt : 0 ] :
$self->{alternate} eq 'shift-trimmed' ?
- $var ? [0,0,0,$c[0] ] : [ @c[0..2], 0 ] :
+ $var ? [Var1Wt, 0, 0, $wt[0] ] : [ @wt[0..2], 0 ] :
croak "$PACKAGE unknown alternate name: $self->{alternate}";
}
sub viewSortKey
{
my $self = shift;
- my $ver = $self->{UCA_Version};
+ $self->visualizeSortKey($self->getSortKey(@_));
+}
- my $key = $self->getSortKey(@_);
- my $view = join " ", map sprintf("%04X", $_), unpack 'n*', $key;
- if ($ver <= 8) {
+sub visualizeSortKey
+{
+ my $self = shift;
+ my $view = join " ", map sprintf("%04X", $_), unpack(KEY_TEMPLATE, shift);
+
+ if ($self->{UCA_Version} <= 8) {
$view =~ s/ ?0000 ?/|/g;
} else {
$view =~ s/\b0000\b/|/g;
##
-## list[strings] elements = splitCE(string arg)
+## arrayref of JCPS = splitCE(string to be collated)
+## arrayref of arrayref[JCPS, ini_pos, fin_pos] = splitCE(string, true)
##
sub splitCE
{
my $self = shift;
+ my $wLen = $_[1];
+
my $code = $self->{preprocess};
my $norm = $self->{normCode};
my $ent = $self->{entries};
my $max = $self->{maxlength};
my $reH = $self->{rearrangeHash};
- my $L3i = $self->{L3ignorable};
+ my $ign = $self->{L3_ignorable};
my $ver9 = $self->{UCA_Version} > 8;
- my $str = ref $code ? &$code(shift) : shift;
- $str = &$norm($str) if ref $norm;
+ my ($str, @buf);
- my @src = unpack('U*', $str);
- my @buf;
+ if ($wLen) {
+ $code and croak "Preprocess breaks character positions. "
+ . "Don't use with index(), match(), etc.";
+ $norm and croak "Normalization breaks character positions. "
+ . "Don't use with index(), match(), etc.";
+ $str = $_[0];
+ }
+ else {
+ $str = $_[0];
+ $str = &$code($str) if ref $code;
+ $str = &$norm($str) if ref $norm;
+ }
+
+ # get array of Unicode code point of string.
+ my @src = unpack_U($str);
- # rearrangement
- if ($reH) {
+ # rearrangement:
+ # Character positions are not kept if rearranged,
+ # then neglected if $wLen is true.
+ if ($reH && ! $wLen) {
for (my $i = 0; $i < @src; $i++) {
if (exists $reH->{ $src[$i] } && $i + 1 < @src) {
($src[$i], $src[$i+1]) = ($src[$i+1], $src[$i]);
}
if ($ver9) {
- @src = grep ! $L3i->{$_}, @src;
+ # To remove a character marked as a completely ignorable.
+ for (my $i = 0; $i < @src; $i++) {
+ $src[$i] = undef if $ign->{ $src[$i] };
+ }
}
for (my $i = 0; $i < @src; $i++) {
- my $ch;
- my $u = $src[$i];
-
- # non-characters
- next if ! defined $u
- || ($u < 0 || 0x10FFFF < $u) # out of range
- || (($u & 0xFFFE) == 0xFFFE) # ??FFFE or ??FFFF (cf. utf8.c)
- || (0xD800 <= $u && $u <= 0xDFFF) # unpaired surrogates
- || (0xFDD0 <= $u && $u <= 0xFDEF) # non-character
- ;
-
- if ($max->{$u}) { # contract
- for (my $j = $max->{$u}; $j >= 1; $j--) {
- next unless $i+$j-1 < @src;
- $ch = pack 'U*', @src[$i .. $i+$j-1];
- $i += $j-1, last if $ent->{$ch};
+ next if _isNonCharacter($src[$i]);
+
+ my $i_orig = $i;
+ my $ce = $src[$i];
+
+ if ($max->{$ce}) { # contract
+ my $temp_ce = $ce;
+
+ for (my $p = $i + 1; $p < @src; $p++) {
+ next if ! defined $src[$p];
+ $temp_ce .= CODE_SEP . $src[$p];
+ if ($ent->{$temp_ce}) {
+ $ce = $temp_ce;
+ $i = $p;
+ }
+ }
+ }
+
+ # with Combining Char (UTS#10, 4.2.1).
+ # requires Unicode::Normalize.
+ # Not be $wLen, as not croaked due to $norm.
+ if ($getCombinClass) {
+ for (my $p = $i + 1; $p < @src; $p++) {
+ next if ! defined $src[$p];
+ last unless $getCombinClass->($src[$p]);
+ my $tail = CODE_SEP . $src[$p];
+ if ($ent->{$ce.$tail}) {
+ $ce .= $tail;
+ $src[$p] = undef;
+ }
}
- } else {
- $ch = pack('U', $u);
}
- # with Combining Char (UTS#10, 4.2.1), here requires Unicode::Normalize.
- if ($getCombinClass && defined $ch) {
- for (my $j = $i+1; $j < @src; $j++) {
- next unless defined $src[$j];
- last unless $getCombinClass->( $src[$j] );
- my $comb = pack 'U', $src[$j];
- next if ! $ent->{ $ch.$comb };
- $ch .= $comb;
- $src[$j] = undef;
+ if ($wLen) {
+ for (my $p = $i + 1; $p < @src; $p++) {
+ last if defined $src[$p];
+ $i = $p;
}
}
- push @buf, $ch;
+
+ push @buf, $wLen ? [$ce, $i_orig, $i + 1] : $ce;
}
- wantarray ? @buf : \@buf;
+ return \@buf;
}
##
-## list[arrayrefs] weight = getWt(string element)
+## list of arrayrefs of weights = getWt(JCPS)
##
sub getWt
{
my $self = shift;
- my $ch = shift;
+ my $ce = shift;
my $ent = $self->{entries};
my $cjk = $self->{overrideCJK};
my $hang = $self->{overrideHangul};
my $der = $self->{derivCode};
- return if !defined $ch;
- return map($self->altCE($_), @{ $ent->{$ch} })
- if $ent->{$ch};
+ return if !defined $ce;
+ return map($self->altCE($_), @{ $ent->{$ce} })
+ if $ent->{$ce};
- my $u = unpack('U', $ch);
+ # CE must not be a contraction, then it's a code point.
+ my $u = $ce;
- if (0xAC00 <= $u && $u <= 0xD7A3) { # is_Hangul
+ if (0xAC00 <= $u && $u <= 0xD7A3) { # is Hangul Syllale
return map $self->altCE($_),
$hang
- ? map(pack(VCE_FORMAT, NON_VAR, @$_), &$hang($u))
+ ? map(pack(VCE_TEMPLATE, NON_VAR, @$_), &$hang($u))
: defined $hang
? map({
- my $v = $_;
- my $vCE = $ent->{pack('U', $v)};
- $vCE ? @$vCE : $der->($v);
+ $ent->{$_} ? @{ $ent->{$_} } : $der->($_);
} _decompHangul($u))
: $der->($u);
}
0x20000 <= $u && $u <= 0x2A6D6) { # CJK Ideograph
return map $self->altCE($_),
$cjk
- ? map(pack(VCE_FORMAT, NON_VAR, @$_), &$cjk($u))
+ ? map(pack(VCE_TEMPLATE, NON_VAR, @$_), &$cjk($u))
: defined $cjk && $self->{UCA_Version} <= 8 && $u < 0x10000
- ? pack(VCE_FORMAT, NON_VAR, $u, 0x20, 0x02, $u)
+ ? pack(VCE_TEMPLATE, NON_VAR, $u, Min2Wt, Min3Wt, $u)
: $der->($u);
}
else {
}
}
-##
-## int = index(string, substring)
-##
-sub index
-{
- my $self = shift;
- my $lev = $self->{level};
- my $comb = $self->{combining};
- my $str = $self->splitCE(shift);
- my $sub = $self->splitCE(shift);
-
- return wantarray ? (0,0) : 0 if ! @$sub;
- return wantarray ? () : -1 if ! @$str;
-
- my @subWt = grep _ignorableAtLevel($_,$lev),
- map $self->getWt($_), @$sub;
-
- my(@strWt,@strPt);
- my $count = 0;
- for (my $i = 0; $i < @$str; $i++) {
- my $go_ahead = 0;
-
- my @tmp = grep _ignorableAtLevel($_,$lev), $self->getWt($str->[$i]);
- $go_ahead += length $str->[$i];
-
- # /*XXX*/ still broken.
- # index("e\x{300}", "e") should be 'no match' at level 2 or higher
- # as "e\x{300}" is a *single* grapheme cluster and not equal to "e".
-
- # go ahead as far as we find a combining character;
- while ($i + 1 < @$str &&
- (! defined $str->[$i+1] || $comb->{ $str->[$i+1] }) ) {
- $i++;
- next if ! defined $str->[$i];
- $go_ahead += length $str->[$i];
- push @tmp,
- grep _ignorableAtLevel($_,$lev), $self->getWt($str->[$i]);
- }
-
- push @strWt, @tmp;
- push @strPt, ($count) x @tmp;
- $count += $go_ahead;
-
- while (@strWt >= @subWt) {
- if (_eqArray(\@strWt, \@subWt, $lev)) {
- my $pos = $strPt[0];
- return wantarray ? ($pos, $count-$pos) : $pos;
- }
- shift @strWt;
- shift @strPt;
- }
- }
- return wantarray ? () : -1;
-}
-
-##
-## bool _eqArray(arrayref, arrayref, level)
-##
-sub _eqArray($$$)
-{
- my $a = shift; # length $a >= length $b;
- my $b = shift;
- my $lev = shift;
- for my $v (0..$lev-1) {
- for my $c (0..@$b-1){
- return if $a->[$c][$v] != $b->[$c][$v];
- }
- }
- return 1;
-}
-
-
-##
-## bool _ignorableAtLevel(CE, level)
-##
-sub _ignorableAtLevel($$)
-{
- my $ce = shift;
- return unless defined $ce;
- my $lv = shift;
- return ! grep { ! $ce->[$_] } 0..$lv-1;
-}
-
##
## string sortkey = getSortKey(string arg)
{
my $self = shift;
my $lev = $self->{level};
- my $rCE = $self->splitCE(shift); # get an arrayref
+ my $rCE = $self->splitCE(shift); # get an arrayref of JCPS
my $ver9 = $self->{UCA_Version} > 8;
- my $sht = $self->{isShift};
+ my $v2i = $self->{alternate} ne 'non-ignorable';
# weight arrays
my (@buf, $last_is_variable);
- foreach my $ce (@$rCE) {
- my @t = $self->getWt($ce);
- if ($sht && $ver9) {
- if (@t == 1 && $t[0][0] == 0) {
- if ($t[0][1] == 0 && $t[0][2] == 0) {
- $last_is_variable = 1;
- } else {
- next if $last_is_variable;
- }
+ foreach my $wt (map $self->getWt($_), @$rCE) {
+ if ($v2i && $ver9) {
+ if ($wt->[0] == 0) { # ignorable
+ next if $last_is_variable;
} else {
- $last_is_variable = 0;
+ $last_is_variable = ($wt->[0] == Var1Wt);
}
}
- push @buf, @t;
+ push @buf, $wt;
}
# make sort key
my @ret = ([],[],[],[]);
foreach my $v (0..$lev-1) {
foreach my $b (@buf) {
- push @{ $ret[$v] }, $b->[$v] if $b->[$v];
+ push @{ $ret[$v] }, $b->[$v]
+ if 0 < $b->[$v];
}
}
- foreach (@{ $self->{backwards} }) {
- my $v = $_ - 1;
- @{ $ret[$v] } = reverse @{ $ret[$v] };
- }
# modification of tertiary weights
if ($self->{upper_before_lower}) {
elsif (0x0D <= $_ && $_ <= 0x0E) { $_ += 5 } # hiragana
}
}
- join "\0\0", map pack('n*', @$_), @ret;
+
+ if ($self->{backwardsFlag}) {
+ for (my $v = MinLevel; $v <= MaxLevel; $v++) {
+ if ($self->{backwardsFlag} & (1 << $v)) {
+ @{ $ret[$v-1] } = reverse @{ $ret[$v-1] };
+ }
+ }
+ }
+
+ join LEVEL_SEP, map pack(KEY_TEMPLATE, @$_), @ret;
}
}
-sub derivCE_9 {
+sub _derivCE_9 {
my $u = shift;
my $base =
- (0x4E00 <= $u && $u <= 0x9FA5) # CJK
- ? 0xFB40 :
+ (0x4E00 <= $u && $u <= 0x9FA5)
+ ? 0xFB40 : # CJK
(0x3400 <= $u && $u <= 0x4DB5 || 0x20000 <= $u && $u <= 0x2A6D6)
- ? 0xFB80 : 0xFBC0;
+ ? 0xFB80 # CJK ext.
+ : 0xFBC0; # others
my $aaaa = $base + ($u >> 15);
my $bbbb = ($u & 0x7FFF) | 0x8000;
return
- pack(VCE_FORMAT, NON_VAR, $aaaa, Min2, Min3, $u),
- pack(VCE_FORMAT, NON_VAR, $bbbb, 0, 0, $u);
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, Min2Wt, Min3Wt, $u),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $u);
}
-sub derivCE_8 {
+sub _derivCE_8 {
my $code = shift;
my $aaaa = 0xFF80 + ($code >> 15);
my $bbbb = ($code & 0x7FFF) | 0x8000;
return
- pack(VCE_FORMAT, NON_VAR, $aaaa, 2, 1, $code),
- pack(VCE_FORMAT, NON_VAR, $bbbb, 0, 0, $code);
-}
-
-sub broken_derivCE { # NG
- my $code = shift;
- my $aaaa = 0xFFC2 + ($code >> 15);
- my $bbbb = $code & 0x7FFF | 0x1000;
- return
- pack(VCE_FORMAT, NON_VAR, $aaaa, 2, 1, $code),
- pack(VCE_FORMAT, NON_VAR, $bbbb, 0, 0, $code);
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, 2, 1, $code),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $code);
}
##
sub _getHexArray { map hex, $_[0] =~ /([0-9a-fA-F]+)/g }
#
-# $code must be in Hangul syllable.
+# $code *must* be in Hangul syllable.
# Check it before you enter here.
#
sub _decompHangul {
);
}
+sub _isNonCharacter {
+ my $code = shift;
+ return ! defined $code # removed
+ || ($code < 0 || 0x10FFFF < $code) # out of range
+ || (($code & 0xFFFE) == 0xFFFE) # ??FFF[EF] (cf. utf8.c)
+ || (0xD800 <= $code && $code <= 0xDFFF) # unpaired surrogates
+ || (0xFDD0 <= $code && $code <= 0xFDEF) # other non-characters
+ ;
+}
+
+
+##
+## bool _nonIgnorAtLevel(arrayref weights, int level)
+##
+sub _nonIgnorAtLevel($$)
+{
+ my $wt = shift;
+ return if ! defined $wt;
+ my $lv = shift;
+ return grep($wt->[$_-1] != 0, MinLevel..$lv) ? TRUE : FALSE;
+}
+
+##
+## bool _eqArray(
+## arrayref of arrayref[weights] source,
+## arrayref of arrayref[weights] substr,
+## int level)
+## * comparison of graphemes vs graphemes.
+## @$source >= @$substr must be true (check it before call this);
+##
+sub _eqArray($$$)
+{
+ my $source = shift;
+ my $substr = shift;
+ my $lev = shift;
+
+ for my $g (0..@$substr-1){
+ # Do the $g'th graphemes have the same number of AV weigths?
+ return if @{ $source->[$g] } != @{ $substr->[$g] };
+
+ for my $w (0..@{ $substr->[$g] }-1) {
+ for my $v (0..$lev-1) {
+ return if $source->[$g][$w][$v] != $substr->[$g][$w][$v];
+ }
+ }
+ }
+ return 1;
+}
+
+##
+## (int position, int length)
+## int position = index(string, substring, position, [undoc'ed grobal])
+##
+## With "grobal" (only for the list context),
+## returns list of arrayref[position, length].
+##
+sub index
+{
+ my $self = shift;
+ my $str = shift;
+ my $len = length($str);
+ my $subCE = $self->splitCE(shift);
+ my $pos = @_ ? shift : 0;
+ $pos = 0 if $pos < 0;
+ my $grob = shift;
+
+ my $lev = $self->{level};
+ my $ver9 = $self->{UCA_Version} > 8;
+ my $v2i = $self->{alternate} ne 'non-ignorable';
+
+ if (! @$subCE) {
+ my $temp = $pos <= 0 ? 0 : $len <= $pos ? $len : $pos;
+ return $grob
+ ? map([$_, 0], $temp..$len)
+ : wantarray ? ($temp,0) : $temp;
+ }
+ if ($len < $pos) {
+ return wantarray ? () : NOMATCHPOS;
+ }
+ my $strCE = $self->splitCE($pos ? substr($str, $pos) : $str, TRUE);
+ if (! @$strCE) {
+ return wantarray ? () : NOMATCHPOS;
+ }
+ my $last_is_variable;
+ my(@strWt, @iniPos, @finPos, @subWt, @g_ret);
+
+ $last_is_variable = FALSE;
+ for my $wt (map $self->getWt($_), @$subCE) {
+ my $to_be_pushed = _nonIgnorAtLevel($wt,$lev);
+
+ if ($v2i && $ver9) {
+ if ($wt->[0] == 0) {
+ $to_be_pushed = FALSE if $last_is_variable;
+ } else {
+ $last_is_variable = ($wt->[0] == Var1Wt);
+ }
+ }
+
+ if (@subWt && $wt->[0] == 0) {
+ push @{ $subWt[-1] }, $wt if $to_be_pushed;
+ } else {
+ $wt->[0] = 0 if $wt->[0] == Var1Wt;
+ push @subWt, [ $wt ];
+ }
+ }
+
+ my $count = 0;
+ my $end = @$strCE - 1;
+
+ $last_is_variable = FALSE;
+
+ for (my $i = 0; $i <= $end; ) { # no $i++
+ my $found_base = 0;
+
+ # fetch a grapheme
+ while ($i <= $end && $found_base == 0) {
+ for my $wt ($self->getWt($strCE->[$i][0])) {
+ my $to_be_pushed = _nonIgnorAtLevel($wt,$lev);
+
+ if ($v2i && $ver9) {
+ if ($wt->[0] == 0) {
+ $to_be_pushed = FALSE if $last_is_variable;
+ } else {
+ $last_is_variable = ($wt->[0] == Var1Wt);
+ }
+ }
+
+ if (@strWt && $wt->[0] == 0) {
+ push @{ $strWt[-1] }, $wt if $to_be_pushed;
+ $finPos[-1] = $strCE->[$i][2];
+ } elsif ($to_be_pushed) {
+ $wt->[0] = 0 if $wt->[0] == Var1Wt;
+ push @strWt, [ $wt ];
+ push @iniPos, $found_base ? NOMATCHPOS : $strCE->[$i][1];
+ $finPos[-1] = NOMATCHPOS if $found_base;
+ push @finPos, $strCE->[$i][2];
+ $found_base++;
+ }
+ # else ===> no-op
+ }
+ $i++;
+ }
+
+ # try to match
+ while ( @strWt > @subWt || (@strWt == @subWt && $i > $end) ) {
+ if ($iniPos[0] != NOMATCHPOS &&
+ $finPos[$#subWt] != NOMATCHPOS &&
+ _eqArray(\@strWt, \@subWt, $lev)) {
+ my $temp = $iniPos[0] + $pos;
+
+ if ($grob) {
+ push @g_ret, [$temp, $finPos[$#subWt] - $iniPos[0]];
+ splice @strWt, 0, $#subWt;
+ splice @iniPos, 0, $#subWt;
+ splice @finPos, 0, $#subWt;
+ }
+ else {
+ return wantarray
+ ? ($temp, $finPos[$#subWt] - $iniPos[0])
+ : $temp;
+ }
+ }
+ shift @strWt;
+ shift @iniPos;
+ shift @finPos;
+ }
+ }
+
+ return $grob
+ ? @g_ret
+ : wantarray ? () : NOMATCHPOS;
+}
+
+##
+## scalarref to matching part = match(string, substring)
+##
+sub match
+{
+ my $self = shift;
+ if (my($pos,$len) = $self->index($_[0], $_[1])) {
+ my $temp = substr($_[0], $pos, $len);
+ return wantarray ? $temp : \$temp;
+ # An lvalue ref \substr should be avoided,
+ # since its value is affected by modification of its referent.
+ }
+ else {
+ return;
+ }
+}
+
+##
+## arrayref matching parts = gmatch(string, substring)
+##
+sub gmatch
+{
+ my $self = shift;
+ my $str = shift;
+ my $sub = shift;
+ return map substr($str, $_->[0], $_->[1]),
+ $self->index($str, $sub, 0, 'g');
+}
+
+##
+## bool subst'ed = subst(string, substring, replace)
+##
+sub subst
+{
+ my $self = shift;
+ my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
+
+ if (my($pos,$len) = $self->index($_[0], $_[1])) {
+ if ($code) {
+ my $mat = substr($_[0], $pos, $len);
+ substr($_[0], $pos, $len, $code->($mat));
+ } else {
+ substr($_[0], $pos, $len, $_[2]);
+ }
+ return TRUE;
+ }
+ else {
+ return FALSE;
+ }
+}
+
+##
+## int count = gsubst(string, substring, replace)
+##
+sub gsubst
+{
+ my $self = shift;
+ my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
+ my $cnt = 0;
+
+ # Replacement is carried out from the end, then use reverse.
+ for my $pos_len (reverse $self->index($_[0], $_[1], 0, 'g')) {
+ if ($code) {
+ my $mat = substr($_[0], $pos_len->[0], $pos_len->[1]);
+ substr($_[0], $pos_len->[0], $pos_len->[1], $code->($mat));
+ } else {
+ substr($_[0], $pos_len->[0], $pos_len->[1], $_[2]);
+ }
+ $cnt++;
+ }
+ return $cnt;
+}
+
1;
__END__
=head1 DESCRIPTION
+This module is an implementation
+of Unicode Technical Standard #10 (UTS #10)
+"Unicode Collation Algorithm."
+
=head2 Constructor and Tailoring
The C<new> method returns a collator object.
=item alternate
--- see 3.2.2 Variable Weighting, UTR #10.
+-- see 3.2.2 Variable Weighting, UTS #10.
(the title in UCA version 8: Alternate Weighting)
These names are case-insensitive.
By default (if specification is omitted), 'shifted' is adopted.
- 'Blanked' Variable elements are ignorable at levels 1 through 3;
+ 'Blanked' Variable elements are made ignorable at levels 1 through 3;
considered at the 4th level.
'Non-ignorable' Variable elements are not reset to ignorable.
- 'Shifted' Variable elements are ignorable at levels 1 through 3
+ 'Shifted' Variable elements are made ignorable at levels 1 through 3
their level 4 weight is replaced by the old level 1 weight.
Level 4 weight for Non-Variable elements is 0xFFFF.
=item backwards
--- see 3.1.2 French Accents, UTR #10.
+-- see 3.1.2 French Accents, UTS #10.
backwards => $levelNumber or \@levelNumbers
=item entry
--- see 3.1 Linguistic Features; 3.2.1 File Format, UTR #10.
+-- see 3.1 Linguistic Features; 3.2.1 File Format, UTS #10.
Overrides a default order or defines additional collation elements
0043 0068 ; [.0893.0020.0008.0043] # "Ch" in traditional Spanish
ENTRIES
+B<NOTE:> The code point in the UCA file format (before C<';'>)
+B<must> be a Unicode code point, but not a native code point.
+So C<0063> must always denote C<U+0063>,
+but not a character of C<"\x63">.
+
=item ignoreName
=item ignoreChar
--- see Completely Ignorable, 3.2.2 Variable Weighting, UTR #10.
+-- see Completely Ignorable, 3.2.2 Variable Weighting, UTS #10.
Makes the entry in the table completely ignorable;
i.e. as if the weights were zero at all level.
=item level
--- see 4.3 Form a sort key for each string, UTR #10.
+-- see 4.3 Form a sort key for each string, UTS #10.
Set the maximum level.
Any higher levels than the specified one are ignored.
=item normalization
--- see 4.1 Normalize each input string, UTR #10.
+-- see 4.1 Normalize each input string, UTS #10.
If specified, strings are normalized before preparation of sort keys
(the normalization is executed after preprocess).
=item overrideCJK
--- see 7.1 Derived Collation Elements, UTR #10.
+-- see 7.1 Derived Collation Elements, UTS #10.
By default, mapping of CJK Unified Ideographs
uses the Unicode codepoint order.
=item overrideHangul
--- see 7.1 Derived Collation Elements, UTR #10.
+-- see 7.1 Derived Collation Elements, UTS #10.
By default, Hangul Syllables are decomposed into Hangul Jamo.
But the mapping of Hangul Syllables may be overrided.
=item preprocess
--- see 5.1 Preprocessing, UTR #10.
+-- see 5.1 Preprocessing, UTS #10.
If specified, the coderef is used to preprocess
before the formation of sort keys.
=item rearrange
--- see 3.1.3 Rearrangement, UTR #10.
+-- see 3.1.3 Rearrangement, UTS #10.
Characters that are not coded in logical order and to be rearranged.
By default,
=item table
--- see 3.2 Default Unicode Collation Element Table, UTR #10.
+-- see 3.2 Default Unicode Collation Element Table, UTS #10.
You can use another element table if desired.
The table file must be in your C<lib/Unicode/Collate> directory.
=item undefChar
--- see 6.3.4 Reducing the Repertoire, UTR #10.
+-- see 6.3.4 Reducing the Repertoire, UTS #10.
Undefines the collation element as if it were unassigned in the table.
This reduces the size of the table.
=item upper_before_lower
--- see 6.6 Case Comparisons; 7.3.1 Tertiary Weight Table, UTR #10.
+-- see 6.6 Case Comparisons; 7.3.1 Tertiary Weight Table, UTS #10.
By default, lowercase is before uppercase
and hiragana is before katakana.
B<NOTE>: These tags simplemindedly assume
any lowercase/uppercase or hiragana/katakana distinctions
-should occur in level 3, and their weights at level 3
-should be same as those mentioned in 7.3.1, UTR #10.
-If you define your collation elements which violates this,
-these tags doesn't work validly.
+must occur in level 3, and their weights at level 3
+must be same as those mentioned in 7.3.1, UTS #10.
+If you define your collation elements which violate this requirement,
+these tags don't work validly.
=back
=item C<$sortKey = $Collator-E<gt>getSortKey($string)>
--- see 4.3 Form a sort key for each string, UTR #10.
+-- see 4.3 Form a sort key for each string, UTS #10.
Returns a sort key.
(If C<UCA_Version> is 8, the output is slightly different.)
-=item C<$position = $Collator-E<gt>index($string, $substring)>
+=back
+
+=head2 Methods for Searching
+
+B<DISCLAIMER:> If C<preprocess> or C<normalization> tag 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 the C<rearrange> tag is 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.
+
+=over 4
-=item C<($position, $length) = $Collator-E<gt>index($string, $substring)>
+=item C<$position = $Collator-E<gt>index($string, $substring[, $position])>
--- see 6.8 Searching, UTR #10.
+=item C<($position, $length) = $Collator-E<gt>index($string, $substring[, $position])>
If C<$substring> matches a part of C<$string>, returns
the position of the first occurrence of the matching part in scalar context;
in list context, returns a two-element list of
the position and the length of the matching part.
-B<Notice> that the length of the matching part may differ from
-the length of C<$substring>.
-
-B<Note> that the position and the length are counted on the string
-after the process of preprocess, normalization, and rearrangement.
-Therefore, in case the specified string is not binary equal to
-the preprocessed/normalized/rearranged string, the position and the length
-may differ form those on the specified string. But it is guaranteed
-that, if matched, it returns a non-negative value as C<$position>.
-
If C<$substring> does not match any part of C<$string>,
returns C<-1> in scalar context and
an empty list in list context.
e.g. you say
my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
- my $str = "Ich mu\x{00DF} studieren.";
- my $sub = "m\x{00FC}ss";
+ # (normalization => undef) is REQUIRED.
+ my $str = "Ich muß studieren Perl.";
+ my $sub = "MÜSS";
my $match;
if (my($pos,$len) = $Collator->index($str, $sub)) {
$match = substr($str, $pos, $len);
}
-and get C<"mu\x{00DF}"> in C<$match> since C<"mu>E<223>C<">
-is primary equal to C<"m>E<252>C<ss">.
+and get C<"muß"> in C<$match> since C<"muß">
+is primary equal to C<"MÜSS">.
+
+=item C<$match_ref = $Collator-E<gt>match($string, $substring)>
+
+=item C<($match) = $Collator-E<gt>match($string, $substring)>
+
+If C<$substring> matches a part of C<$string>, in scalar context, returns
+B<a reference to> the first occurrence of the matching part
+(C<$match_ref> is always true if matches,
+since every reference is B<true>);
+in list context, returns the first occurrence of the matching part.
+
+If C<$substring> does not match any part of C<$string>,
+returns C<undef> in scalar context and
+an empty list in list context.
+
+e.g.
+
+ if ($match_ref = $Collator->match($str, $sub)) { # scalar context
+ print "matches [$$match_ref].\n";
+ } else {
+ print "doesn't match.\n";
+ }
+
+ or
+
+ if (($match) = $Collator->match($str, $sub)) { # list context
+ print "matches [$match].\n";
+ } else {
+ print "doesn't match.\n";
+ }
+
+=item C<@match = $Collator-E<gt>gmatch($string, $substring)>
+
+If C<$substring> matches a part of C<$string>, returns
+all the matching parts (or matching count in scalar context).
+
+If C<$substring> does not match any part of C<$string>,
+returns an empty list.
+
+=item C<$count = $Collator-E<gt>subst($string, $substring, $replacement)>
+
+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<$replacement> can be a C<CODEREF>,
+taking the matching part as an argument,
+and returning a string to replace the matching part
+(a bit similar to C<s/(..)/$coderef-E<gt>($1)/e>).
+
+=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>.
+
+C<$replacement> can be a C<CODEREF>,
+taking the matching part as an argument,
+and returning a string to replace the matching part
+(a bit similar to C<s/(..)/$coderef-E<gt>($1)/eg>).
+
+e.g.
+
+ my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
+ # (normalization => undef) is REQUIRED.
+ my $str = "Camel ass came\x{301}l CAMEL horse cAm\0E\0L...";
+ $Collator->gsubst($str, "camel", sub { "<b>$_[0]</b>" });
+
+ # now $str is "<b>Camel</b> ass <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cAm\0E\0L</b>...";
+ # i.e., all the camels are made bold-faced.
=back
=item UCA_Version
-Returns the version number of Unicode Technical Standard 10
-this module consults.
+Returns the version number of UTS #10 this module consults.
=item Base_Unicode_Version
=head2 TODO
-Unicode::Collate has not been ported to EBCDIC. The code mostly would
-work just fine but a decision needs to be made: how the module should
-work in EBCDIC? Should the low 256 characters be understood as
-Unicode or as EBCDIC code points? Should one be chosen or should
-there be a way to do either? Or should such translation be left
-outside the module for the user to do, for example by using
-Encode::from_to()?
-(or utf8::unicode_to_native()/utf8::native_to_unicode()?)
+Unicode::Collate has not been ported to EBCDIC.
+IMHO, use of utf8::unicode_to_native()/utf8::native_to_unicode()
+at the proper postions should allow
+this module to work on EBCDIC platform...
=head2 CAVEAT
handle any combining characters),
assign C<normalization =E<gt> undef> explicitly.
--- see 6.5 Avoiding Normalization, UTR #10.
+-- see 6.5 Avoiding Normalization, UTS #10.
=head2 Conformance Test
for F<CollationTest_NON_IGNORABLE.txt>, a collator via
C<Unicode::Collate-E<gt>new(alternate =E<gt> "non-ignorable", level =E<gt> 3)>.
-B<Unicode::Normalize is required to try this test.>
-
-=head2 BUGS
-
-C<index()> is an experimental method and
-its return value may be unreliable.
-The correct implementation for C<index()> must be based
-on Locale-Sensitive Support: Level 3 in UTR #18,
-F<Unicode Regular Expression Guidelines>.
-
-See also 4.2 Locale-Dependent Graphemes in UTR #18.
+B<Unicode::Normalize is required to try The Conformance Test.>
=head1 AUTHOR
=item http://www.unicode.org/reports/tr10/
-Unicode Collation Algorithm - UTR #10
+Unicode Collation Algorithm - UTS #10
=item http://www.unicode.org/reports/tr10/allkeys.txt
Unicode Normalization Forms - UAX #15
-=item http://www.unicode.org/reports/tr18
-
-Unicode Regular Expression Guidelines - UTR #18
-
=item L<Unicode::Normalize>
=back