]> git.donarmstrong.com Git - bin.git/blob - site_tester
add common subscriber
[bin.git] / 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 IO::File;
55 use WWW::Mechanize;
56
57 my %options = (debug           => 0,
58                help            => 0,
59                man             => 0,
60                ip_addr         => '127.0.0.1',
61                apache_conf     => '/etc/apache2/sites-enabled/*',
62                );
63
64 GetOptions(\%options,
65            'debug|d+','help|h|?','man|m',
66            'ip_addr|ip-addr=s',
67            'apache_conf|apache-conf=s',
68           );
69
70 pod2usage() if $options{help};
71 pod2usage({verbose=>2}) if $options{man};
72
73 $DEBUG = $options{debug};
74
75 my @USAGE_ERRORS;
76 # if (1) {
77 #      push @USAGE_ERRORS,"You must pass something";
78 # }
79
80 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
81
82 my @conf_files = glob($options{apache_conf});
83
84 my %sites;
85
86 {package SITE_TESTER::http;
87  use warnings;
88  use strict;
89  use LWP::Protocol::http;
90  require LWP::MemberMixin;
91  use base qw(LWP::Protocol::http);
92  sub _new_socket{
93      my($self, $host, $port, $timeout) = @_;
94      $host = $self->{ua}{____special_host};
95      return $self->SUPER::_new_socket($host,$port,$timeout);
96  }
97  sub socket_class {
98      return "LWP::Protocol::http::Socket";
99  }
100 }
101
102 # parse the conf_files
103
104 for my $conf_file (@conf_files) {
105     next unless -r $conf_file;
106     my $fh = IO::File->new($conf_file,'r');
107     while (<$fh>) {
108         chomp;
109         next unless /^\s*ServerName\s(\S+)/;
110         $sites{$1} = 1;
111     }
112 }
113
114 my $mech = WWW::Mechanize->new(autocheck => 0);
115 $mech->{____special_host} = $options{ip_addr};
116 LWP::Protocol::implementor('http','SITE_TESTER::http');
117
118 for my $site (sort keys %sites) {
119     $mech->get("http://$site/");
120     print "site $site [$options{ip_addr}]: ".$mech->status()."\n";
121     # print $mech->content();
122     # for my $header ($mech->response->header_field_names) {
123     #   print $header.': '.$mech->response->header($header)."\n";
124     # }
125 }
126
127 __END__