File Coverage

blib/lib/Lingua/KO/Munja.pm
Criterion Covered Total %
statement 63 67 94.0
branch 5 8 62.5
condition n/a
subroutine 10 10 100.0
pod 2 6 33.3
total 80 91 87.9


line stmt bran cond sub pod time code
1             package Lingua::KO::Munja;
2 2     2   16173 use warnings;
  2         3  
  2         59  
3 2     2   7 use strict;
  2         2  
  2         134  
4             require Exporter;
5             our @ISA = qw(Exporter);
6             our @EXPORT_OK = qw/roman2hangul hangul2roman/;
7             our %EXPORT_TAGS = (
8             all => \@EXPORT_OK,
9             );
10             our $VERSION = '0.07';
11 2     2   884 use Convert::Moji 'make_regex';
  2         3138  
  2         1393  
12              
13             my $verbose;
14              
15             sub makearegex
16             {
17 6     6 0 14 my @possibles = @_;
18 6         9 @possibles = map {$_ =~ s/^-$//; $_} @possibles;
  136         89  
  136         115  
19 6         22 make_regex (@possibles);
20             }
21              
22             my @initial = qw(
23             g kk n d tt r m b pp s ss - j jj
24             ch k t p h
25             );
26              
27             my $initial_re = makearegex (@initial);
28              
29             my %initial = a2h (@initial);
30              
31             my @peak = qw(
32             a ae ya yae eo e yeo ye o wa wae oe yo u
33             wo we wi yu eu ui i
34             );
35              
36             my $peak_re = makearegex (@peak);
37              
38             my %peak = a2h (@peak);
39              
40             my @final = qw(
41             - g kk ks n nj nh d l lg lm lb ls lt
42             lp lh m b ps s ss ng j c k t p h
43             );
44              
45             my $final_re = makearegex (@final);
46              
47             my %final = a2h (@final);
48              
49             sub hangul
50             {
51 17     17 0 27 my ($initial, $peak, $final) = @_;
52 17         18 for ($initial, $peak, $final) {
53 51 100       66 if (! $_) {
54 15         33 $_ = '-';
55             }
56             }
57 17 50       21 if ($verbose) {
58 0         0 print "Initial = $initial, peak = $peak, final = $final\n";
59 0         0 print "Initial = $initial{$initial}, peak = $peak{$peak}, final = $final{$final}\n";
60             }
61 17         38 my $x = (($initial{$initial} * 21) + $peak{$peak}) * 28 + $final{$final};
62 17         23 my $hangul = chr (0xAC00 + $x);
63 17         28 return $hangul;
64             }
65              
66             sub roman2hangul
67             {
68 6     6 1 9081 my ($input) = @_;
69 6         16 my $match = "$initial_re$peak_re$final_re";
70 6         11 $match =~ s/\\-//g;
71 6         260 while ($input =~ s/((?:$match)+)/ROMAN/) {
72 7         25 my $i = $1;
73 7 50       11 if ($verbose) {
74 0         0 print "Looking at '$i' from '$input'.\n";
75             }
76 7         8 my @syllables;
77 7         186 while ($i =~ s/($match)$//g) {
78 17 50       32 if ($verbose) {
79 0         0 print "pushing $1\n";
80             }
81 17         76 unshift @syllables, $1;
82             }
83 7         8 my @hangul;
84 7         11 for my $s (@syllables) {
85 17         14 my $h = $s;
86 17         203 $h =~ s/^$match$/hangul ($1, $2, $3)/ge;
  17         26  
87 17         39 push @hangul, $h;
88             }
89 7         12 my $output = join '', @hangul;
90 7         49 $input =~ s/ROMAN/$output/;
91             }
92 6         17 return $input;
93             }
94              
95             # Given an array, make a hash with the elements as keys and a unique
96             # number as values.
97              
98             sub a2h
99             {
100 6     6 0 15 my @array = @_;
101 6         15 my %hash;
102 6         6 my $count = 0;
103 6         7 for my $k (@array) {
104 136         110 $hash{$k} = $count;
105 136         93 $count++;
106             }
107 6         52 return %hash;
108             }
109              
110             sub romanize
111             {
112 16     16 0 17 my ($char) = @_;
113 16         13 my $han = ord ($char) - 0xAC00;
114 16         17 my $init = int ($han / (21 * 28));
115 16         16 my $peak = int ($han / 28) % 21;
116 16         8 my $final = $han % 28;
117 16         26 my $roman = join '', $initial[$init], $peak[$peak], $final[$final];
118 16         34 return $roman;
119             }
120              
121             sub hangul2roman
122             {
123 5     5 1 922 my ($hangul) = @_;
124 2     2   673 $hangul =~ s/(\p{Hangul})/romanize ($1)/ge;
  2         9  
  2         24  
  5         23  
  16         21  
125 5         15 $hangul =~ s/-//g;
126 5         11 return $hangul;
127             }
128              
129             1;
130