File Coverage

blib/lib/Lingua/KO/Hangul/Util.pm

Criterion	Covered	Total	%
statement	169	169	100.0
branch	54	54	100.0
condition	37	38	97.3
subroutine	40	40	100.0
pod	13	13	100.0
total	313	314	99.6

package Lingua::KO::Hangul::Util;

use 5.006001;
use strict;
use warnings;

require Exporter;

our $VERSION = '0.28';
our $PACKAGE = __PACKAGE__;

our @EXPORT = qw(
    decomposeHangul
    composeHangul
    getHangulName
    parseHangulName
    getHangulComposite
);
our @EXPORT_OK = qw(
    decomposeSyllable
    composeSyllable
    decomposeJamo
    composeJamo
    decomposeFull
    getSyllableType
    isStandardForm
    insertFiller
);
our %EXPORT_TAGS = (
    'all' => [ @EXPORT, @EXPORT_OK ],
);

##### The above part is common to XS and PP #####

our @ISA = qw(Exporter);
use Carp;

#####

my @JamoL = ( # Initial (HANGUL CHOSEONG)
    "G", "GG", "N", "D", "DD", "R", "M", "B", "BB",
    "S", "SS", "", "J", "JJ", "C", "K", "T", "P", "H",
  );

my @JamoV = ( # Medial  (HANGUL JUNGSEONG)
    "A", "AE", "YA", "YAE", "EO", "E", "YEO", "YE", "O",
    "WA", "WAE", "OE", "YO", "U", "WEO", "WE", "WI",
    "YU", "EU", "YI", "I",
  );

my @JamoT = ( # Final    (HANGUL JONGSEONG)
    "", "G", "GG", "GS", "N", "NJ", "NH", "D", "L", "LG", "LM",
    "LB", "LS", "LT", "LP", "LH", "M", "B", "BS",
    "S", "SS", "NG", "J", "C", "K", "T", "P", "H",
  );

my $BlockName = "HANGUL SYLLABLE ";

#####

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; # scalar @JamoL
use constant VBase  => 0x1161;
use constant VFinal => 0x1175;
use constant VCount =>     21; # scalar @JamoV
use constant TBase  => 0x11A7;
use constant TFinal => 0x11C2;
use constant TCount =>     28; # scalar @JamoT
use constant JBase  => 0x1100;
use constant JFinal => 0x11FF;
use constant JCount =>    256;

use constant JamoLIni   => 0x1100;
use constant JamoLFin   => 0x1159;
use constant JamoLFill  => 0x115F;
use constant JamoVIni   => 0x1160;
use constant JamoVFin   => 0x11A2;
use constant JamoTIni   => 0x11A8;
use constant JamoTFin   => 0x11F9;

my(%CodeL, %CodeV, %CodeT);
@CodeL{@JamoL} = 0 .. LCount-1;
@CodeV{@JamoV} = 0 .. VCount-1;
@CodeT{@JamoT} = 0 .. TCount-1;

my $IsJ = sub { JBase <= $_[0] && $_[0] <= JFinal };
my $IsS = sub { SBase <= $_[0] && $_[0] <= SFinal };
my $IsL = sub { LBase <= $_[0] && $_[0] <= LFinal };
my $IsV = sub { VBase <= $_[0] && $_[0] <= VFinal };
my $IsT = sub { TBase  < $_[0] && $_[0] <= TFinal };
	      # TBase <= $_[0] is false!
my $IsLV = sub {
    SBase <= $_[0] && $_[0] <= SFinal && (($_[0] - SBase ) % TCount) == 0;
};

#####

# separator is a semicolon, ';'.
my %Map12;   # ("integer;integer" => integer)
my %Map123;  # ("integer;integer;integer" => integer)

