diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Unicode/Normalize.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Unicode/Normalize.pm | 525 |
1 files changed, 30 insertions, 495 deletions
diff --git a/Master/tlpkg/tlperl/lib/Unicode/Normalize.pm b/Master/tlpkg/tlperl/lib/Unicode/Normalize.pm index b11df69cf5b..ff6c0f0dc47 100644 --- a/Master/tlpkg/tlperl/lib/Unicode/Normalize.pm +++ b/Master/tlpkg/tlperl/lib/Unicode/Normalize.pm @@ -16,7 +16,7 @@ use Carp; no warnings 'utf8'; -our $VERSION = '1.18'; +our $VERSION = '1.25'; our $PACKAGE = __PACKAGE__; our @EXPORT = qw( NFC NFD NFKC NFKD ); @@ -45,501 +45,22 @@ sub pack_U { } sub unpack_U { + + # The empty pack returns an empty UTF-8 string, so the effect is to force + # the shifted parameter into being UTF-8. This allows this to work on + # Perl 5.6, where there is no utf8::upgrade(). return unpack('U*', shift(@_).pack('U*')); } require Exporter; -our @ISA = qw(Exporter); -use File::Spec; - -our %Combin; # $codepoint => $number : combination class -our %Canon; # $codepoint => \@codepoints : canonical decomp. -our %Compat; # $codepoint => \@codepoints : compat. decomp. -our %Compos; # $1st,$2nd => $codepoint : composite -our %Exclus; # $codepoint => 1 : composition exclusions -our %Single; # $codepoint => 1 : singletons -our %NonStD; # $codepoint => 1 : non-starter decompositions -our %Comp2nd; # $codepoint => 1 : may be composed with a prev char. - -# from core Unicode database -our $Combin = do "unicore/CombiningClass.pl" - || do "unicode/CombiningClass.pl" - || croak "$PACKAGE: CombiningClass.pl not found"; -our $Decomp = do "unicore/Decomposition.pl" - || do "unicode/Decomposition.pl" - || croak "$PACKAGE: Decomposition.pl not found"; - -# CompositionExclusions.txt since Unicode 3.2.0 -our @CompEx = qw( - 0958 0959 095A 095B 095C 095D 095E 095F 09DC 09DD 09DF 0A33 0A36 - 0A59 0A5A 0A5B 0A5E 0B5C 0B5D 0F43 0F4D 0F52 0F57 0F5C 0F69 0F76 - 0F78 0F93 0F9D 0FA2 0FA7 0FAC 0FB9 FB1D FB1F FB2A FB2B FB2C FB2D - FB2E FB2F FB30 FB31 FB32 FB33 FB34 FB35 FB36 FB38 FB39 FB3A FB3B - FB3C FB3E FB40 FB41 FB43 FB44 FB46 FB47 FB48 FB49 FB4A FB4B FB4C - FB4D FB4E 2ADC 1D15E 1D15F 1D160 1D161 1D162 1D163 1D164 1D1BB - 1D1BC 1D1BD 1D1BE 1D1BF 1D1C0 -); - -# definition of Hangul constants -use constant SBase => 0xAC00; -use constant SFinal => 0xD7A3; # SBase -1 + SCount -use constant SCount => 11172; # LCount * NCount -use constant NCount => 588; # VCount * TCount -use constant LBase => 0x1100; -use constant LFinal => 0x1112; -use constant LCount => 19; -use constant VBase => 0x1161; -use constant VFinal => 0x1175; -use constant VCount => 21; -use constant TBase => 0x11A7; -use constant TFinal => 0x11C2; -use constant TCount => 28; - -sub decomposeHangul { - my $sindex = $_[0] - SBase; - my $lindex = int( $sindex / NCount); - my $vindex = int(($sindex % NCount) / TCount); - my $tindex = $sindex % TCount; - my @ret = ( - LBase + $lindex, - VBase + $vindex, - $tindex ? (TBase + $tindex) : (), - ); - return wantarray ? @ret : pack_U(@ret); -} - -########## getting full decomposition ########## - -## converts string "hhhh hhhh hhhh" to a numeric list -## (hex digits separated by spaces) -sub _getHexArray { map hex, $_[0] =~ /\G *([0-9A-Fa-f]+)/g } - -while ($Combin =~ /(.+)/g) { - my @tab = split /\t/, $1; - my $ini = hex $tab[0]; - if ($tab[1] eq '') { - $Combin{$ini} = $tab[2]; - } else { - $Combin{$_} = $tab[2] foreach $ini .. hex($tab[1]); - } -} - -while ($Decomp =~ /(.+)/g) { - my @tab = split /\t/, $1; - my $compat = $tab[2] =~ s/<[^>]+>//; - my $dec = [ _getHexArray($tab[2]) ]; # decomposition - my $ini = hex($tab[0]); # initial decomposable character - my $end = $tab[1] eq '' ? $ini : hex($tab[1]); - # ($ini .. $end) is the range of decomposable characters. - - foreach my $u ($ini .. $end) { - $Compat{$u} = $dec; - $Canon{$u} = $dec if ! $compat; - } -} - -for my $s (@CompEx) { - my $u = hex $s; - next if !$Canon{$u}; # not assigned - next if $u == 0xFB1D && !$Canon{0x1D15E}; # 3.0.1 before Corrigendum #2 - $Exclus{$u} = 1; -} - -foreach my $u (keys %Canon) { - my $dec = $Canon{$u}; - - if (@$dec == 2) { - if ($Combin{ $dec->[0] }) { - $NonStD{$u} = 1; - } else { - $Compos{ $dec->[0] }{ $dec->[1] } = $u; - $Comp2nd{ $dec->[1] } = 1 if ! $Exclus{$u}; - } - } elsif (@$dec == 1) { - $Single{$u} = 1; - } else { - my $h = sprintf '%04X', $u; - croak("Weird Canonical Decomposition of U+$h"); - } -} - -# modern HANGUL JUNGSEONG and HANGUL JONGSEONG jamo -foreach my $j (0x1161..0x1175, 0x11A8..0x11C2) { - $Comp2nd{$j} = 1; -} - -sub getCanonList { - my @src = @_; - my @dec = map { - (SBase <= $_ && $_ <= SFinal) ? decomposeHangul($_) - : $Canon{$_} ? @{ $Canon{$_} } : $_ - } @src; - return join(" ",@src) eq join(" ",@dec) ? @dec : getCanonList(@dec); - # condition @src == @dec is not ok. -} - -sub getCompatList { - my @src = @_; - my @dec = map { - (SBase <= $_ && $_ <= SFinal) ? decomposeHangul($_) - : $Compat{$_} ? @{ $Compat{$_} } : $_ - } @src; - return join(" ",@src) eq join(" ",@dec) ? @dec : getCompatList(@dec); - # condition @src == @dec is not ok. -} - -# exhaustive decomposition -foreach my $key (keys %Canon) { - $Canon{$key} = [ getCanonList($key) ]; -} - -# exhaustive decomposition -foreach my $key (keys %Compat) { - $Compat{$key} = [ getCompatList($key) ]; -} - -sub getHangulComposite ($$) { - if ((LBase <= $_[0] && $_[0] <= LFinal) - && (VBase <= $_[1] && $_[1] <= VFinal)) { - my $lindex = $_[0] - LBase; - my $vindex = $_[1] - VBase; - return (SBase + ($lindex * VCount + $vindex) * TCount); - } - if ((SBase <= $_[0] && $_[0] <= SFinal && (($_[0] - SBase ) % TCount) == 0) - && (TBase < $_[1] && $_[1] <= TFinal)) { - return($_[0] + $_[1] - TBase); - } - return undef; -} - -########## - -sub getCombinClass ($) { - my $uv = 0 + shift; - return $Combin{$uv} || 0; -} - -sub getCanon ($) { - my $uv = 0 + shift; - return exists $Canon{$uv} - ? pack_U(@{ $Canon{$uv} }) - : (SBase <= $uv && $uv <= SFinal) - ? scalar decomposeHangul($uv) - : undef; -} - -sub getCompat ($) { - my $uv = 0 + shift; - return exists $Compat{$uv} - ? pack_U(@{ $Compat{$uv} }) - : (SBase <= $uv && $uv <= SFinal) - ? scalar decomposeHangul($uv) - : undef; -} - -sub getComposite ($$) { - my $uv1 = 0 + shift; - my $uv2 = 0 + shift; - my $hangul = getHangulComposite($uv1, $uv2); - return $hangul if $hangul; - return $Compos{ $uv1 } && $Compos{ $uv1 }{ $uv2 }; -} - -sub isExclusion ($) { - my $uv = 0 + shift; - return exists $Exclus{$uv}; -} - -sub isSingleton ($) { - my $uv = 0 + shift; - return exists $Single{$uv}; -} - -sub isNonStDecomp($) { - my $uv = 0 + shift; - return exists $NonStD{$uv}; -} - -sub isComp2nd ($) { - my $uv = 0 + shift; - return exists $Comp2nd{$uv}; -} - -sub isNFC_MAYBE ($) { - my $uv = 0 + shift; - return exists $Comp2nd{$uv}; -} - -sub isNFKC_MAYBE($) { - my $uv = 0 + shift; - return exists $Comp2nd{$uv}; -} - -sub isNFD_NO ($) { - my $uv = 0 + shift; - return exists $Canon {$uv} || (SBase <= $uv && $uv <= SFinal); -} - -sub isNFKD_NO ($) { - my $uv = 0 + shift; - return exists $Compat{$uv} || (SBase <= $uv && $uv <= SFinal); -} - -sub isComp_Ex ($) { - my $uv = 0 + shift; - return exists $Exclus{$uv} || exists $Single{$uv} || exists $NonStD{$uv}; -} - -sub isNFC_NO ($) { - my $uv = 0 + shift; - return exists $Exclus{$uv} || exists $Single{$uv} || exists $NonStD{$uv}; -} - -sub isNFKC_NO ($) { - my $uv = 0 + shift; - return 1 if $Exclus{$uv} || $Single{$uv} || $NonStD{$uv}; - return '' if (SBase <= $uv && $uv <= SFinal) || !exists $Compat{$uv}; - return 1 if ! exists $Canon{$uv}; - return pack('N*', @{ $Canon{$uv} }) ne pack('N*', @{ $Compat{$uv} }); -} - -## -## string decompose(string, compat?) -## -sub decompose ($;$) -{ - my $hash = $_[1] ? \%Compat : \%Canon; - return pack_U map { - $hash->{ $_ } ? @{ $hash->{ $_ } } : - (SBase <= $_ && $_ <= SFinal) ? decomposeHangul($_) : $_ - } unpack_U($_[0]); -} - -## -## string reorder(string) -## -sub reorder ($) -{ - my @src = unpack_U($_[0]); - - for (my $i=0; $i < @src;) { - $i++, next if ! $Combin{ $src[$i] }; +##### The above part is common to XS and PP ##### - my $ini = $i; - $i++ while $i < @src && $Combin{ $src[$i] }; +our @ISA = qw(Exporter DynaLoader); +require DynaLoader; +bootstrap Unicode::Normalize $VERSION; - my @tmp = sort { - $Combin{ $src[$a] } <=> $Combin{ $src[$b] } || $a <=> $b - } $ini .. $i - 1; - - @src[ $ini .. $i - 1 ] = @src[ @tmp ]; - } - return pack_U(@src); -} - - -## -## string compose(string) -## -## S : starter; NS : not starter; -## -## composable sequence begins at S. -## S + S or (S + S) + S may be composed. -## NS + NS must not be composed. -## -sub compose ($) -{ - my @src = unpack_U($_[0]); - - for (my $s = 0; $s+1 < @src; $s++) { - next unless defined $src[$s] && ! $Combin{ $src[$s] }; - # S only; removed or combining are skipped as a starter. - - my($c, $blocked, $uncomposed_cc); - for (my $j = $s+1; $j < @src && !$blocked; $j++) { - ($Combin{ $src[$j] } ? $uncomposed_cc : $blocked) = 1; - - # S + C + S => S-S + C would be blocked. - next if $blocked && $uncomposed_cc; - - # blocked by same CC (and higher CC: revised D2) - next if defined $src[$j-1] && $Combin{ $src[$j-1] } - && $Combin{ $src[$j-1] } >= $Combin{ $src[$j] }; - - $c = getComposite($src[$s], $src[$j]); - - # no composite or is exclusion - next if !$c || $Exclus{$c}; - - # replace by composite - $src[$s] = $c; $src[$j] = undef; - if ($blocked) { $blocked = 0 } else { -- $uncomposed_cc } - } - } - return pack_U(grep defined, @src); -} - - -## -## string composeContiguous(string) -## -sub composeContiguous ($) -{ - my @src = unpack_U($_[0]); - - for (my $s = 0; $s+1 < @src; $s++) { - next unless defined $src[$s] && ! $Combin{ $src[$s] }; - # S only; removed or combining are skipped as a starter. - - for (my $j = $s+1; $j < @src; $j++) { - my $c = getComposite($src[$s], $src[$j]); - - # no composite or is exclusion - last if !$c || $Exclus{$c}; - - # replace by composite - $src[$s] = $c; $src[$j] = undef; - } - } - return pack_U(grep defined, @src); -} - - -## -## normalization forms -## - -use constant COMPAT => 1; - -sub NFD ($) { reorder(decompose($_[0])) } -sub NFKD ($) { reorder(decompose($_[0], COMPAT)) } -sub NFC ($) { compose(reorder(decompose($_[0]))) } -sub NFKC ($) { compose(reorder(decompose($_[0], COMPAT))) } -sub FCC ($) { composeContiguous(reorder(decompose($_[0]))) } - -## -## quick check -## - -sub checkNFD ($) -{ - my $preCC = 0; - my $curCC; - for my $uv (unpack_U($_[0])) { - $curCC = $Combin{ $uv } || 0; - return '' if $preCC > $curCC && $curCC != 0; - return '' if exists $Canon{$uv} || (SBase <= $uv && $uv <= SFinal); - $preCC = $curCC; - } - return 1; -} - -sub checkNFKD ($) -{ - my $preCC = 0; - my $curCC; - for my $uv (unpack_U($_[0])) { - $curCC = $Combin{ $uv } || 0; - return '' if $preCC > $curCC && $curCC != 0; - return '' if exists $Compat{$uv} || (SBase <= $uv && $uv <= SFinal); - $preCC = $curCC; - } - return 1; -} - -sub checkNFC ($) -{ - my $preCC = 0; - my($curCC, $isMAYBE); - for my $uv (unpack_U($_[0])) { - $curCC = $Combin{ $uv } || 0; - return '' if $preCC > $curCC && $curCC != 0; - - if (isNFC_MAYBE($uv)) { - $isMAYBE = 1; - } elsif (isNFC_NO($uv)) { - return ''; - } - $preCC = $curCC; - } - return $isMAYBE ? undef : 1; -} - -sub checkNFKC ($) -{ - my $preCC = 0; - my($curCC, $isMAYBE); - for my $uv (unpack_U($_[0])) { - $curCC = $Combin{ $uv } || 0; - return '' if $preCC > $curCC && $curCC != 0; - - if (isNFKC_MAYBE($uv)) { - $isMAYBE = 1; - } elsif (isNFKC_NO($uv)) { - return ''; - } - $preCC = $curCC; - } - return $isMAYBE ? undef : 1; -} - -sub checkFCD ($) -{ - my $preCC = 0; - my $curCC; - for my $uv (unpack_U($_[0])) { - # Hangul syllable need not decomposed since cc[any Jamo] == 0; - my @uvCan = exists $Canon{$uv} ? @{ $Canon{$uv} } : ($uv); - - $curCC = $Combin{ $uvCan[0] } || 0; - return '' if $curCC != 0 && $curCC < $preCC; - $preCC = $Combin{ $uvCan[-1] } || 0; - } - return 1; -} - -sub checkFCC ($) -{ - my $preCC = 0; - my($curCC, $isMAYBE); - for my $uv (unpack_U($_[0])) { - # Hangul syllable need not decomposed since cc[any Jamo] == 0; - my @uvCan = exists $Canon{$uv} ? @{ $Canon{$uv} } : ($uv); - - $curCC = $Combin{ $uvCan[0] } || 0; - return '' if $curCC != 0 && $curCC < $preCC; - - if (isNFC_MAYBE($uv)) { - $isMAYBE = 1; - } elsif (isNFC_NO($uv)) { - return ''; - } - - $preCC = $Combin{ $uvCan[-1] } || 0; - } - return $isMAYBE ? undef : 1; -} - -## -## split on last starter -## - -sub splitOnLastStarter -{ - my $str = pack_U(unpack_U(shift)); - if ($str eq '') { - return ('', ''); - } - - my $ch; - my $unproc = ""; - do { - $ch = chop($str); - $unproc = $ch.$unproc; - } while (getCombinClass(unpack 'U', $ch) && $str ne ""); - return ($str, $unproc); -} +##### The below part is common to XS and PP ##### ## ## normalize @@ -644,7 +165,10 @@ C<$string> is used as a string under character semantics (see F<perlunicode>). C<$code_point> should be an unsigned integer representing a Unicode code point. -Note: Do not use a floating point nor a negative sign in C<$code_point>. +Note: Between XSUB and pure Perl, there is an incompatibility +about the interpretation of C<$code_point> as a decimal number. +XSUB converts C<$code_point> to an unsigned integer, but pure Perl does not. +Do not use a floating point nor a negative sign in C<$code_point>. =head2 Normalization Forms @@ -1019,22 +543,29 @@ C<normalize> and other some functions: on request. Since this module refers to perl core's Unicode database in the directory F</lib/unicore> (or formerly F</lib/unicode>), the Unicode version of -normalization implemented by this module depends on your perl's version. +normalization implemented by this module depends on what has been +compiled into your perl. The following table lists the default Unicode +version that comes with various perl versions. (It is possible to change +the Unicode version in any perl version to be any earlier Unicode version, +so one could cause Unicode 3.2 to be used in any perl version starting with +5.8.0. See C<$Config{privlib}>/F<unicore/README.perl>. perl's version implemented Unicode version 5.6.1 3.0.1 5.7.2 3.1.0 5.7.3 3.1.1 (normalization is same as 3.1.0) 5.8.0 3.2.0 - 5.8.1-5.8.3 4.0.0 - 5.8.4-5.8.6 4.0.1 (normalization is same as 4.0.0) - 5.8.7-5.8.8 4.1.0 + 5.8.1-5.8.3 4.0.0 + 5.8.4-5.8.6 4.0.1 (normalization is same as 4.0.0) + 5.8.7-5.8.8 4.1.0 5.10.0 5.0.0 - 5.8.9, 5.10.1 5.1.0 + 5.8.9, 5.10.1 5.1.0 5.12.x 5.2.0 5.14.x 6.0.0 5.16.x 6.1.0 5.18.x 6.2.0 + 5.20.x 6.3.0 + 5.22.x 7.0.0 =item Correction of decomposition mapping @@ -1062,8 +593,12 @@ lower than 4.1.0. SADAHIRO Tomoyuki <SADAHIRO@cpan.org> +Currently maintained by <perl5-porters@perl.org> + Copyright(C) 2001-2012, SADAHIRO Tomoyuki. Japan. All rights reserved. +=head1 LICENSE + This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |