File Coverage

blib/lib/Text/Morse.pm
Criterion Covered Total %
statement 35 45 77.7
branch 6 16 37.5
condition 4 12 33.3
subroutine 8 10 80.0
pod 0 3 0.0
total 53 86 61.6


line stmt bran cond sub pod time code
1             package Text::Morse;
2              
3 2     2   31685 use utf8;
  2         21  
  2         12  
4 2     2   77 use warnings;
  2         3  
  2         76  
5 2     2   11 use strict;
  2         3  
  2         121  
6              
7             $Text::Morse::VERSION = '0.07';
8              
9 2     2   9 no warnings 'qw';
  2         3  
  2         802  
10              
11             our %ENGLISH = qw(
12             A .-
13             B -...
14             C -.-.
15             D -..
16             E .
17             F ..-.
18             G --.
19             H ....
20             I ..
21             J .---
22             K -.-
23             L .-..
24             M --
25             N -.
26             O ---
27             P .--.
28             Q --.-
29             R .-.
30             S ...
31             T -
32             U ..-
33             V ...-
34             W .--
35             X -..-
36             Y -.--
37             Z --..
38             . .-.-.-
39             , --..--
40             / -...-
41             : ---...
42             ' .----.
43             - -....-
44             ? ..--..
45             ! ..--.
46             @ ...-.-
47             + .-.-.
48             0 -----
49             1 .----
50             2 ..---
51             3 ...--
52             4 ....-
53             5 .....
54             6 -....
55             7 --...
56             8 ---..
57             9 ----.
58             );
59              
60             our %SWEDISH = (%ENGLISH, qw(
61             Å .--.-
62             Ä .-.-
63             Ö ---.
64             å .--.-
65             ä .-.-
66             ö ---.
67             ));
68              
69             our %LATIN = (%ENGLISH, qw(
70             Á .--.-
71             Ä .-.-
72             Ö ---.
73             á .--.-
74             ä .-.-
75             ö ---.
76             É ..-..
77             é ..-..
78             Ñ --.--
79             ñ --.--
80             Ü ..--
81             ü ..--
82             ));
83              
84             our %COMMON_CYR = qw(
85             А .-
86             Б -...
87             В .--
88             Г --.
89             Д -..
90             Е .
91             Ж ...-
92             З --..
93             И ..
94             Й .---
95             К -.-
96             Л .-..
97             М --
98             Н -.
99             О ---
100             П .--.
101             Р .-.
102             С ...
103             Т -
104             У ..-
105             Ф ..-.
106             Х ....
107             Ц -.-.
108             Ч ---.
109             Ш ----
110             Щ --.-
111             Ю ..--
112             Я .-.-
113             . .-.-.-
114             , --..--
115             / -...-
116             : ---...
117             ' .----.
118             - -....-
119             ? ..--..
120             ! ..--.
121             @ ...-.-
122             + .-.-.
123             0 -----
124             1 .----
125             2 ..---
126             3 ...--
127             4 ....-
128             5 .....
129             6 -....
130             7 --...
131             8 ---..
132             9 ----.
133             );
134              
135             our %BULGARIAN = (%COMMON_CYR, qw(
136             Ъ -..-
137             Ь -.--
138             ));
139              
140             our %RUSSIAN = (%COMMON_CYR, qw(
141             Ь -..-
142             Ы -.--
143             Э ..-..
144             ));
145              
146             sub new {
147 2     2 0 771 my $class = shift @_;
148 2         7 my $lang = shift @_;
149              
150 2         9 my $hash = \%ENGLISH;
151 2 50 33     14 $hash = \%SWEDISH if defined $lang and $lang =~ /^(SWEDISH|SVENSKA)$/i;
152 2 50 33     16 $hash = \%LATIN if defined $lang and $lang =~ /^LATIN$/i;
153 2 50 33 2   10 $hash = \%BULGARIAN if defined $lang and $lang =~ /^(BULGARIAN|БЪЛГАРСКИ)$/i;
  2         2  
  2         20  
  2         12  
154 2 50 33     11 $hash = \%RUSSIAN if defined $lang and $lang =~ /^(RUSSIAN|РУССКИЙ)$/i;
155            
156 2         125 my $rev = {reverse %$hash};
157 2         14 my $self = {'enc' => $hash, 'dec' => $rev, 'lang' => $lang};
158 2         14 bless $self, $class;
159             }
160              
161             sub Encode {
162 0     0 0 0 my ($self, $text) = @_;
163 0         0 my $enc = $self->{'enc'};
164 0         0 my @words = split(/\s+/, $text);
165 0 0   0   0 my $sub = sub { $_ = $enc->{shift()}; $_ ? "$_ " : ""; };
  0         0  
  0         0  
166 0         0 foreach (@words) {
167 0         0 s/(\S)/&$sub(uc($1))/ge;
  0         0  
168             }
169 0 0       0 wantarray ? @words : join("\n", @words);
170             }
171              
172             sub Decode {
173 1     1 0 9 my ($self, @codes) = @_;
174 1         3 my @words = @codes;
175 1         7 my $dec = $self->{'dec'};
176 1 50   3   7 my $sub = sub { $_ = $dec->{shift()}; defined($_) ? $_ : ""; };
  3         9  
  3         18  
177 1         4 foreach (@words) {
178 1         10 s/([\.-]+)\s*/&$sub($1)/ge;
  3         7  
179             }
180 1 50       11 wantarray ? @words : join(" ", @words);
181             }
182              
183             1;
184             __END__