#!/usr/local/bin/perl

################################################################
#  wwwtest.pl  by David Efflandt  efflandt@xnet.com  12/20/98  #
#                                                              #
#  CGI/SSI or shell online/response test of remote webserver.  #
#  Links successful response to server (same|different link).  #
#                                                              #
#  CGI/SSI:  wwwtest.cgi ($defaulturl & optional $linkurl)     #
#  Shell:    wwwtest http://site.name.com:8080/                #
#            wwwtest http://site.name.com/~username/           #
################################################################

### User variables

# Alarm timeout (seconds) for lookup, connect, response
$timeout = 5;

# Uncomment for CGI or SSI cgi= (comment out for shell or SSI cmd=)
#print "Content-type: text/html\n\n";

# Default URL for CGI/SSI (can include :port)
#$defaulturl = 'http://localhost/';
#$defaulturl = 'http://your.site.com/';
$defaulturl = 'http://www.xnet.com/~efflandt/';

# Alternate link URL (if defined) when using $defaulturl
$linkurl = '';

### End of user variables


# Required for perl5.
use Socket;

# Get http address and rip into its corresponding parts
($_) = @ARGV;
$_ = $defaulturl unless $_;
$url = $_;

/http:\/\/([^\/]*)\/*([^ ]*)/;
$site = $1;
$uri = "/".$2;

if (!$site) {
  print "$0:  URL Error.
  URL address appears to be munged.
  It must be in the form http://www.any.site/location\n";
  exit;
}

$_ = $site;
/^([^:]*):*([^ ]*)/;
$host = $1;
$port = $2;
$port = 80 unless $port;

# Open socket and attempt connect
($sockaddr,$there,$response,$tries) = ("Snc4x8");
$there = pack($sockaddr,2,$port, &getaddress($host));
$proto = (getprotobyname ('tcp'))[2];

unless (socket(S,AF_INET,SOCK_STREAM,$proto))
  {print "Can't open socket: $!\n"; exit;};

eval {
  local $SIG{ALRM} = sub{die "Server is not connected\n";};
  alarm $timeout;
  $err = $! unless connect(S,$there);
  alarm 0;
};
if ($@) {
  print "$@";		# alarm timeout (no connect response)
  exit;
} elsif ($err) {
  print "$err\n";	# ie: Connection refused
  exit;
}

# Disable socket buffering
select(S);$|=1;
select(STDOUT);

# See if webserver responds to header request.
print S "HEAD $uri HTTP/1.0\n";
print S 'Host: ' . "$host\n";
print S "User-Agent: Perl (any OS)\n\n";

eval {
  local $SIG{ALRM} = sub{die "Server timed out\n";};
  alarm $timeout;
  @lines = <S>;
  alarm 0;
};
close(S);
$line = shift(@lines);
if ($@) {
  print "$@";
  exit;
} elsif ($line =~ /200 OK/i) {
  $url = $linkurl if ($linkurl && $url eq $defaulturl);
  print qq(<a href="$url">Server is ONLINE</a>\n);
} else {
  print "Bad server response: $line\n";
}

sub getaddress {
  local($host) = @_;
  local(@ary);
  if (@ary = gethostbyname($host)) {
    return(unpack("C4",$ary[4]));
  } else {
    print "Host not found\n";
    exit;
  }
}