File Coverage

blib/lib/Text/Phonetic/Phonem.pm
Criterion Covered Total %
statement 19 19 100.0
branch 2 2 100.0
condition n/a
subroutine 4 4 100.0
pod n/a
total 25 25 100.0


line stmt bran cond sub pod time code
1             # ============================================================================
2             package Text::Phonetic::Phonem;
3             # ============================================================================
4 4     4   92559 use utf8;
  4         11  
  4         23  
5              
6 4     4   514 use Moo;
  4         8458  
  4         21  
7             extends qw(Text::Phonetic);
8              
9             __PACKAGE__->meta->make_immutable;
10              
11             our $VERSION = $Text::Phonetic::VERSION;
12              
13             our %DOUBLECHARS = (
14             SC =>'C',
15             SZ =>'C',
16             CZ =>'C',
17             TZ =>'C',
18             SZ =>'C',
19             TS =>'C',
20             KS =>'X',
21             PF =>'V',
22             QU =>'KW',
23             PH =>'V',
24             UE =>'Y',
25             AE =>'E',
26             OE =>'Ö',
27             EI =>'AY',
28             EY =>'AY',
29             EU =>'OY',
30             AU =>'A§',
31             OU =>'§ '
32             );
33              
34             sub _do_encode {
35 17     17   34 my ($self,$string) = @_;
36            
37 17         41 $string = uc($string);
38 17         42 $string =~ tr/A-Z//cd;
39              
40             # Iterate over two character substitutions
41 17         44 foreach my $index (0..((length $string)-2)) {
42 98 100       230 if ($DOUBLECHARS{substr $string,$index,2}) {
43 14         31 substr ($string,$index,2) = $DOUBLECHARS{substr $string,$index,2};
44             }
45             }
46            
47             # Single character substitutions via tr
48 4     4   2802 $string =~tr/ZKGQIJFWPT§/CCCCYYVBDUA/;
  4         9  
  4         52  
  17         51  
49            
50             #delete forbidden characters
51 17         35 $string =~tr/ABCDLMNORSUVWXY//cd;
52            
53             #remove double chars
54 17         32 $string =~tr/ABCDLMNORSUVWXY//s;
55            
56 17         53 return $string;
57             }
58              
59             =encoding utf8
60              
61             =pod
62              
63             =head1 NAME
64              
65             Text::Phonetic::Phonem - Phonem algorithm
66              
67             =head1 DESCRIPTION
68              
69             The PHONEM algorithm is a simple substitution algorithm that was originally
70             implemented in dBase.
71              
72             Implementation of the PHONEM substitutions, as described in Georg Wilde and
73             Carsten Meyer, "Doppelgaenger gesucht - Ein Programm fuer kontextsensitive
74             phonetische Textumwandlung" from ct Magazin fuer Computer & Technik 25/1999.
75              
76             The original variant was implemented as X86-Assembler-Funktion. This
77             implementation does not try to mimic the original code, though it should
78             achieve equal results. As the original software used for building the original
79             implementation was not available, there was no testing for correctness, other
80             than the examples given in the article.
81              
82             The Perl implementation was written by Martin Wilz
83             (L)
84              
85             =head1 AUTHOR
86              
87             Martin Wilz
88             http://wilz.de/view/Themen/MagisterArbeit
89              
90             Maroš Kollár
91             CPAN ID: MAROS
92             maros [at] k-1.com
93             http://www.k-1.com
94              
95             =head1 COPYRIGHT
96              
97             This program is free software; you can redistribute
98             it and/or modify it under the same terms as Perl itself.
99              
100             The full text of the license can be found in the
101             LICENSE file included with this module.
102              
103             =head1 SEE ALSO
104              
105              
106             =cut
107              
108             1;