summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Unicode/Normalize.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Unicode/Normalize.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Unicode/Normalize.pm525
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.