my %Decomp = (
0x1101 => [0x1100, 0x1100],
0x1104 => [0x1103, 0x1103],
0x1108 => [0x1107, 0x1107],
0x110A => [0x1109, 0x1109],
0x110D => [0x110C, 0x110C],
0x1113 => [0x1102, 0x1100],
0x1114 => [0x1102, 0x1102],
0x1115 => [0x1102, 0x1103],
0x1116 => [0x1102, 0x1107],
0x1117 => [0x1103, 0x1100],
0x1118 => [0x1105, 0x1102],
0x1119 => [0x1105, 0x1105],
0x111A => [0x1105, 0x1112],
0x111B => [0x1105, 0x110B],
0x111C => [0x1106, 0x1107],
0x111D => [0x1106, 0x110B],
0x111E => [0x1107, 0x1100],
0x111F => [0x1107, 0x1102],
0x1120 => [0x1107, 0x1103],
0x1121 => [0x1107, 0x1109],
0x1122 => [0x1107, 0x1109, 0x1100],
0x1123 => [0x1107, 0x1109, 0x1103],
0x1124 => [0x1107, 0x1109, 0x1107],
0x1125 => [0x1107, 0x1109, 0x1109],
0x1126 => [0x1107, 0x1109, 0x110C],
0x1127 => [0x1107, 0x110C],
0x1128 => [0x1107, 0x110E],
0x1129 => [0x1107, 0x1110],
0x112A => [0x1107, 0x1111],
0x112B => [0x1107, 0x110B],
0x112C => [0x1107, 0x1107, 0x110B],
0x112D => [0x1109, 0x1100],
0x112E => [0x1109, 0x1102],
0x112F => [0x1109, 0x1103],
0x1130 => [0x1109, 0x1105],
0x1131 => [0x1109, 0x1106],
0x1132 => [0x1109, 0x1107],
0x1133 => [0x1109, 0x1107, 0x1100],
0x1134 => [0x1109, 0x1109, 0x1109],
0x1135 => [0x1109, 0x110B],
0x1136 => [0x1109, 0x110C],
0x1137 => [0x1109, 0x110E],
0x1138 => [0x1109, 0x110F],
0x1139 => [0x1109, 0x1110],
0x113A => [0x1109, 0x1111],
0x113B => [0x1109, 0x1112],
0x113D => [0x113C, 0x113C],
0x113F => [0x113E, 0x113E],
0x1141 => [0x110B, 0x1100],
0x1142 => [0x110B, 0x1103],
0x1143 => [0x110B, 0x1106],
0x1144 => [0x110B, 0x1107],
0x1145 => [0x110B, 0x1109],
0x1146 => [0x110B, 0x1140],
0x1147 => [0x110B, 0x110B],
0x1148 => [0x110B, 0x110C],
0x1149 => [0x110B, 0x110E],
0x114A => [0x110B, 0x1110],
0x114B => [0x110B, 0x1111],
0x114D => [0x110C, 0x110B],
0x114F => [0x114E, 0x114E],
0x1151 => [0x1150, 0x1150],
0x1152 => [0x110E, 0x110F],
0x1153 => [0x110E, 0x1112],
0x1156 => [0x1111, 0x1107],
0x1157 => [0x1111, 0x110B],
0x1158 => [0x1112, 0x1112],
0x1162 => [0x1161, 0x1175],
0x1164 => [0x1163, 0x1175],
0x1166 => [0x1165, 0x1175],
0x1168 => [0x1167, 0x1175],
0x116A => [0x1169, 0x1161],
0x116B => [0x1169, 0x1161, 0x1175],
0x116C => [0x1169, 0x1175],
0x116F => [0x116E, 0x1165],
0x1170 => [0x116E, 0x1165, 0x1175],
0x1171 => [0x116E, 0x1175],
0x1174 => [0x1173, 0x1175],
0x1176 => [0x1161, 0x1169],
0x1177 => [0x1161, 0x116E],
0x1178 => [0x1163, 0x1169],
0x1179 => [0x1163, 0x116D],
0x117A => [0x1165, 0x1169],
0x117B => [0x1165, 0x116E],
0x117C => [0x1165, 0x1173],
0x117D => [0x1167, 0x1169],
0x117E => [0x1167, 0x116E],
0x117F => [0x1169, 0x1165],
0x1180 => [0x1169, 0x1165, 0x1175],
0x1181 => [0x1169, 0x1167, 0x1175],
0x1182 => [0x1169, 0x1169],
0x1183 => [0x1169, 0x116E],
0x1184 => [0x116D, 0x1163],
0x1185 => [0x116D, 0x1163, 0x1175],
0x1186 => [0x116D, 0x1167],
0x1187 => [0x116D, 0x1169],
0x1188 => [0x116D, 0x1175],
0x1189 => [0x116E, 0x1161],
0x118A => [0x116E, 0x1161, 0x1175],
0x118B => [0x116E, 0x1165, 0x1173],
0x118C => [0x116E, 0x1167, 0x1175],
0x118D => [0x116E, 0x116E],
0x118E => [0x1172, 0x1161],
0x118F => [0x1172, 0x1165],
0x1190 => [0x1172, 0x1165, 0x1175],
0x1191 => [0x1172, 0x1167],
0x1192 => [0x1172, 0x1167, 0x1175],
0x1193 => [0x1172, 0x116E],
0x1194 => [0x1172, 0x1175],
0x1195 => [0x1173, 0x116E],
0x1196 => [0x1173, 0x1173],
0x1197 => [0x1173, 0x1175, 0x116E],
0x1198 => [0x1175, 0x1161],
0x1199 => [0x1175, 0x1163],
0x119A => [0x1175, 0x1169],
0x119B => [0x1175, 0x116E],
0x119C => [0x1175, 0x1173],
0x119D => [0x1175, 0x119E],
0x119F => [0x119E, 0x1165],
0x11A0 => [0x119E, 0x116E],
0x11A1 => [0x119E, 0x1175],
0x11A2 => [0x119E, 0x119E],
0x11A9 => [0x11A8, 0x11A8],
0x11AA => [0x11A8, 0x11BA],
0x11AC => [0x11AB, 0x11BD],
0x11AD => [0x11AB, 0x11C2],
0x11B0 => [0x11AF, 0x11A8],
0x11B1 => [0x11AF, 0x11B7],
0x11B2 => [0x11AF, 0x11B8],
0x11B3 => [0x11AF, 0x11BA],
0x11B4 => [0x11AF, 0x11C0],
0x11B5 => [0x11AF, 0x11C1],
0x11B6 => [0x11AF, 0x11C2],
0x11B9 => [0x11B8, 0x11BA],
0x11BB => [0x11BA, 0x11BA],
0x11C3 => [0x11A8, 0x11AF],
0x11C4 => [0x11A8, 0x11BA, 0x11A8],
0x11C5 => [0x11AB, 0x11A8],
0x11C6 => [0x11AB, 0x11AE],
0x11C7 => [0x11AB, 0x11BA],
0x11C8 => [0x11AB, 0x11EB],
0x11C9 => [0x11AB, 0x11C0],
0x11CA => [0x11AE, 0x11A8],
0x11CB => [0x11AE, 0x11AF],
0x11CC => [0x11AF, 0x11A8, 0x11BA],
0x11CD => [0x11AF, 0x11AB],
0x11CE => [0x11AF, 0x11AE],
0x11CF => [0x11AF, 0x11AE, 0x11C2],
0x11D0 => [0x11AF, 0x11AF],
0x11D1 => [0x11AF, 0x11B7, 0x11A8],
0x11D2 => [0x11AF, 0x11B7, 0x11BA],
0x11D3 => [0x11AF, 0x11B8, 0x11BA],
0x11D4 => [0x11AF, 0x11B8, 0x11C2],
0x11D5 => [0x11AF, 0x11B8, 0x11BC],
0x11D6 => [0x11AF, 0x11BA, 0x11BA],
0x11D7 => [0x11AF, 0x11EB],
0x11D8 => [0x11AF, 0x11BF],
0x11D9 => [0x11AF, 0x11F9],
0x11DA => [0x11B7, 0x11A8],
0x11DB => [0x11B7, 0x11AF],
0x11DC => [0x11B7, 0x11B8],
0x11DD => [0x11B7, 0x11BA],
0x11DE => [0x11B7, 0x11BA, 0x11BA],
0x11DF => [0x11B7, 0x11EB],
0x11E0 => [0x11B7, 0x11BE],
0x11E1 => [0x11B7, 0x11C2],
0x11E2 => [0x11B7, 0x11BC],
0x11E3 => [0x11B8, 0x11AF],
0x11E4 => [0x11B8, 0x11C1],
0x11E5 => [0x11B8, 0x11C2],
0x11E6 => [0x11B8, 0x11BC],
0x11E7 => [0x11BA, 0x11A8],
0x11E8 => [0x11BA, 0x11AE],
0x11E9 => [0x11BA, 0x11AF],
0x11EA => [0x11BA, 0x11B8],
0x11EC => [0x11BC, 0x11A8],
0x11ED => [0x11BC, 0x11A8, 0x11A8],
0x11EE => [0x11BC, 0x11BC],
0x11EF => [0x11BC, 0x11BF],
0x11F1 => [0x11F0, 0x11BA],
0x11F2 => [0x11F0, 0x11EB],
0x11F3 => [0x11C1, 0x11B8],
0x11F4 => [0x11C1, 0x11BC],
0x11F5 => [0x11C2, 0x11AB],
0x11F6 => [0x11C2, 0x11AF],
0x11F7 => [0x11C2, 0x11B7],
0x11F8 => [0x11C2, 0x11B8],
);

