File Coverage

blib/lib/Text/Morse.pm
Criterion Covered Total %
statement 27 37 72.9
branch 4 12 33.3
condition 2 6 33.3
subroutine 6 8 75.0
pod 0 3 0.0
total 39 66 59.0


line stmt bran cond sub pod time code
1             package Text::Morse;
2              
3 2     2   37024 use warnings;
  2         4  
  2         65  
4 2     2   9 use strict;
  2         5  
  2         88  
5              
6             $Text::Morse::VERSION = '0.04';
7              
8 2     2   10 no warnings 'qw';
  2         4  
  2         1349  
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             sub new {
84 2     2 0 844 my $class = shift @_;
85 2         5 my $lang = shift @_;
86              
87 2         5 my $hash = \%ENGLISH;
88 2 50 33     10 $hash = \%SWEDISH if defined $lang and $lang =~ /^(SWEDISH|SVENSKA)$/i;
89 2 50 33     14 $hash = \%LATIN if defined $lang and $lang =~ /^LATIN$/i;
90            
91 2         122 my $rev = {reverse %$hash};
92 2         15 my $self = {'enc' => $hash, 'dec' => $rev, 'lang' => $lang};
93 2         10 bless $self, $class;
94             }
95              
96             sub Encode {
97 0     0 0 0 my ($self, $text) = @_;
98 0         0 my $enc = $self->{'enc'};
99 0         0 my @words = split(/\s+/, $text);
100 0 0   0   0 my $sub = sub { $_ = $enc->{shift()}; $_ ? "$_ " : ""; };
  0         0  
  0         0  
101 0         0 foreach (@words) {
102 0         0 s/(\S)/&$sub(uc($1))/ge;
  0         0  
103             }
104 0 0       0 wantarray ? @words : join("\n", @words);
105             }
106              
107             sub Decode {
108 1     1 0 6 my ($self, @codes) = @_;
109 1         2 my @words = @codes;
110 1         5 my $dec = $self->{'dec'};
111 1 50   3   5 my $sub = sub { $_ = $dec->{shift()}; defined($_) ? $_ : ""; };
  3         6  
  3         13  
112 1         2 foreach (@words) {
113 1         7 s/([\.-]+)\s*/&$sub($1)/ge;
  3         8  
114             }
115 1 50       9 wantarray ? @words : join(" ", @words);
116             }
117              
118             1;
119             __END__