File Coverage

blib/lib/LyricFinder/_Class.pm
Criterion Covered Total %
statement 21 150 14.0
branch 0 34 0.0
condition 0 15 0.0
subroutine 7 25 28.0
pod 0 12 0.0
total 28 236 11.8


line stmt bran cond sub pod time code
1             package LyricFinder::_Class;
2              
3 1     1   477 use strict;
  1         2  
  1         30  
4 1     1   5 use warnings;
  1         2  
  1         36  
5 1     1   727 use LWP::UserAgent;
  1         52499  
  1         63  
6 1     1   15 use HTTP::Request;
  1         3  
  1         33  
7 1     1   864 use HTML::Strip;
  1         8715  
  1         87  
8 1     1   16 use Carp;
  1         2  
  1         1709  
9              
10             our $AGENT = "Mozilla/5.0 (X11; Linux x86_64; rv:91.0) Gecko/20100101 Firefox/91.0";
11             our $DEBUG = 0; # If you want debug messages, set debug to a true value, and
12             # messages will be output with warn.
13              
14             sub new
15             {
16 0     0 0   my $class = shift;
17 0           my $source = shift;
18              
19 0           my $self = {};
20              
21 0           $self->{'-debug'} = $DEBUG;
22 0           $self->{'-agent'} = $AGENT;
23 0           $self->{'-cache'} = '';
24 0           $self->{'Error'} = 'Ok';
25 0           $self->{'Source'} = $source;
26 0           $self->{'Site'} = '';
27 0           $self->{'Order'} = '';
28 0           $self->{'Tried'} = '';
29 0           $self->{'Url'} = '';
30 0           $self->{'image_url'} = '';
31 0           $self->{'Credits'} = [];
32              
33             #EXTRACT ANY ARGUMENTS:
34 0           while (@_) {
35 0 0         if ($_[0] =~ /^\-/o) {
36 0           my $key = shift;
37 0 0 0       $self->{$key} = (!defined($_[0]) || $_[0] =~/^\-/) ? 1 : shift;
38 0           next;
39             }
40 0           shift;
41             }
42              
43             #NOW EXTRACT ANY SUBMODULE-SPECIFIC HASH ARGUMENTS (ie. "-Submodule => {args}"):
44 0 0 0       if (defined($self->{"-$source"}) && ref($self->{"-$source"}) =~ /HASH/) {
45 0           my @subarglist = %{$self->{"-$source"}};
  0            
46 0           while (@subarglist) {
47 0 0         if ($subarglist[0] =~ /^\-/o) {
48 0           my $key = shift @subarglist;
49 0 0 0       $self->{$key} = (!defined($subarglist[0]) || $subarglist[0] =~/^\-/) ? 1 : shift(@subarglist);
50 0           next;
51             }
52 0           shift @subarglist;
53             }
54             }
55              
56 0 0 0       $self->{'-debug'} = $DEBUG unless (defined($self->{'-debug'}) && $self->{'-debug'} =~ /^\d$/);
57 0           bless $self, $class; #BLESS IT!
58              
59 0           return $self;
60             }
61              
62             sub _debug {
63 0     0     my $self = shift;
64 0           my $msg = shift;
65            
66 0 0         warn $msg if $self->{'-debug'};
67             }
68              
69             sub sources {
70 0     0 0   my $self = shift;
71 0 0         return wantarray ? @{$self->{'_fetchers'}} : \@{$self->{'_fetchers'}};
  0            
  0            
72             }
73              
74             sub source {
75 0     0 0   my $self = shift;
76 0           return $self->{'Source'};
77             }
78              
79             sub url {
80 0     0 0   my $self = shift;
81 0           return $self->{'Url'};
82             }
83              
84             sub order {
85 0     0 0   my $self = shift;
86 0 0         return wantarray ? ($self->{'Source'}) : $self->{'Source'};
87             }
88              
89             sub tried {
90 0     0 0   return order (@_);
91             }
92              
93             sub credits {
94 0     0 0   my $self = shift;
95 0 0         return wantarray ? @{$self->{'Credits'}} : join(', ', @{$self->{'Credits'}});
  0            
  0            
96             }
97              
98             sub message {
99 0     0 0   my $self = shift;
100 0           return $self->{'Error'};
101             }
102              
103             sub site {
104 0     0 0   my $self = shift;
105 0           return $self->{'Site'};
106             }
107              
108             # Allow user to specify a different user-agent:
109             sub agent {
110 0     0 0   my $self = shift;
111 0 0         if (defined $_[0]) {
112 0           $self->{'-agent'} = $_[0];
113             } else {
114 0           return $self->{'-agent'};
115             }
116             }
117              
118             sub cache {
119 0     0 0   my $self = shift;
120 0 0         if (defined $_[0]) {
121 0           $self->{'-cache'} = $_[0];
122             } else {
123 0           return $self->{'-cache'};
124             }
125             }
126              
127             sub image_url {
128 0     0 0   return shift->{'image_url'};
129             }
130              
131             sub _check_inputs {
132 0     0     my $self = shift;
133              
134 0           my $Source = $self->{'Source'};
135             # reset the error var, change it if an error occurs.
136 0           $self->{'Error'} = 'Ok';
137 0           $self->{'Url'} = '';
138              
139 0 0 0       unless ($_[0] && $_[1]) {
140 0           carp($self->{'Error'} = "e:$Source.fetch() called without artist and song!");
141 0           return 0;
142             }
143 0           return 1;
144             }
145              
146             sub _web_fetch {
147 0     0     my $self = shift;
148              
149 0           $self->_debug($self->{'Source'}.":_web_fetch($_[0], $_[1]): URL=".$self->{'Url'}."=");
150 0           my $ua = LWP::UserAgent->new(
151             ssl_opts => { verify_hostname => 0, },
152             );
153 0           $ua->timeout(10);
154 0           $ua->agent($self->{'-agent'});
155 0           $ua->protocols_allowed(['https']);
156 0           $ua->cookie_jar( {} );
157 0           push @{ $ua->requests_redirectable }, 'GET';
  0            
158 0           (my $referer = $self->{'Url'}) =~ s{^(\w+)\:\/\/}{};
159 0           my $protocol = $1;
160 0           $referer =~ s{\/.+$}{\/};
161 0           my $host = $referer;
162 0           $host =~ s{\/$}{};
163 0           $referer = $protocol . '://' . $referer;
164 0           my $req = new HTTP::Request 'GET' => $self->{'Url'};
165 0           $req->header(
166             'Accept' =>
167             'text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8',
168             'Accept-Language' => 'en-US,en;q=0.5',
169             'Accept-Encoding' => 'gzip, deflate',
170             'Connection' => 'keep-alive',
171             'Upgrade-insecure-requests' => 1,
172             'Host' => $host,
173             );
174              
175 0           my $res = $ua->request($req);
176              
177 0 0         if ($res->is_success) {
178 0           my $lyrics = $self->_parse($res->decoded_content);
179 0           return $lyrics;
180             } else {
181 0           my $Source = $self->{'Source'};
182 0 0         if ($res->status_line =~ /^404/) {
183 0           $self->{'Error'} = "..$Source - Lyrics not found.";
184             } else {
185 0           carp($self->{'Error'} = "e:$Source - Failed to retrieve ".$self->{'Url'}
186             .' ('.$res->status_line.').');
187             }
188 0           return '';
189             }
190             }
191              
192             sub _remove_accents {
193 0     0     my $self = shift;
194 0           my $str = shift;
195              
196 0           $str =~ tr/\xc4\xc2\xc0\xc1\xc3\xe4\xe2\xe0\xe1\xe3/aaaaaaaaaa/;
197 0           $str =~ tr/\xcb\xca\xc8\xc9\xeb\xea\xe8\xe9/eeeeeeee/;
198 0           $str =~ tr/\xcf\xcc\xef\xec/iiii/;
199 0           $str =~ tr/\xd6\xd4\xd2\xd3\xd5\xf6\xf4\xf2\xf3\xf5/oooooooooo/;
200 0           $str =~ tr/\xdc\x{0016}\xd9\xda\xfc\x{0016}\xf9\xfa/uuuuuuuu/;
201 1     1   953 $str =~ tr/\x{0178}\xdd\xff\xfd/yyyy/;
  1         19  
  1         20  
  0            
202 0           $str =~ tr/\xd1\xf1/nn/;
203 0           $str =~ tr/\xc7\xe7/cc/;
204 0           $str =~ s/\xdf/ss/g;
205              
206 0           return $str;
207             }
208              
209             # nasty way to strip out HTML
210             sub _html2text {
211 0     0     my $self = shift;
212 0           my $str = shift;
213              
214 0           $str =~ s#\<(?:br|\/?p).*?\>#\n#gio;
215 0           $str =~ s#\>\;#\>#go;
216 0           $str =~ s#\<\;#\<#go;
217 0           $str =~ s#\&\;#\&#go;
218 0           $str =~ s#\"\;#\"#go;
219 0           $str =~ s#\<.*?\>##go;
220              
221 0           return $str;
222             }
223              
224             sub _normalize_lyric_text {
225 0     0     my $self = shift;
226 0           my $str = shift;
227              
228             # normalize Windowsey \r\n sequences:
229 0           $str =~ s/\r+//gs;
230             # strip off pre & post padding with spaces:
231 0           $str =~ s/^ +//mg;
232 0           $str =~ s/ +$//mg;
233             # clear up repeated blank lines:
234 0           $str =~ s/(\R){2,}/\n\n/gs;
235             # and remove any blank top and bottom lines:
236 0           $str =~ s/^\R+//s;
237 0           $str =~ s/\R\R+$/\n/s;
238             # add a linefeed to end of lyrics if ther's not one already:
239 0 0         $str .= "\n" unless ($str =~ /\n$/s);
240             # now fix up for either Windows or Linux/Unix:
241 0 0         $str =~ s/\R/\r\n/gs if ($^O =~ /Win/);
242              
243 0           return $str;
244             }
245              
246             1
247              
248             __END__