foreach my $char (sort {$a <=> $b} keys %Decomp) {
    $char or croak("$PACKAGE : composition to NULL is not allowed");
    my @dec = @{ $Decomp{$char} };
    @dec == 2 || @dec == 3 or
	croak(sprintf("$PACKAGE : weird decomposition [%04X]", $char));
    if (@dec == 2) {
	$Map12{"$dec[0];$dec[1]"} = $char;
    } else {
	$Map123{"$dec[0];$dec[1];$dec[2]"} = $char;
    }
}

#####

sub getSyllableType($) {
    my $u = shift;
    return
	JamoLIni <= $u && $u <= JamoLFin || $u == JamoLFill ? "L" :
	JamoVIni <= $u && $u <= JamoVFin	     ? "V" :
	JamoTIni <= $u && $u <= JamoTFin	     ? "T" :
	SBase <= $u && $u <= SFinal ?
	    ($u - SBase) % TCount ? "LVT" : "LV" : "NA";
}

my %Fillers = (
    "LT"   => [ 0x1160, 0x115F, 0x1160 ],
    "LNA"  => [ 0x1160 ],
    "TV"   => [ 0x115F ],
    "LVTV" => [ 0x115F ],
    "NAV"  => [ 0x115F ],
    "NAT"  => [ 0x115F, 0x1160 ],
);

