File Coverage

blib/lib/MojoX/ValidateHeadLinks.pm
Criterion Covered Total %
statement 21 89 23.6
branch 0 20 0.0
condition 0 13 0.0
subroutine 7 15 46.6
pod 4 4 100.0
total 32 141 22.7


line stmt bran cond sub pod time code
1             package MojoX::ValidateHeadLinks;
2              
3 1     1   16129 use feature 'say';
  1         1  
  1         89  
4 1     1   4 use strict;
  1         1  
  1         25  
5 1     1   4 use warnings;
  1         3  
  1         25  
6              
7 1     1   590 use Hash::FieldHash ':all';
  1         1333  
  1         130  
8              
9 1     1   801 use Log::Handler;
  1         38429  
  1         8  
10              
11 1     1   720 use Mojo::UserAgent;
  1         230297  
  1         11  
12              
13 1     1   37 use Try::Tiny;
  1         1  
  1         1232  
14              
15             fieldhash my %doc_root => 'doc_root';
16             fieldhash my %logger => 'logger';
17             fieldhash my %maxlevel => 'maxlevel';
18             fieldhash my %minlevel => 'minlevel';
19             fieldhash my %url => 'url';
20              
21             our $VERSION = '1.04';
22              
23             # -----------------------------------------------
24              
25             sub _count
26             {
27 0     0     my($self, $want, $type, $target) = @_;
28              
29 0           $$want{$type}{count}++;
30              
31 0           my($file_name) = $self -> doc_root . $target;
32              
33 0           $self -> log(debug => sprintf('%7s: %s', "\u$type", $file_name) );
34              
35 0 0         if (! -e $file_name)
36             {
37 0           $$want{$type}{error}++;
38              
39 0           $self -> log(error => "Error: $file_name does not exist");
40             }
41              
42             } # End of _count.
43              
44             # --------------------------------------------------
45              
46             sub _init
47             {
48 0     0     my($self, $arg) = @_;
49 0   0       $$arg{doc_root} ||= ''; # Caller can set.
50 0           $$arg{logger} = Log::Handler -> new;
51 0   0       $$arg{maxlevel} ||= 'notice'; # Caller can set.
52 0   0       $$arg{minlevel} ||= 'error'; # Caller can set.
53 0   0       $$arg{url} ||= ''; # Caller can set.
54 0 0         $$arg{url} = "http://$$arg{url}" if ($$arg{url} !~ /^http/);
55 0           $self = from_hash($self, $arg);
56              
57 0           $self -> logger -> add
58             (
59             screen =>
60             {
61             maxlevel => $self -> maxlevel,
62             message_layout => '%m',
63             minlevel => $self -> minlevel,
64             newline => 1, # When running from the command line.
65             }
66             );
67              
68 0           return $self;
69              
70             } # End of _init.
71              
72             # -----------------------------------------------
73              
74             sub log
75             {
76 0     0 1   my($self, $level, $s) = @_;
77              
78 0   0       $self -> logger -> $level($s || '');
79              
80             } # End of log.
81              
82             # --------------------------------------------------
83              
84             sub new
85             {
86 0     0 1   my($class, %arg) = @_;
87 0           my($self) = bless {}, $class;
88 0           $self = $self -> _init(\%arg);
89              
90 0           return $self;
91              
92             } # End of new.
93              
94             # -----------------------------------------------
95              
96             sub quit
97             {
98 0     0 1   my($self, $s) = @_;
99              
100 0           $self -> log(error => $s);
101              
102 0           die "\n";
103              
104             } # End of quit.
105              
106             # -----------------------------------------------
107              
108             sub run
109             {
110 0     0 1   my($self) = @_;
111              
112 0           $self -> log(debug => 'URL: ' . $self -> url);
113 0 0         $self -> quit('You must provide a value for the doc_root parameter') if (! $self -> doc_root);
114 0 0         $self -> quit('You must provide a value for the url parameter') if (! $self -> url);
115              
116 0           my(%want) =
117             (
118             import =>
119             {
120             count => 0,
121             error => 0,
122             },
123             link =>
124             {
125             count => 0,
126             error => 0,
127             },
128             script =>
129             {
130             count => 0,
131             error => 0,
132             },
133             );
134 0           my($ua) = Mojo::UserAgent -> new;
135 0           my($dom) = $ua -> get($self -> url) -> res -> dom;
136              
137 0           my(@field);
138             my(@import);
139              
140 0           for my $item (@{$dom -> find('html head style')})
  0            
141             {
142 0 0         next if (! $item -> can('text') );
143              
144 0           @field = grep{length} map{s/^\s+//m; s/\s+$//m; $_} split(/;/, $item -> text);
  0            
  0            
  0            
  0            
145              
146 0 0         next if ($field[0] !~ /^\@import/);
147              
148 0           for my $field (@field)
149             {
150 0           @import = split(/\s+/, $field);
151 0           $import[1] =~ s/([\"\'])(.+)\1/$2/; # The backslashed are to help UltraEdit's syntax hiliter.
152              
153 0           $self -> _count(\%want, 'import', $import[1]);
154             }
155             }
156              
157 0           for my $item (@{$dom -> find('html head link')})
  0            
158             {
159 0           my($index);
160              
161 0           for my $i (0 .. $#{$$item{tree} })
  0            
162             {
163 0 0 0       if ( (ref $$item{tree}[$i] eq 'HASH') && exists $$item{tree}[$i]{href})
164             {
165 0           $index = $i;
166              
167 0           last;
168             }
169             }
170              
171 0 0         $self -> _count(\%want, 'link', $$item{tree}[$index]{href}) if ($index);
172             }
173              
174             # WTF: Tried $head -> can('script') and UNIVERSAL::can($head, 'script').
175              
176 0           my($can);
177              
178             try
179             {
180 0     0     my(@script) = $dom -> find('html head script');
181 0           $can = 1;
182             }
183             catch
184             {
185 0     0     $can = 0;
186 0           };
187              
188 0 0         if ($can)
189             {
190 0           for my $item (@{$dom -> find('html head script')})
  0            
191             {
192 0 0         $self -> _count(\%want, 'script', $$item{src}) if ($$item{src});
193             }
194             }
195              
196 0           for my $type (sort keys %want)
197             {
198 0           $self -> log(info => sprintf('%7s: %d. Errors: %d', "\u${type}s", $want{$type}{count}, $want{$type}{error}) );
199             }
200              
201             # Return:
202             # 0 => success.
203             # 1+ => error.
204              
205 0           return $want{link}{error} + $want{import}{error} + $want{script}{error};
206              
207             } # End of run.
208              
209             # -----------------------------------------------
210              
211             1;
212              
213             =head1 NAME
214              
215             MojoX::ValidateHeadLinks - Ensure CSS and JS links in web pages point to real files
216              
217             =head1 Synopsis
218              
219             shell> validate.head.links.pl -h
220             shell> validate.head.links.pl -d /run/shm/html -u http://127.0.0.1/index.html
221              
222             This program calls the L method, which returns the number of errors found. Various logging
223             options, discussed under L and in the L, control the amount
224             of output. Nothing is printed by default.
225              
226             On my machine, /run/shm/ is the directory used to access the Debian built-in RAM disk, and
227             /run/shm/html/ is my web server document root directory.
228              
229             Since this script -validate.head.links.pl - ships in the bin/ directory, it is installed somewhere
230             along your executable search path when the module is installed.
231              
232             =head1 Description
233              
234             C is a pure Perl module.
235              
236             It does no more than this:
237              
238             =over 4
239              
240             =item o Downloads and parses a web page using L
241              
242             Hence the -url parameter to validate.head.links.pl.
243              
244             =item o Checks whether the CSS and JS links point to real files
245              
246             Hence the -directory parameter to validate.head.links.pl.
247              
248             =back
249              
250             It handles the '@import' option used in some CSS links.
251              
252             =head1 Distributions
253              
254             This module is available as a Unix-style distro (*.tgz).
255              
256             See L for details.
257              
258             See L for
259             help on unpacking and installing.
260              
261             =head1 Constructor and initialization
262              
263             new(...) returns an object of type C.
264              
265             This is the class contructor.
266              
267             Usage: C<< MojoX::ValidateHeadLinks -> new() >>.
268              
269             This method takes a hashref of options.
270              
271             Call C as C<< new({option_1 => value_1, option_2 => value_2, ...}) >>.
272              
273             Available options (which are also methods):
274              
275             =over 4
276              
277             =item o doc_root => $dir_name
278              
279             Use this to specify the doc root directory of your web server. This option is mandatory.
280              
281             Default: ''.
282              
283             =item o maxlevel => $logOption1
284              
285             This option affects L.
286              
287             See the L docs, and the L.
288              
289             Default: 'notice'. This means nothing is printed.
290              
291             For maximum details in the printed report, try:
292              
293             MojoX::ValidateHeadLinks -> new(doc_root => $d, maxlevel => 'debug', url => $u) -> run;
294              
295             =item o minlevel => $logOption2
296              
297             This option affects L.
298              
299             See the L docs.
300              
301             Default: 'error'.
302              
303             No lower levels are used.
304              
305             =item o url => $url
306              
307             Use this to specify the URL of the web page to be checked.
308              
309             Default: ''.
310              
311             If the string supplied does not start with 'http', then 'http://' is prefixed to $url automatically.
312              
313             =back
314              
315             =head1 Methods
316              
317             =head2 doc_root([$dir_name])
318              
319             Here, the [] indicate an optional parameter.
320              
321             Get or set the name of your web server doc root directory.
322              
323             =head2 log($level => $message)
324              
325             Log the string $message at log level $level.
326              
327             The logger object is of class L.
328              
329             =head2 maxlevel([$string])
330              
331             Here, the [] indicate an optional parameter.
332              
333             Get or set the value used by the logger object.
334              
335             For more details in the printed report, try:
336              
337             MojoX::ValidateHeadLinks -> new(doc_root => $d, maxlevel => 'debug', url => $u) -> run;
338              
339             'maxlevel' is a parameter to L. See L, and the L,
340             for details.
341              
342             =head2 minlevel([$string])
343              
344             Here, the [] indicate an optional parameter.
345              
346             Get or set the value used by the logger object.
347              
348             'minlevel' is a parameter to L. See L for details.
349              
350             =head2 new()
351              
352             See L for details on the parameters accepted by L.
353              
354             =head2 quit($message)
355              
356             Logs $message at log level I, and then dies.
357              
358             Errors can arise in these situations:
359              
360             =over 4
361              
362             =item o doc_root has no value during the call to L
363              
364             =item o url has no value during the call to L
365              
366             =back
367              
368             =head2 run()
369              
370             Does all the work.
371              
372             Returns the number of errors detected, so 0 is good and N > 0 is bad.
373              
374             =head2 url([$url])
375              
376             Here, the [] indicate an optional parameter.
377              
378             Get or set the URL of the web page your wish to check.
379              
380             =head1 FAQ
381              
382             =head2 How does bin/validate.head.links.pl differ from linkcheck.pl?
383              
384             L does not check that
385             links to non-HTML resources (CSS, JS) point to real files.
386              
387             =head2 How does the -maxlevel parameter affect the output?
388              
389             In these examples, $DR stands for the /run/shm/html/ directory, the doc root of my web server.
390              
391             Output from a real run, where my dev web site is the same as my real web site (so -d $DR works):
392              
393             shell> validate.head.links.pl -d $DR -url http://savage.net.au/Novels-etc.html -max debug
394              
395             URL: http://savage.net.au/Novels-etc.html
396             Import: /run/shm/html/assets/js/DataTables-1.9.4/media/css/demo_page.css
397             Import: /run/shm/html/assets/js/DataTables-1.9.4/media/css/demo_table.css
398             Link: /run/shm/html/assets/css/local/default.css
399             Script: /run/shm/html/assets/js/DataTables-1.9.4/media/js/jquery.js
400             Script: /run/shm/html/assets/js/DataTables-1.9.4/media/js/jquery.dataTables.min.js
401             Imports: 2. Errors: 0
402             Links: 1. Errors: 0
403             Scripts: 2. Errors: 0
404              
405             shell> validate.head.links.pl -d $DR -url http://savage.net.au/Novels-etc.html -max info
406              
407             Imports: 2. Errors: 0
408             Links: 1. Errors: 0
409             Scripts: 2. Errors: 0
410              
411             shell> validate.head.links.pl -d $DR -url http://savage.net.au/Novels-etc.html -max error
412              
413             (No output)
414              
415             shell> echo $?
416             0
417              
418             =head1 Support
419              
420             Email the author, or log a bug on RT:
421              
422             L.
423              
424             =head1 Author
425              
426             C was written by Ron Savage Iron@savage.net.auE> in 2012.
427              
428             Home page: L.
429              
430             =head1 Copyright
431              
432             Australian copyright (c) 2012, Ron Savage.
433              
434             All Programs of mine are 'OSI Certified Open Source Software';
435             you can redistribute them and/or modify them under the terms of
436             The Artistic License, a copy of which is available at:
437             http://www.opensource.org/licenses/index.html
438              
439             =cut