File Coverage

blib/lib/Text/Morse.pm
Criterion Covered Total %
statement 29 39 74.3
branch 6 16 37.5
condition 4 12 33.3
subroutine 6 8 75.0
pod 0 3 0.0
total 45 78 57.6


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