File Coverage

blib/lib/Text/Phonetic/DaitchMokotoff.pm
Criterion Covered Total %
statement 44 44 100.0
branch 15 16 93.7
condition 3 3 100.0
subroutine 5 5 100.0
pod n/a
total 67 68 98.5


line stmt bran cond sub pod time code
1             # ============================================================================
2             package Text::Phonetic::DaitchMokotoff;
3             # ============================================================================
4 3     3   104359 use utf8;
  3         18  
  3         13  
5              
6 3     3   379 use Moo;
  3         8052  
  3         22  
7             extends qw(Text::Phonetic);
8              
9             our $VERSION = $Text::Phonetic::VERSION;
10              
11             our @RULES = (
12             ["SCHTSCH", 2, 4, 4],
13             ["SCHTSH", 2, 4, 4],
14             ["SCHTCH", 2, 4, 4],
15             ["SHTCH", 2, 4, 4],
16             ["SHTSH", 2, 4, 4],
17             ["STSCH", 2, 4, 4],
18             ["TTSCH", 4, 4, 4],
19             ["ZHDZH", 2, 4, 4],
20             ["SHCH", 2, 4, 4],
21             ["SCHT", 2, 43, 43],
22             ["SCHD", 2, 43, 43],
23             ["STCH", 2, 4, 4],
24             ["STRZ", 2, 4, 4],
25             ["STRS", 2, 4, 4],
26             ["STSH", 2, 4, 4],
27             ["SZCZ", 2, 4, 4],
28             ["SZCS", 2, 4, 4],
29             ["TTCH", 4, 4, 4],
30             ["TSCH", 4, 4, 4],
31             ["TTSZ", 4, 4, 4],
32             ["ZDZH", 2, 4, 4],
33             ["ZSCH", 4, 4, 4],
34             ["CHS", 5, 54, 54],
35             ["CSZ", 4, 4, 4],
36             ["CZS", 4, 4, 4],
37             ["DRZ", 4, 4, 4],
38             ["DRS", 4, 4, 4],
39             ["DSH", 4, 4, 4],
40             ["DSZ", 4, 4, 4],
41             ["DZH", 4, 4, 4],
42             ["DZS", 4, 4, 4],
43             ["SCH", 4, 4, 4],
44             ["SHT", 2, 43, 43],
45             ["SZT", 2, 43, 43],
46             ["SHD", 2, 43, 43],
47             ["SZD", 2, 43, 43],
48             ["TCH", 4, 4, 4],
49             ["TRZ", 4, 4, 4],
50             ["TRS", 4, 4, 4],
51             ["TSH", 4, 4, 4],
52             ["TTS", 4, 4, 4],
53             ["TTZ", 4, 4, 4],
54             ["TZS", 4, 4, 4],
55             ["TSZ", 4, 4, 4],
56             ["ZDZ", 2, 4, 4],
57             ["ZHD", 2, 43, 43],
58             ["ZSH", 4, 4, 4],
59             ["AI", 0, 1, undef],
60             ["AJ", 0, 1, undef],
61             ["AY", 0, 1, undef],
62             ["AU", 0, 7, undef],
63             ["CZ", 4, 4, 4],
64             ["CS", 4, 4, 4],
65             ["DS", 4, 4, 4],
66             ["DZ", 4, 4, 4],
67             ["DT", 3, 3, 3],
68             ["EI", 0, 1, undef],
69             ["EJ", 0, 1, undef],
70             ["EY", 0, 1, undef],
71             ["EU", 1, 1, undef],
72             ["IA", 1, undef, undef],
73             ["IE", 1, undef, undef],
74             ["IO", 1, undef, undef],
75             ["IU", 1, undef, undef],
76             ["KS", 5, 54, 54],
77             ["KH", 5, 5, 5],
78             ["MN", 66, 66, 66],
79             ["NM", 66, 66, 66],
80             ["OI", 0, 1, undef],
81             ["OJ", 0, 1, undef],
82             ["OY", 0, 1, undef],
83             ["PF", 7, 7, 7],
84             ["PH", 7, 7, 7],
85             ["SH", 4, 4, 4],
86             ["SC", 2, 4, 4],
87             ["ST", 2, 43, 43],
88             ["SD", 2, 43, 43],
89             ["SZ", 4, 4, 4],
90             ["TH", 3, 3, 3],
91             ["TS", 4, 4, 4],
92             ["TC", 4, 4, 4],
93             ["TZ", 4, 4, 4],
94             ["UI", 0, 1, undef],
95             ["UJ", 0, 1, undef],
96             ["UY", 0, 1, undef],
97             ["UE", 0, 1, undef],
98             ["ZD", 2, 43, 43],
99             ["ZH", 4, 4, 4],
100             ["ZS", 4, 4, 4],
101             ["RZ", [94,4], [94,4], [94,4]],
102             ["CH", [5,4], [5,4], [5,4]],
103             ["CK", [4,45], [4,45], [4,45]],
104             ["RS", [94,4], [94,4], [94,4]],
105             ["FB", 7, 7, 7],
106             ["A", 0, undef, undef],
107             ["B", 7, 7, 7],
108             ["D", 3, 3, 3],
109             ["E", 0, undef, undef],
110             ["F", 7, 7, 7],
111             ["G", 5, 5, 5],
112             ["H", 5, 5, undef],
113             ["I", 0, undef, undef],
114             ["K", 5, 5, 5],
115             ["L", 8, 8, 8],
116             ["M", 6, 6, 6],
117             ["N", 6, 6, 6],
118             ["O", 0, undef, undef],
119             ["P", 7, 7, 7],
120             ["Q", 5, 5, 5],
121             ["R", 9, 9, 9],
122             ["S", 4, 4, 4],
123             ["T", 3, 3, 3],
124             ["U", 0, undef, undef],
125             ["V", 7, 7, 7],
126             ["W", 7, 7, 7],
127             ["X", 5, 54, 54],
128             ["Y", 1, undef, undef],
129             ["Z", 4, 4, 4],
130             ["C", [5,4], [5,4], [5,4]],
131             ["J", [1,4], [4,undef], [4,undef]],
132             );
133              
134             sub _do_compare {
135 2     2   8 my ($self,$result1,$result2) = @_;
136              
137 2 100       12 return 50
138             if Text::Phonetic::_compare_list($result1,$result2);
139              
140 1         14 return 0;
141             }
142              
143             sub _do_encode {
144 32     32   85 my ($self,$string) = @_;
145              
146 32         55 my $match_index;
147             my $last_match;
148 32         74 my $result_list = [''];
149              
150 32         78 $string = uc($string);
151 32         81 $string =~ tr/A-Z//cd;
152              
153 32         76 while (length($string)) {
154             # Loop all rules
155 174         279 RULES: foreach my $rule (@RULES) {
156              
157             # Check if rule matches
158             #if ($string =~ s/^([AEIOUJY]{2})([AEIOU])//i) {
159              
160 16919 100       95988 if ($string =~ s/^$rule->[0]//) {
161             # Is Start of a string?
162 174 100       703 if ($result_list->[0] eq '') {
    100          
163 32         50 $match_index = 1;
164             # Before a vowel?
165             } elsif (Text::Phonetic::_is_inlist(substr($string,0,1),qw(A E I O U))) {
166 31         56 $match_index = 2;
167             # Other situation
168             } else{
169 111         171 $match_index = 3;
170             }
171 174 100       389 unless (defined $rule->[$match_index]) {
172 57         88 undef $last_match;
173 57         197 last RULES;
174             }
175 117 100 100     310 last RULES if (defined($last_match) && $last_match eq $rule->[$match_index]);
176 111         170 $last_match = $rule->[$match_index];
177 111         191 $result_list = _add_result($result_list,$rule->[$match_index]);
178 111         301 last RULES;
179             }
180             }
181             }
182              
183 32         84 foreach my $result (@$result_list) {
184 38         100 $result .= '0' x (6-length $result);
185 38         74 $result = substr($result,0,6);
186             }
187              
188 32         126 return $result_list;
189             }
190              
191             sub _add_result {
192 111     111   152 my $result = shift;
193 111         146 my $rule = shift;
194              
195 111 50       179 return $result unless defined $rule;
196              
197 111 100       193 if (ref($rule) eq 'ARRAY') {
198 6         22 my $newresult = [];
199 6         11 foreach my $result_string (@$result) {
200 6         13 foreach my $rule_string (@$rule) {
201 12         37 push @$newresult,$result_string.$rule_string;
202             }
203             }
204 6         15 return $newresult;
205             } else {
206 105         194 foreach my $result_string (@$result) {
207 106         194 $result_string .= $rule;
208             }
209 105         226 return $result;
210             }
211             }
212              
213             1;
214              
215             =encoding utf8
216              
217             =pod
218              
219             =head1 NAME
220              
221             Text::Phonetic::DaitchMokotoff - Daitch-Mokotoff algorithm
222              
223             =head1 DESCRIPTION
224              
225             Daitch-Mokotoff Soundex (D-M Soundex) is a phonetic algorithm invented in 1985
226             by genealogist Gary Mokotoff, and later improved by Randy Daitch, both of the
227             Jewish Genealogical Society. It is a refinement of the Russell and American
228             Soundex algorithms designed to allow matching of Slavic and Yiddish surnames
229             with similar pronunciation but differences in spelling. (Wikipedia, 2007)
230              
231             Some strings in the Daitch-Mokotoff algorithm produce ambigous results.
232             Therefore the results are always returned as Array references, even if there
233             is only a single result.
234              
235             =head1 AUTHOR
236              
237             Maroš Kollár
238             CPAN ID: MAROS
239             maros [at] k-1.com
240             http://www.k-1.com
241              
242             =head1 COPYRIGHT
243              
244             Text::Phonetic::Metaphone is Copyright (c) 2006,2007 Maroš. Kollár.
245             All rights reserved.
246              
247             This program is free software; you can redistribute
248             it and/or modify it under the same terms as Perl itself.
249              
250             The full text of the license can be found in the
251             LICENSE file included with this module.
252              
253             =head1 SEE ALSO
254              
255             Description of the algorithm can be found at
256             L
257              
258             L
259              
260             =cut