File Coverage

blib/lib/URL/Check.pm
Criterion Covered Total %
statement 90 98 91.8
branch 29 36 80.5
condition 5 8 62.5
subroutine 14 14 100.0
pod 4 9 44.4
total 142 165 86.0


line stmt bran cond sub pod time code
1             package URL::Check;
2              
3             $URL::Check::VERSION = '0.10';
4             $URL::Check::AUTHORITY = 'cpan:ALEXMASS';
5              
6             =head1 NAME
7              
8             URL::Check - Check a list of URL and respond accordingly.
9              
10             =head1 VERSION
11              
12             Version 0.10
13              
14             =cut
15              
16 4     4   93945 use 5.006;
  4         16  
17 4     4   23 use strict; use warnings;
  4     4   9  
  4         94  
  4         21  
  4         12  
  4         141  
18              
19 4     4   3059 use LWP::Simple qw/get/;
  4         565025  
  4         38  
20 4     4   5137 use Time::HiRes qw /gettimeofday/;
  4         7151  
  4         21  
21              
22             =head1 DESCRIPTION
23              
24             This module is not aimed at being used directly but via the script C.
25              
26             url-check --config=my-config.txt
27              
28             If no C<--config argument> is set, the value is taken from environment variable C.
29              
30             More examples can be found in the C directory but consist
31             in default parameter (mailto etc., then each url to be tested can be followed
32             by dedicated test (time.delay, xpath etc.)
33              
34             More info can be found L
35              
36             =head1 METHODS
37              
38             =head2 readConfig($file_name)
39              
40             Read the config file. Default file name is taken from C<$URL_CHECK_FILE>
41              
42             =cut
43              
44             our %config;
45             our @report;
46              
47             sub readConfig {
48             my $configFile = shift || $ENV{URL_CHECK_CONFIG}
49 6   50 6 1 5736 || die "ERROR: No config file is passed or env URL_CHECK_CONFIG is set.\n";
50              
51 5         11 my $FD;
52 5 100       229 open ($FD, "<$configFile")
53             || die "ERROR: Cannot open config file [$configFile]: $!\n";
54              
55 4         20 p_clearConfig();
56              
57             # $currenturl will contain at first the default map for handling error,
58             # then, when a url is encountered, it will contain the url's error handlers
59 4         7 my $currentUrl;
60 4         81 while (my $line = <$FD>) {
61 39         79 $line=~s/^#.*//; # remove comments
62 39         184 $line=~s/\s*$//; # end of line spaces
63 39 100       148 next unless $line =~/\S/; # skip emplty lines
64              
65 23 100       64 if ($line=~/^onerror/i) {
66 4   33     37 p_addOnErrorLine($line, $currentUrl || $config{default});
67 4         17 next;
68             }
69              
70 19 100       53 if ($line=~/^check/i) {
71 5         9 p_addCheckLine($line, $currentUrl);
72 5         20 next;
73             }
74              
75 14 50       60 if ($line=~/^(ftp|http|file):\/\//i) {
76 14         34 $currentUrl = p_addUrl($line);
77 14         60 next;
78             }
79              
80 0         0 die "ERROR: Cannot parse line: $line\n";
81             }
82              
83 4         62 close($FD);
84             }
85              
86             =head2 run()
87              
88             Run the configured tests, and store the result into the local @report
89              
90             =cut
91              
92             sub run {
93              
94 3     3 1 1127 undef @report;
95 3         5 foreach my $urlConfig (@{$config{urls}}) {
  3         11  
96 10         46 push @report, p_runOneUrl($urlConfig);
97             }
98             }
99              
100             =head2 submitReport(%report)
101              
102             Print on console or send by mail the error output
103              
104             =cut
105              
106             sub submitReport {
107 2     2 1 4949 my %report = @_;
108              
109 2 50       17 if ($config{default}{onError}{console}) {
110 2         81 print "ERROR REPORT: $report{subject}\n$report{contents}\n";
111             }
112              
113 2 50       23 if ($config{default}{onError}{mailto}) {
114 0         0 require Mail::Sendmail;
115 0         0 my $hostname = `hostname`;
116 0         0 chomp $hostname;
117             my %mail = (
118 0         0 To => join(',', @{$config{default}{onError}{mailto}}),
  0         0  
119             Subject => "[url-check] $report{subject}",
120             From => "url.check\@$hostname",
121             Message => "$report{contents}\n",
122             );
123              
124 0         0 warn "sending error report by mail: $report{subject}\n";
125 0 0       0 Mail::Sendmail::sendmail(%mail) or die $Mail::Sendmail::error
126             }
127             }
128              
129             =head2 errorReport()
130              
131             Build a map (subject => ..., content=> ...) with the errors after the run
132             return () if no error were detected
133              
134             =cut
135              
136             sub errorReport {
137 3     3 1 96 my @errors = grep {! $_->{success}} @report;
  10         38  
138              
139 3 100       22 unless (@errors) {
140 1         7 return ();
141             }
142              
143             (
144             subject => ''.scalar(@errors).' errors reported',
145 2         10 contents => join("\n", (map {$_->{url}." : ".$_->{message}} @errors))
  4         33  
146             );
147             }
148              
149             #
150             #
151             # PRIVATE METHODS
152              
153             sub p_addOnErrorLine {
154 11     11 0 3695 my ($line, $conf) = @_;
155              
156 11 50       72 die "ERROR: Cannot parse error line: $line"
157             unless $line=~/^onerror\.(.+?)=(.+)/i;
158              
159 11         42 my ($errorCat, $params) = ($1, $2);
160              
161 11 100       31 if ($errorCat eq 'mailto') {
162 2         9 my @tmp = split(/,/, $params);
163 2         7 $conf->{onError}{mailto}=\@tmp;
164 2         5 return;
165             }
166              
167 9 100       32 if ($errorCat eq 'console') {
168 8         50 $conf->{onError}{console}= $params =~ /\s*(y(es)?|t(rue)?|1)\s*$/i;
169 8         20 return;
170             }
171              
172 1         7 die "ERROR: Unknown onerror type [$errorCat]\n";
173             }
174              
175             sub p_addCheckLine {
176 5     5 0 8 my ($line, $conf) = @_;
177              
178 5 50       21 die "ERROR: Cannot parse error line: $line\n"
179             unless $line=~/^check\.(.+?)=(.+)/i;
180              
181 5         12 my ($cat, $params) = ($1, $2);
182              
183 5 100       16 if ($cat eq 'contains') {
184 3         4 push @{ $conf->{check}{contains}}, $params ;
  3         8  
185 3         23 return;
186             }
187              
188 2         5 $conf->{check}{$cat} = $params
189             }
190              
191             sub p_addUrl {
192 14     14 0 21 my ($line) = @_;
193              
194 14         49 my $h = {
195             url => $line,
196             check => {}
197             };
198              
199 14         19 push @{$config{urls}}, $h;
  14         33  
200 14         26 return $h;
201             }
202              
203             sub p_clearConfig {
204              
205 4     4 0 33 %config = (
206             default => { onError=>{} },
207             urls => [],
208             );
209             }
210              
211             sub p_runOneUrl {
212 10     10 0 22 my %urlConfig = %{$_[0]};
  10         67  
213              
214 10         30 my $url = $urlConfig{url};
215 10         50 my ($sec0, $micros0) = gettimeofday;
216 10         67 my $content = get($url);
217              
218 10 100       2539378 unless ($content) {
219             return {
220 2         27 url => $url,
221             success => 0,
222             message => 'cannot load content'
223             }
224             }
225              
226 8         62 my ($sec1, $micros1) = gettimeofday;
227 8         55 my $dtime = int(($sec1-$sec0)*1000 + ($micros1-$micros0)/1000);
228              
229 8 100 100     69 if ((exists $urlConfig{check}{overtime}) && ($urlConfig{check}{overtime} < $dtime)) {
230             return {
231 1         18 url => $url,
232             success => 0,
233             message => "overtime > $urlConfig{check}{overtime} (${dtime}ms)",
234             }
235             }
236              
237 7 100       34 if (exists $urlConfig{check}{contains}) {
238 2         6 my @searchFor = @{$urlConfig{check}{contains}};
  2         11  
239 2         9 foreach (@searchFor) {
240 2 100       32 if (index($content, $_) < 0) {
241             return {
242 1         18 url => $url,
243             success => 0,
244             message => "does not contains \"$_\"",
245             }
246             }
247             }
248             }
249              
250             return {
251 6         65 url => $url,
252             success => 1
253             };
254             }
255              
256             =head1 AUTHOR
257              
258             Alexandre Masselot, C<< >>
259              
260             Currently maintained by Mohammad S Anwar (MANWAR) C<< >>
261              
262             =head1 REPOSITORY
263              
264             L
265              
266             =head1 BUGS
267              
268             Please report any bugs or feature requests to C,
269             or through the web interface at L.
270             I will be notified, and then you'll automatically be notified of progress on
271             your bug as I make changes.
272              
273             =head1 SUPPORT
274              
275             You can find documentation for this module with the perldoc command.
276              
277             perldoc URL::Check
278              
279             You can also look for information at:
280              
281             =over 4
282              
283             =item * RT: CPAN's request tracker (report bugs here)
284              
285             L
286              
287             =item * AnnoCPAN: Annotated CPAN documentation
288              
289             L
290              
291             =item * CPAN Ratings
292              
293             L
294              
295             =item * Search CPAN
296              
297             L
298              
299             =back
300              
301             =head1 LICENSE AND COPYRIGHT
302              
303             Copyright (C) 2011 - 2015 Alexandre Masselot.
304              
305             This program is free software; you can redistribute it and/or modify it under the
306             terms of either: the GNU General Public License as published by the Free Software
307             Foundation; or the Artistic License.
308              
309             See http://dev.perl.org/licenses/ for more information.
310              
311             =cut
312              
313             1; # End of URL::Check