sub isStandardForm($) {
    my $str = shift(@_).pack('U*');

    my $ptype = 'NA';
    foreach my $ch (unpack('U*', $str)) {
	my $ctype = getSyllableType($ch);
	return "" if $Fillers{"$ptype$ctype"};
	$ptype = $ctype;
    }
    return $ptype eq "L" ? "" : 1;
}

sub insertFiller($) {
    my $str = shift(@_).pack('U*');
    my $ptype = 'NA';
    my(@ret);
    foreach my $ch (unpack('U*', $str)) {
	my $ctype = getSyllableType($ch);
	$Fillers{"$ptype$ctype"} and
	    push(@ret, @{ $Fillers{"$ptype$ctype"} });
	push @ret, $ch;
	$ptype = $ctype;
    }
    $ptype eq "L" and push(@ret, @{ $Fillers{"LNA"} });
    return pack('U*', @ret);
}

sub getHangulName ($) {
    my $u = shift;
    return undef unless &$IsS($u);
    my $sindex = $u - SBase;
    my $lindex = int( $sindex / NCount);
    my $vindex = int(($sindex % NCount) / TCount);
    my $tindex =      $sindex % TCount;
    return "$BlockName$JamoL[$lindex]$JamoV[$vindex]$JamoT[$tindex]";
}

