Finally merged the branch 'apache20'(+'apache2') back to the main trunk.

[www.jankratochvil.net.git] / html-test.pl

diff --git a/html-test.pl b/html-test.pl
new file mode 100755 (executable)
index 0000000..ce68887
--- /dev/null
+++ b/html-test.pl
@@ -0,0 +1,82 @@
+#! /usr/bin/perl
+#
+# $Id$
+
+
+use strict;
+use warnings;
+use My::ModPerlPm;
+require LWP::UserAgent;
+require HTTP::Status;
+require LWP;
+use Carp qw(confess cluck);
+use Getopt::Long;
+use Sys::Hostname::Long;
+use URI::Escape;
+
+
+my $URL_BASE="http://".hostname_long().":7680";
+my $URL_VALIDATOR_BASE="http://validator.w3.org/check?uri=";
+my $URL_VALIDATOR_BASE_LOCAL="http://localhost/cgi-bin/check.cgi?uri=";
+
+
+my $opt_validate;
+my $opt_local;
+die if !GetOptions(
+               "validate!",\$opt_validate,
+               "local!",\$opt_local,
+               );
+
+my($first_pattern)=@ARGV;
+die if @ARGV>=2;
+
+
+$|=1;
+
+my $UA=LWP::UserAgent->new();
+$UA->env_proxy();
+
+my $first_seen=!$first_pattern;
+My::ModPerlPm->list("sub"=>sub {
+       my($p)=@_;
+       require $p->{"file"};
+       eval 'require '.$p->{"module"}.'; 1;'
+                       or cluck "Error loading module ".$p->{"module"}.": $@";
+       my $HTML_TEST=eval '$'.$p->{"module"}.'::HTML_TEST;';
+       return if defined $HTML_TEST && !$HTML_TEST;
+       my $validate=$opt_validate;
+       $validate=0 if $HTML_TEST && $HTML_TEST eq "download";
+       my $HTML_TEST_QUERY_STRING=eval '$'.$p->{"module"}.'::HTML_TEST_QUERY_STRING;';
+       for my $query_string ("ARRAY" eq ref $HTML_TEST_QUERY_STRING ? @$HTML_TEST_QUERY_STRING : $HTML_TEST_QUERY_STRING) {
+               my $url=$URL_BASE.$p->{"url"}.(!$query_string ? "" : "?".$query_string);
+               my $url_matches=1 if $first_pattern && $url=~/$first_pattern/o;
+               die "Pattern amiguous on: $url\n" if $first_seen && $url_matches;
+               if (!$first_seen && !($first_seen=($url=~/$first_pattern/o))) {
+                       print "_";
+                       next;
+                       }
+               print ".";
+               if ($validate) {
+                       $url=($opt_local ? $URL_VALIDATOR_BASE_LOCAL : $URL_VALIDATOR_BASE).uri_escape($url);
+                       }
+               my $request=HTTP::Request->new("GET",$url);
+               $request->header("Cache-control"=>"no-cache");
+               # Do not: ...->request(...);
+               # as it would follow our tested 403 redirect responses.
+               my $response=$UA->simple_request($request);
+               my $HTML_TEST_RC=eval '$'.$p->{"module"}.'::HTML_TEST_RC;';
+               $HTML_TEST_RC=HTTP::Status::RC_OK() if !defined $HTML_TEST_RC;
+               if ($response->code()==$HTML_TEST_RC) {
+                       next if !$validate;
+                       local $_=$response->content();
+                       my   $valid=/\bclass="valid"\s*>/;
+                       my $invalid=/\bclass="invalid"\s*>/;
+                       die "\nUnexpected response: $url\n" if $valid==$invalid;
+                       next if $valid;
+                       die "\n$url\n";
+                       }
+               die "\n$url: ".$response->code()."\n";
+               }
+       }) for (0,($opt_validate ? 1 : ()));
+print "\n";
+die "Nothing seen for: $first_pattern\n" if !$first_seen;