site_tester

   1 #! /usr/bin/perl
   2 # site_tester tests sites, and is released
   3 # under the terms of the GPL version 2, or any later version, at your
   4 # option. See the file README and COPYING for more information.
   5 # Copyright 2009 by Don Armstrong <don@donarmstrong.com>.
   6 # $Id: perl_script 1432 2009-04-21 02:42:41Z don $
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 site_tester - Test sites
  18
  19 =head1 SYNOPSIS
  20
  21  [options]
  22
  23  Options:
  24   --debug, -d debugging level (Default 0)
  25   --help, -h display this help
  26   --man, -m display manual
  27
  28 =head1 OPTIONS
  29
  30 =over
  31
  32 =item B<--debug, -d>
  33
  34 Debug verbosity. (Default 0)
  35
  36 =item B<--help, -h>
  37
  38 Display brief usage information.
  39
  40 =item B<--man, -m>
  41
  42 Display this manual.
  43
  44 =back
  45
  46 =head1 EXAMPLES
  47
  48
  49 =cut
  50
  51
  52 use vars qw($DEBUG);
  53
  54 use WWW::Mechanize;
  55
  56 my %options = (debug           => 0,
  57                help            => 0,
  58                man             => 0,
  59                ip_addr         => '127.0.0.1',
  60                apache_conf     => '/etc/apache2/sites-enabled/*',
  61                );
  62
  63 GetOptions(\%options,
  64            'debug|d+','help|h|?','man|m',
  65            'ip_addr|ip-addr=s',
  66            'apache_conf|apache-conf=s',
  67           );
  68
  69 pod2usage() if $options{help};
  70 pod2usage({verbose=>2}) if $options{man};
  71
  72 $DEBUG = $options{debug};
  73
  74 my @USAGE_ERRORS;
  75 # if (1) {
  76 #      push @USAGE_ERRORS,"You must pass something";
  77 # }
  78
  79 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  80
  81 my @conf_files = glob($options{apache_conf});
  82
  83 my %sites;
  84
  85 {package SITE_TESTER::http;
  86  use warnings;
  87  use strict;
  88  use LWP::Protocol::http;
  89  require LWP::MemberMixin;
  90  use base qw(LWP::Protocol::http);
  91  sub _new_socket{
  92      my($self, $host, $port, $timeout) = @_;
  93      $host = $self->{ua}{____special_host};
  94      return $self->SUPER::_new_socket($host,$port,$timeout);
  95  }
  96  sub socket_class {
  97      return "LWP::Protocol::http::Socket";
  98  }
  99 }
 100
 101 # parse the conf_files
 102
 103 for my $conf_file (@conf_files) {
 104     next unless -r $conf_file;
 105     my $fh = IO::File->new($conf_file,'r');
 106     while (<$fh>) {
 107         chomp;
 108         next unless /^\s*ServerName\s(\S+)/;
 109         $sites{$1} = 1;
 110     }
 111 }
 112
 113 my $mech = WWW::Mechanize->new(autocheck => 0);
 114 $mech->{____special_host} = $options{ip_addr};
 115 LWP::Protocol::implementor('http','SITE_TESTER::http');
 116
 117 for my $site (sort keys %sites) {
 118     $mech->get("http://$site/");
 119     print "site $site [$options{ip_addr}]: ".$mech->status()."\n";
 120     # print $mech->content();
 121     # for my $header ($mech->response->header_field_names) {
 122     #   print $header.': '.$mech->response->header($header)."\n";
 123     # }
 124 }
 125
 126 __END__