Initial mod_perl-2.0 port.

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

diff --git a/html-test.pl b/html-test.pl
new file mode 100755 (executable)
index 0000000..aa09b81
--- /dev/null
+++ b/html-test.pl
@@ -0,0 +1,70 @@
+#! /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 $opt_validate;
+die if !GetOptions(
+               "validate!",\$opt_validate,
+               );
+
+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 $result=eval '$'.$p->{"module"}.'::HTML_TEST;';
+       return if defined $result && !$result;
+       my $url=$URL_BASE.$p->{"url"};
+       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 "_";
+               return;
+               }
+       print ".";
+       if ($opt_validate) {
+               $url=$URL_VALIDATOR_BASE.uri_escape($url);
+               }
+       my $request=HTTP::Request->new("GET",$url);
+       $request->header("Cache-control"=>"no-cache");
+       my $response=$UA->request($request);
+       if ($response->code()==HTTP::Status::RC_OK()) {
+               return if !$opt_validate;
+               local $_=$response->content();
+               my   $valid=/\bclass="valid"\s*>/;
+               my $invalid=/\bclass="invalid"\s*>/;
+               die "\nUnexpected response: $url\n" if $valid==$invalid;
+               return if $valid;
+               die "\n$url\n";
+               }
+       die "\n$url: ".$response->code()."\n";
+       });
+print "\n";
+die "Nothing seen for: $first_pattern\n" if !$first_seen;