File Coverage

blib/lib/W3C/LogValidator/SurveyEngine.pm
Criterion Covered Total %
statement 13 74 17.5
branch 0 36 0.0
condition 0 3 0.0
subroutine 5 9 55.5
pod n/a
total 18 122 14.7


.*?'; .*?';
line stmt bran cond sub pod time code
1             # Copyright (c) 2004-2005 the World Wide Web Consortium :
2             # Keio University,
3             # European Research Consortium for Informatics and Mathematics
4             # Massachusetts Institute of Technology.
5             # written by Matthieu Faure for W3C
6             # maintained by olivier Thereaux and Matthieu Faure
7             # $Id: SurveyEngine.pm,v 1.13 2006/04/12 02:42:46 ot Exp $
8              
9             package W3C::LogValidator::SurveyEngine;
10 1     1   476 use strict;
  1         3  
  1         37  
11 1     1   8 use warnings;
  1         3  
  1         1191  
12              
13             require Exporter;
14             our @ISA = qw(Exporter);
15             our %EXPORT_TAGS = ( 'all' => [ qw() ] );
16             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
17             our @EXPORT = qw();
18             our $VERSION = sprintf "%d.%03d",q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
19              
20              
21             ###########################
22             # usual package interface #
23             ###########################
24             our $verbose = 1;
25             our %config;
26              
27             sub new
28             {
29 0     0     my $self = {};
30 0           my $proto = shift;
31 0   0       my $class = ref($proto) || $proto;
32             # mandatory vars for the API
33 0           @{$self->{URIs}} = undef;
  0            
34             # internal stuff here
35             # $self->{FOO} = undef;
36            
37             # don't change this
38 0 0         if (@_) {%config = %{(shift)};}
  0            
  0            
39 0 0         if (exists $config{verbose}) {$verbose = $config{verbose}}
  0            
40 0 0         if (exists $config{AuthorizedExtensions})
41             {
42 0           $self->{AUTH_EXT} = $config{AuthorizedExtensions};
43             }
44             else # same as the formats supported by markup Validator
45             # TODO add support for CSS too, at least
46             {
47 0           $self->{AUTH_EXT} = ".html .xhtml .phtml .htm .shtml .php .svg .xml /";
48             }
49 0 0         $config{ValidatorHost} = "validator.w3.org" if (! exists $config{ValidatorHost});
50 0 0         $config{ValidatorPort} = "80" if (!exists $config{ValidatorPort});
51 0 0         $config{ValidatorString} = "/check\?uri=" if (!exists $config{ValidatorString});
52 0 0         $config{ValidatorVersion} = "0.7.0" if (!exists $config{ValidatorVersion});
53 0           bless($self, $class);
54 0           return $self;
55             }
56              
57              
58             sub uris
59             {
60 0     0     my $self = shift;
61 0 0         if (@_) { @{$self->{URIs}} = @_ }
  0            
  0            
62 0           return @{$self->{URIs}};
  0            
63             }
64              
65              
66             sub auth_ext
67             {
68 0     0     my $self=shift;
69 0 0         if (@_) { $self->{AUTH_EXT} = shift}
  0            
70 0           return $self->{AUTH_EXT};
71             }
72              
73             sub trim_uris
74             {
75 0     0     my $self = shift;
76 0           my @authorized_extensions = split(" ", $self->auth_ext);
77 0           my @trimmed_uris;
78 0           my $exclude_regexp = "";
79 0           my @excluded_areas;
80 0           $exclude_regexp = $config{ExcludeAreas};
81 0 0         if ($exclude_regexp){
82 0           $exclude_regexp =~ s/\//\\\//g ;
83 0           @excluded_areas = split(" ", $exclude_regexp);
84             }
85 0 0         else { print "nothing to exclude\n" if ($verbose >2);}
86 0           my $uri;
87 0           while ($uri = shift)
88             {
89 0           my $uri_ext = "";
90 0           my $match = 0;
91 0 0         if ($uri =~ /(\.[0-9a-zA-Z]+)$/)
    0          
92             {
93 0           $uri_ext = $1;
94             }
95 0           elsif ($uri =~ /\/$/) { $uri_ext = "/";}
96 0           foreach my $ext (@authorized_extensions)
97             {
98 0 0         if ($ext eq $uri_ext) { $match = 1; }
  0            
99             }
100 0 0         if ($match)
101             {
102 0           foreach my $area (@excluded_areas)
103             {
104 0 0         if ($uri =~ /$area/)
105             {
106 0           my $slasharea = $area;
107 0           $slasharea =~ s/\\\//\//g;
108 0           $slasharea =~ s/\\././g;
109 0 0         print "Ignoring $uri matching $slasharea \n" if ($verbose > 2) ;
110 0           $match = 0;
111             }
112              
113             }
114             }
115              
116 0 0         push @trimmed_uris,$uri if ($match);
117             }
118 0           return @trimmed_uris;
119             }
120              
121             #########################################
122             # Actual subroutine to check the list of uris #
123             #########################################
124              
125              
126             sub process_list
127             {
128             my $self = shift;
129             my $max_invalid = undef;
130             my $max_documents = undef;
131             if ( exists $config{MaxInvalid} ) { $max_invalid = $config{MaxInvalid}; }
132             else {$max_invalid = 0;}
133             if (exists $config{MaxDocuments}) {$max_documents = $config{MaxDocuments}; }
134             else {$max_documents = 0;}
135             # print "$max_documents max documents" if ($verbose > 2); # debug
136             my $name = "";
137             if (exists $config{ServerName}) {$name = $config{ServerName}}
138              
139              
140             print "Now Using the SurveyEngine module...\n" if $verbose;
141             my %hits;
142             my @uris;
143 1     1   379 use URI::Escape;
  1         2097  
  1         77  
144 1     1   548 use LWP::UserAgent;
  1         51451  
  1         42  
145             if (defined ($config{tmpfile}))
146             {
147 1     1   857 use DB_File;
  0            
  0            
148             my $tmp_file = $config{tmpfile};
149             tie (%hits, 'DB_File', "$tmp_file", O_RDONLY) ||
150             die ("Cannot create or open $tmp_file");
151             @uris = sort { $hits{$b} <=> $hits{$a} } keys %hits;
152             }
153             elsif ($self->uris())
154             {
155             @uris = $self->uris();
156             foreach my $uri (@uris) { $hits{$uri} = 0 }
157             }
158             @uris = sort { $hits{$b} <=> $hits{$a} } keys %hits;
159            
160             my @result_head;
161             #push @result_head, "Hits";
162             push @result_head, "Rank";
163             push @result_head, "Hits";
164             push @result_head, "URI";
165             push @result_head, "Charset";
166             push @result_head, "Doctype";
167             push @result_head, "Valid (#err)";
168            
169             my @result;
170             my $uri = undef;
171             my $ua = new LWP::UserAgent;
172             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
173             $year += 1900;
174             $mon = sprintf ( "%02d", $mon);
175             $mday = sprintf ("%02d", $mday);
176             my $localDate = "$year-$mon-$mday" ;
177             my $census = 0;
178              
179             @uris = $self->trim_uris(@uris);
180              
181             while ((@uris) and (($census < $max_documents) or (!$max_documents)) )
182             {
183             # a few initializations
184             $uri = shift (@uris);
185             my $uri_orig = $uri;
186             $uri = uri_escape($uri);
187             my @result_tmp = ();
188             $census = $census+1;
189             print " processing #$census $uri_orig..." if ($verbose > 1);
190             # filling result table with "fixed" content
191             push @result_tmp, $census;
192             push @result_tmp, $hits{$uri_orig};
193             push @result_tmp, $uri_orig;
194              
195             my $validatorUri = join ("", "http://",$config{ValidatorHost},":",$config{ValidatorPort}, $config{ValidatorString},$uri);
196             print "$validatorUri \n" if ($verbose > 2); # debug info
197            
198             my $testStringCharset = undef;
199             my $testStringDoctype = undef;
200             my $testStringInvalid = undef;
201             my $testStringValid = undef;
202             my $testStringErrorNum = undef;
203              
204             if ( $config{ValidatorVersion} eq "0.6.1" ) {
205             $testStringCharset = 'I was not able to extract a character encoding labeling from any of';
206             $testStringDoctype = '

Fatal Error: No DOCTYPE specified!

';
207             $testStringInvalid = '

This page is not Valid';

208             $testStringValid = '

This Page Is Valid';

209             $testStringErrorNum = 'Errors: (\d+)
210             } elsif ( $config{ValidatorVersion} eq "0.6.5" ) {
211             $testStringCharset = 'found are not valid values in the specified Character Encoding';
212             $testStringDoctype = '

No DOCTYPE Found!';

213             $testStringInvalid = '

This page is not Valid';

214             $testStringValid = '

This Page Is Valid';

215             $testStringErrorNum = 'Errors: (\d+)
216             } else {
217             # Default ValidatorVersion is 0.7.0 (current version as of August 2005)
218             $testStringValid = '

This Page Is Valid';

219             $testStringErrorNum = 'Failed validation, .* errors';
220             $testStringDoctype = 'No DOCTYPE found!';
221             $testStringInvalid = '

This page is';

222             $testStringCharset = 'found are not valid values in the specified Character Encoding';
223             }
224              
225             my $request = new HTTP::Request("GET", $validatorUri );
226             my $validatorResponse = new HTTP::Response;
227             $validatorResponse = $ua->simple_request($request);
228              
229             if ( ! $validatorResponse->is_success ) {
230             push @result_tmp, "N/A";
231             push @result_tmp, "N/A";
232             push @result_tmp, "can't connect";
233             } else {
234             # Actual tests
235             if ( $validatorResponse->content =~ $testStringCharset ) {
236             push @result_tmp, "No";
237             push @result_tmp, "N/A";
238             push @result_tmp, "N/A";
239             }
240             elsif ( $validatorResponse->content =~ $testStringDoctype ) {
241             push @result_tmp, "Yes";
242             push @result_tmp, "No";
243             push @result_tmp, "N/A";
244             }
245             elsif ( $validatorResponse->content =~ $testStringInvalid )
246             {
247             push @result_tmp, "Yes";
248             push @result_tmp, "Yes";
249             my $numErrors = $validatorResponse->header('X-W3C-Validator-Errors');
250             print "Invalid... $numErrors Errors" if ( $verbose > 1);
251             push @result_tmp, "No ($numErrors)";
252             }
253             elsif ( $validatorResponse->content =~ $testStringValid ) {
254             push @result_tmp, "Yes";
255             push @result_tmp, "Yes";
256             push @result_tmp, "Yes";
257             } else {
258             push @result_tmp, "N/A";
259             push @result_tmp, "N/A";
260             push @result_tmp, "Could not validate";
261             }
262             print "\n" if ($verbose > 1);
263             }
264             # store results for this URI in table of results
265             push @result, [@result_tmp];
266             }
267             my $intro_str = "Here are the $census most popular documents surveyed for $name on .";
268             print "Done!\n" if $verbose;
269             #print "Result: @result \n" if $verbose;
270             if (defined ($config{tmpfile}))
271             {
272             untie %hits;
273             }
274             # Here is what the module will return. The hash will be sent to
275             # the output module
276              
277             my %returnhash;
278             # the name of the module
279             $returnhash{"name"}="SurveyEngine";
280             #intro
281             $returnhash{"intro"}=$intro_str;
282             #Headers for the result table
283             @{$returnhash{"thead"}} = @result_head;
284             # data for the results table
285             @{$returnhash{"trows"}} = @result;
286             #outro
287             $returnhash{"outro"}="";
288             return %returnhash;
289             }
290              
291             package W3C::LogValidator::SurveyEngine;
292              
293             1;
294              
295             __END__