sub parseHangulName ($) {
    my $arg = shift;
    return undef unless $arg =~ s/$BlockName//o;
    return undef unless $arg =~ /^([^AEIOUWY]*)([AEIOUWY]+)([^AEIOUWY]*)$/;
    return undef unless exists $CodeL{$1}
		 && exists $CodeV{$2} && exists $CodeT{$3};
    return SBase + $CodeL{$1} * NCount + $CodeV{$2} * TCount + $CodeT{$3};
}

sub getHangulComposite ($$) {
    if (&$IsL($_[0]) && &$IsV($_[1])) {
	my $lindex = $_[0] - LBase;
	my $vindex = $_[1] - VBase;
	return (SBase + ($lindex * VCount + $vindex) * TCount);
    }
    if (&$IsLV($_[0]) && &$IsT($_[1])) {
	return($_[0] + $_[1] - TBase);
    }
    return undef;
}

sub decomposeJamo ($) {
    my $str = shift(@_).pack('U*');
    my(@ret);
    foreach my $ch (unpack('U*', $str)) {
	push @ret, $Decomp{$ch} ? @{ $Decomp{$ch} } : ($ch);
    }
    return pack('U*', @ret);
}

sub decomposeSyllable ($) {
    my $str = shift(@_).pack('U*');
    my(@ret);
    foreach my $ch (unpack('U*', $str)) {
	my @r = decomposeHangul($ch);
	push @ret, @r ? @r : ($ch);
    }
    return pack('U*', @ret);
}

sub decomposeHangul ($) {
    my $code = shift;
    return unless &$IsS($code);
    my $sindex = $code - 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) : (),
    );
    wantarray ? @ret : pack('U*', @ret);
}

sub composeJamo ($) {
    my $str = shift(@_).pack('U*');
    my @tmp = unpack('U*', $str);
    for (my $i = 0; $i < @tmp; $i++) {
	next unless &$IsJ($tmp[$i]);

	if ($tmp[$i + 2] && $Map123{"$tmp[$i];$tmp[$i+1];$tmp[$i+2]"}) {
	    $tmp[$i] = $Map123{"$tmp[$i];$tmp[$i+1];$tmp[$i+2]"};
	    $tmp[$i+1] = $tmp[$i+2] = undef;
	    $i += 2;
	}
	elsif ($tmp[$i + 1] && $Map12{"$tmp[$i];$tmp[$i+1]"}) {
	    $tmp[$i] = $Map12{"$tmp[$i];$tmp[$i+1]"};
	    $tmp[$i+1] = undef;
	    $i ++;
	}
    }
    return pack 'U*', grep defined, @tmp;
}

sub composeSyllable ($) {
    my $str = shift(@_).pack('U*');
    my(@ret);
    foreach my $ch (unpack('U*', $str)) {
	push(@ret, $ch) and next unless @ret;

      # 1. check to see if $ret[-1] is L and $ch is V.

	if (&$IsL($ret[-1]) && &$IsV($ch)) {
	    $ret[-1] -= LBase; # LIndex
	    $ch      -= VBase; # VIndex
	    $ret[-1]  = SBase + ($ret[-1] * VCount + $ch) * TCount;
	    next; # discard $ch
	}

      # 2. check to see if $ret[-1] is LV and $ch is T.

	if (&$IsLV($ret[-1]) && &$IsT($ch)) {
	    $ret[-1] += $ch - TBase; # + TIndex
	    next; # discard $ch
	}

      # 3. just append $ch
	push(@ret, $ch);
    }
    return pack('U*', @ret);
}

##### The below part is common to XS and PP #####

sub decomposeFull ($) { decomposeJamo(decomposeSyllable(shift)) }

sub composeHangul ($) {
    my $ret = composeSyllable(shift);
    wantarray ? unpack('U*', $ret) : $ret;
}

1;
__END__