html-test.pl

   1 #! /usr/bin/perl
   2 #
   3 # $Id$
   4
   5
   6 use strict;
   7 use warnings;
   8 use My::ModPerlPm;
   9 require LWP::UserAgent;
  10 require HTTP::Status;
  11 require LWP;
  12 use Carp qw(confess cluck);
  13 use Getopt::Long;
  14 use Sys::Hostname::Long;
  15 use URI::Escape;
  16
  17
  18 my $URL_BASE="http://".hostname_long().":7680";
  19 my $URL_VALIDATOR_BASE="http://validator.w3.org/check?uri=";
  20
  21
  22 my $opt_validate;
  23 die if !GetOptions(
  24                 "validate!",\$opt_validate,
  25                 );
  26
  27 my($first_pattern)=@ARGV;
  28 die if @ARGV>=2;
  29
  30
  31 $|=1;
  32
  33 my $UA=LWP::UserAgent->new();
  34 $UA->env_proxy();
  35
  36 my $first_seen=!$first_pattern;
  37 My::ModPerlPm->list("sub"=>sub {
  38         my($p)=@_;
  39         require $p->{"file"};
  40         eval 'require '.$p->{"module"}.'; 1;'
  41                         or cluck "Error loading module ".$p->{"module"}.": $@";
  42         my $result=eval '$'.$p->{"module"}.'::HTML_TEST;';
  43         return if defined $result && !$result;
  44         my $url=$URL_BASE.$p->{"url"};
  45         my $url_matches=1 if $first_pattern && $url=~/$first_pattern/o;
  46         die "Pattern amiguous on: $url\n" if $first_seen && $url_matches;
  47         if (!$first_seen && !($first_seen=($url=~/$first_pattern/o))) {
  48                 print "_";
  49                 return;
  50                 }
  51         print ".";
  52         if ($opt_validate) {
  53                 $url=$URL_VALIDATOR_BASE.uri_escape($url);
  54                 }
  55         my $request=HTTP::Request->new("GET",$url);
  56         $request->header("Cache-control"=>"no-cache");
  57         my $response=$UA->request($request);
  58         if ($response->code()==HTTP::Status::RC_OK()) {
  59                 return if !$opt_validate;
  60                 local $_=$response->content();
  61                 my   $valid=/\bclass="valid"\s*>/;
  62                 my $invalid=/\bclass="invalid"\s*>/;
  63                 die "\nUnexpected response: $url\n" if $valid==$invalid;
  64                 return if $valid;
  65                 die "\n$url\n";
  66                 }
  67         die "\n$url: ".$response->code()."\n";
  68         });
  69 print "\n";
  70 die "Nothing seen for: $first_pattern\n" if !$first_seen;