dbmmanage, log_server_status, et al are now generated files; get them

#!/usr/local/bin/perl

# ====================================================================

# The Apache Software License, Version 1.1

#

# Copyright (c) 2000-2001 The Apache Software Foundation.  All rights

# reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions

# are met:

#

# 1. Redistributions of source code must retain the above copyright

#    notice, this list of conditions and the following disclaimer.

#

# 2. Redistributions in binary form must reproduce the above copyright

#    notice, this list of conditions and the following disclaimer in

#    the documentation and/or other materials provided with the

#    distribution.

#

# 3. The end-user documentation included with the redistribution,

#    if any, must include the following acknowledgment:

#       "This product includes software developed by the

#        Apache Software Foundation (http://www.apache.org/)."

#    Alternately, this acknowledgment may appear in the software itself,

#    if and wherever such third-party acknowledgments normally appear.

#

# 4. The names "Apache" and "Apache Software Foundation" must

#    not be used to endorse or promote products derived from this

#    software without prior written permission. For written

#    permission, please contact apache@apache.org.

#

# 5. Products derived from this software may not be called "Apache",

#    nor may "Apache" appear in their name, without prior written

#    permission of the Apache Software Foundation.

#

# THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED

# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES

# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

# DISCLAIMED.  IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR

# ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF

# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND

# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT

# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF

# SUCH DAMAGE.

# ====================================================================

#

# This software consists of voluntary contributions made by many

# individuals on behalf of the Apache Software Foundation.  For more

# information on the Apache Software Foundation, please see

# <http://www.apache.org/>.

#

#for more functionality see the HTTPD::UserAdmin module:

# http://www.perl.com/CPAN/modules/by-module/HTTPD/HTTPD-Tools-x.xx.tar.gz

#

# usage: dbmmanage <DBMfile> <command> <user> <password> <groups> <comment>

package dbmmanage;

#                               -ldb    -lndbm    -lgdbm    -lsdbm

BEGIN { @AnyDBM_File::ISA = qw(DB_File NDBM_File GDBM_File SDBM_File) }

use strict;

use Fcntl;

use AnyDBM_File ();

sub usage {

    my $cmds = join "|", sort keys %dbmc::;

    die <<SYNTAX;

Usage: dbmmanage [enc] dbname command [username [pw [group[,group] [comment]]]]

    where enc is  -d for crypt encryption (default except on Win32, Netware)

                  -m for MD5 encryption (default on Win32, Netware)

                  -s for SHA1 encryption

                  -p for plaintext

    command is one of: $cmds

    pw of . for update command retains the old password

    pw of - (or blank) for update command prompts for the password

    groups or comment of . (or blank) for update command retains old values

    groups or comment of - for update command clears the existing value

    groups or comment of - for add and adduser commands is the empty value

SYNTAX

}

sub need_sha1_crypt {

    if (!eval ('require "Digest/SHA1.pm";')) {

        print STDERR <<SHAERR;

dbmmanage SHA1 passwords require the interface or the module Digest::SHA1

available from CPAN:

    http://www.cpan.org/modules/by-module/Digest/Digest-MD5-2.12.tar.gz

Please install Digest::SHA1 and try again, or use a different crypt option:

SHAERR

        usage();

    }

}

sub need_md5_crypt {

    if (!eval ('require "Crypt/PasswdMD5.pm";')) {

        print STDERR <<MD5ERR;

dbmmanage MD5 passwords require the module Crypt::PasswdMD5 available from CPAN

    http://www.cpan.org/modules/by-module/Crypt/Crypt-PasswdMD5-1.1.tar.gz

Please install Crypt::PasswdMD5 and try again, or use a different crypt option:

MD5ERR

        usage();

    }

}

# if your osname is in $newstyle_salt, then use new style salt (starts with '_' and contains

# four bytes of iteration count and four bytes of salt).  Otherwise, just use

# the traditional two-byte salt.

# see the man page on your system to decide if you have a newer crypt() lib.

# I believe that 4.4BSD derived systems do (at least BSD/OS 2.0 does).

# The new style crypt() allows up to 20 characters of the password to be

# significant rather than only 8.

#

my $newstyle_salt_platforms = join '|', qw{bsdos}; #others?

my $newstyle_salt = $^O =~ /(?:$newstyle_salt_platforms)/;

# Some platforms just can't crypt() for Apache

#

my $crypt_not_supported_platforms = join '|', qw{MSWin32 NetWare}; #others?

my $crypt_not_supported = $^O =~ /(?:$crypt_not_supported_platforms)/;

my $crypt_method = "crypt";

if ($crypt_not_supported) {

    $crypt_method = "md5";

}

# Some platforms won't jump through our favorite hoops

#

my $not_unix_platforms = join '|', qw{MSWin32 NetWare}; #others?

my $not_unix = $^O =~ /(?:$not_unix_platforms)/;

if ($crypt_not_supported) {

    $crypt_method = "md5";

}

if (@ARGV[0] eq "-d") {

    shift @ARGV;

    if ($crypt_not_supported) {

        print STDERR 

              "Warning: Apache/$^O does not support crypt()ed passwords!\n\n";

    }

    $crypt_method = "crypt";

}

if (@ARGV[0] eq "-m") {

    shift @ARGV;

    $crypt_method = "md5";

}

if (@ARGV[0] eq "-p") {

    shift @ARGV;

    if (!$crypt_not_supported) {

        print STDERR 

              "Warning: Apache/$^O does not support plaintext passwords!\n\n";

    }

    $crypt_method = "plain";

}

if (@ARGV[0] eq "-s") {

    shift @ARGV;

    need_sha1_crypt();

    $crypt_method = "sha1";

}

if ($crypt_method eq "md5") {

    need_md5_crypt();

}

my($file,$command,$key,$crypted_pwd,$groups,$comment) = @ARGV;

usage() unless $file and $command and defined &{$dbmc::{$command}};

# remove extension if any

my $chop = join '|', qw{db.? pag dir};

$file =~ s/\.($chop)$//;

my $is_update = $command eq "update";

my %DB = ();

my @range = ();

my($mode, $flags) = $command =~ 

    /^(?:view|check)$/ ? (0644, O_RDONLY) : (0644, O_RDWR|O_CREAT);

tie (%DB, "AnyDBM_File", $file, $flags, $mode) || die "Can't tie $file: $!";

dbmc->$command();

untie %DB;

my $x;

sub genseed {

    my $psf;

    if ($not_unix) {

	srand (time ^ $$ or time ^ ($$ + ($$ << 15)));

    }

    else {

        for (qw(-xlwwa -le)) { 

	    `ps $_ 2>/dev/null`;

            $psf = $_, last unless $?;

        }

        srand (time ^ $$ ^ unpack("%L*", `ps $psf | gzip -f`));

    }

    @range = (qw(. /), '0'..'9','a'..'z','A'..'Z');

    $x = int scalar @range;

}

sub randchar { 

    join '', map $range[rand $x], 1..shift||1;

}

sub saltpw_crypt {

    genseed() unless @range; 

    return $newstyle_salt ? 

	join '', "_", randchar, "a..", randchar(4) :

        randchar(2);

}

sub cryptpw_crypt {

    my ($pw, $salt) = @_;

    $salt = saltpw_crypt unless $salt;

    crypt $pw, $salt;

}

sub saltpw_md5 {

    genseed() unless @range; 

    randchar(8);

}

sub cryptpw_md5 {

    my($pw, $salt) = @_;

    $salt = saltpw_md5 unless $salt;

    Crypt::PasswdMD5::apache_md5_crypt($pw, $salt);

}

sub cryptpw_sha1 {

    my($pw, $salt) = @_;

    '{SHA}' . Digest::SHA1::sha1_base64($pw) . "=";

}

sub cryptpw {

    if ($crypt_method eq "md5") {

        return cryptpw_md5(@_);

    } elsif ($crypt_method eq "sha1") {

        return cryptpw_sha1(@_);

    } elsif ($crypt_method eq "crypt") {

        return cryptpw_crypt(@_);

    }

    @_[0]; # otherwise return plaintext

}

sub getpass {

    my $prompt = shift || "Enter password:";

    unless($not_unix) { 

	open STDIN, "/dev/tty" or warn "couldn't open /dev/tty $!\n";

	system "stty -echo;";

    }

    my($c,$pwd);

    print STDERR $prompt;

    while (($c = getc(STDIN)) ne '' and $c ne "\n" and $c ne "\r") {

	$pwd .= $c;

    }

    system "stty echo" unless $not_unix;

    print STDERR "\n";

    die "Can't use empty password!\n" unless length $pwd;

    return $pwd;

}

sub dbmc::update {

    die "Sorry, user `$key' doesn't exist!\n" unless $DB{$key};

    $crypted_pwd = (split /:/, $DB{$key}, 3)[0] if $crypted_pwd eq '.';

    $groups = (split /:/, $DB{$key}, 3)[1] if !$groups || $groups eq '.';

    $comment = (split /:/, $DB{$key}, 3)[2] if !$comment || $comment eq '.';

    if (!$crypted_pwd || $crypted_pwd eq '-') {

        dbmc->adduser;

    }

    else {

        dbmc->add;

    }

}

sub dbmc::add {

    die "Can't use empty password!\n" unless $crypted_pwd;

    unless($is_update) {

	die "Sorry, user `$key' already exists!\n" if $DB{$key};

    }

    $groups = '' if $groups eq '-';

    $comment = '' if $comment eq '-';

    $groups .= ":" . $comment if $comment;

    $crypted_pwd .= ":" . $groups if $groups;

    $DB{$key} = $crypted_pwd;

    my $action = $is_update ? "updated" : "added";

    print "User $key $action with password encrypted to $DB{$key} using $crypt_method\n";

}

sub dbmc::adduser {

    my $value = getpass "New password:";

    die "They don't match, sorry.\n" unless getpass("Re-type new password:") eq $value;

    $crypted_pwd = cryptpw $value;

    dbmc->add;

}

sub dbmc::delete {

    die "Sorry, user `$key' doesn't exist!\n" unless $DB{$key};

    delete $DB{$key}, print "`$key' deleted\n";

}

sub dbmc::view {

    print $key ? "$key:$DB{$key}\n" : map { "$_:$DB{$_}\n" if $DB{$_} } keys %DB;

}

sub dbmc::check {

    die "Sorry, user `$key' doesn't exist!\n" unless $DB{$key};

    my $chkpass = (split /:/, $DB{$key}, 3)[0];

    my $testpass = getpass();

    if (substr($chkpass, 0, 6) eq '$apr1$') {

        need_md5_crypt;

        $crypt_method = "md5";

    } elsif (substr($chkpass, 0, 5) eq '{SHA}') {

        need_sha1_crypt;

        $crypt_method = "sha1";

    } elsif (length($chkpass) == 13 && $chkpass ne $testpass) {

        $crypt_method = "crypt";

    } else {

        $crypt_method = "plain";

    }

    print $crypt_method . (cryptpw($testpass, $chkpass) eq $chkpass 

                           ? " password ok\n" : " password mismatch\n");

}

sub dbmc::import {

    while(defined($_ = <STDIN>) and chomp) {

	($key,$crypted_pwd,$groups,$comment) = split /:/, $_, 4;

	dbmc->add;

    }

}

#!/usr/local/bin/perl

# ====================================================================

# The Apache Software License, Version 1.1

#

# Copyright (c) 2000-2001 The Apache Software Foundation.  All rights

# reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions

# are met:

#

# 1. Redistributions of source code must retain the above copyright

#    notice, this list of conditions and the following disclaimer.

#

# 2. Redistributions in binary form must reproduce the above copyright

#    notice, this list of conditions and the following disclaimer in

#    the documentation and/or other materials provided with the

#    distribution.

#

# 3. The end-user documentation included with the redistribution,

#    if any, must include the following acknowledgment:

#       "This product includes software developed by the

#        Apache Software Foundation (http://www.apache.org/)."

#    Alternately, this acknowledgment may appear in the software itself,

#    if and wherever such third-party acknowledgments normally appear.

#

# 4. The names "Apache" and "Apache Software Foundation" must

#    not be used to endorse or promote products derived from this

#    software without prior written permission. For written

#    permission, please contact apache@apache.org.

#

# 5. Products derived from this software may not be called "Apache",

#    nor may "Apache" appear in their name, without prior written

#    permission of the Apache Software Foundation.

#

# THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED

# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES

# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

# DISCLAIMED.  IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR

# ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF

# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND

# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT

# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF

# SUCH DAMAGE.

# ====================================================================

#

# This software consists of voluntary contributions made by many

# individuals on behalf of the Apache Software Foundation.  For more

# information on the Apache Software Foundation, please see

# <http://www.apache.org/>.

#

# Log Server Status

# Mark J Cox, UK Web Ltd 1996, mark@ukweb.com

#

# This script is designed to be run at a frequent interval by something

# like cron.  It connects to the server and downloads the status

# information.  It reformats the information to a single line and logs

# it to a file.  Make sure the directory $wherelog is writable by the

# user who runs this script.

#

require 'sys/socket.ph';

$wherelog = "/var/log/graph/";  # Logs will be like "/var/log/graph/19960312"

$server = "localhost";          # Name of server, could be "www.foo.com"

$port = "80";                   # Port on server

$request = "/status/?auto";     # Request to send

sub tcp_connect

{

	local($host,$port) =@_;

        $sockaddr='S n a4 x8';

        chop($hostname=`hostname`);

        $port=(getservbyname($port, 'tcp'))[2]  unless $port =~ /^\d+$/;

        $me=pack($sockaddr,&AF_INET,0,(gethostbyname($hostname))[4]);

        $them=pack($sockaddr,&AF_INET,$port,(gethostbyname($host))[4]);

        socket(S,&PF_INET,&SOCK_STREAM,(getprotobyname('tcp'))[2]) || 

		die "socket: $!";

        bind(S,$me) || return "bind: $!";

        connect(S,$them) || return "connect: $!";

        select(S); 

	$| = 1; 

	select(stdout);

	return "";

}

### Main

{

        $year=`date +%y`;

	chomp($year);

	$year += ($year < 70) ? 2000 : 1900;

	$date = $year . `date +%m%d:%H%M%S`;

	chomp($date);

	($day,$time)=split(/:/,$date);

	$res=&tcp_connect($server,$port);

	open(OUT,">>$wherelog$day");

	if ($res) {

		print OUT "$time:-1:-1:-1:-1:$res\n";

		exit 1;

	}

	print S "GET $request\n";

	while (<S>) {

		$requests=$1 if ( m|^BusyServers:\ (\S+)|);

		$idle=$1 if ( m|^IdleServers:\ (\S+)|);

		$number=$1 if ( m|sses:\ (\S+)|);

		$cpu=$1 if (m|^CPULoad:\ (\S+)|);

	}

	print OUT "$time:$requests:$idle:$number:$cpu\n";

}

#!/usr/local/bin/perl

# ====================================================================

# The Apache Software License, Version 1.1

#

# Copyright (c) 2000-2001 The Apache Software Foundation.  All rights

# reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions

# are met:

#

# 1. Redistributions of source code must retain the above copyright

#    notice, this list of conditions and the following disclaimer.

#

# 2. Redistributions in binary form must reproduce the above copyright

#    notice, this list of conditions and the following disclaimer in

#    the documentation and/or other materials provided with the

#    distribution.

#

# 3. The end-user documentation included with the redistribution,

#    if any, must include the following acknowledgment:

#       "This product includes software developed by the

#        Apache Software Foundation (http://www.apache.org/)."

#    Alternately, this acknowledgment may appear in the software itself,

#    if and wherever such third-party acknowledgments normally appear.

#

# 4. The names "Apache" and "Apache Software Foundation" must

#    not be used to endorse or promote products derived from this

#    software without prior written permission. For written

#    permission, please contact apache@apache.org.

#

# 5. Products derived from this software may not be called "Apache",

#    nor may "Apache" appear in their name, without prior written

#    permission of the Apache Software Foundation.

#

# THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED

# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES

# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

# DISCLAIMED.  IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR

# ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF

# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND

# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT

# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF

# SUCH DAMAGE.

# ====================================================================

#

# This software consists of voluntary contributions made by many

# individuals on behalf of the Apache Software Foundation.  For more

# information on the Apache Software Foundation, please see

# <http://www.apache.org/>.

#

# logresolve.pl

#

# v 1.2 by robh @ imdb.com

# 

# usage: logresolve.pl <infile >outfile

#

# input = Apache/NCSA/.. logfile with IP numbers at start of lines

# output = same logfile with IP addresses resolved to hostnames where

#  name lookups succeeded.

#

# this differs from the C based 'logresolve' in that this script

# spawns a number ($CHILDREN) of subprocesses to resolve addresses

# concurrently and sets a short timeout ($TIMEOUT) for each lookup in

# order to keep things moving quickly.

#

# the parent process handles caching of IP->hostnames using a Perl hash

# it also avoids sending the same IP to multiple child processes to be

# resolved multiple times concurrently.

#

# Depending on the settings of $CHILDREN and $TIMEOUT you should see

# significant reductions in the overall time taken to resolve your

# logfiles. With $CHILDREN=40 and $TIMEOUT=5 I've seen 200,000 - 300,000

# logfile lines processed per hour compared to ~45,000 per hour

# with 'logresolve'.

#

# I haven't yet seen any noticable reduction in the percentage of IPs

# that fail to get resolved. Your mileage will no doubt vary. 5s is long

# enough to wait IMO.

#

# Known to work with FreeBSD 2.2

# Known to have problems with Solaris

#

# 980417 - use 'sockaddr_un' for bind/connect to make the script work

#  with linux. Fix from Luuk de Boer <luuk_de_boer@pi.net>

require 5.004;

$|=1;

use FileHandle;

use Socket;

use strict;

no strict 'refs';

use vars qw($PROTOCOL);

$PROTOCOL = 0;

my $CHILDREN = 40;

my $TIMEOUT  = 5;

my $filename;

my %hash = ();

my $parent = $$;

my @children = ();

for (my $child = 1; $child <=$CHILDREN; $child++) {

	my $f = fork();	

	if (!$f) {

		$filename = "./.socket.$parent.$child";

		if (-e $filename) { unlink($filename) || warn "$filename .. $!\n";}

		&child($child);

		exit(0);

	}

	push(@children, $f);

}

&parent;

&cleanup;

## remove all temporary files before shutting down

sub cleanup {

	 # die kiddies, die

	kill(15, @children);

	for (my $child = 1; $child <=$CHILDREN; $child++) {

		if (-e "./.socket.$parent.$child") {

			unlink("./.socket.$parent.$child")

				|| warn ".socket.$parent.$child $!";

		}

	}

}

sub parent {

	# Trap some possible signals to trigger temp file cleanup

	$SIG{'KILL'} = $SIG{'INT'} = $SIG{'PIPE'} = \&cleanup;

	my %CHILDSOCK;

	my $filename;

	 ## fork child processes. Each child will create a socket connection

	 ## to this parent and use an unique temp filename to do so.

	for (my $child = 1; $child <=$CHILDREN; $child++) {

		$CHILDSOCK{$child}= FileHandle->new;

		if (!socket($CHILDSOCK{$child}, AF_UNIX, SOCK_STREAM, $PROTOCOL)) {

			warn "parent socket to child failed $!";

		}

		$filename = "./.socket.$parent.$child";

		my $response;

		do {

			$response = connect($CHILDSOCK{$child}, sockaddr_un($filename));

			if ($response != 1) {

				sleep(1);

			}                       

		} while ($response != 1);

		$CHILDSOCK{$child}->autoflush;

	}

	## All child processes should now be ready or at worst warming up 

	my (@buffer, $child, $ip, $rest, $hostname, $response);

	 ## read the logfile lines from STDIN

	while(<STDIN>) {

		@buffer = ();	# empty the logfile line buffer array.

		$child = 1;		# children are numbered 1..N, start with #1

		# while we have a child to talk to and data to give it..

		do {

			push(@buffer, $_);					# buffer the line

			($ip, $rest) = split(/ /, $_, 2);	# separate IP form rest

			unless ($hash{$ip}) {				# resolve if unseen IP

				$CHILDSOCK{$child}->print("$ip\n"); # pass IP to next child

				$hash{$ip} = $ip;				# don't look it up again.

				$child++;

			}

		} while (($child < ($CHILDREN-1)) and ($_ = <STDIN>));

		 ## now poll each child for a response

		while (--$child > 0) { 

			$response = $CHILDSOCK{$child}->getline;

			chomp($response);

			 # child sends us back both the IP and HOSTNAME, no need for us

			 # to remember what child received any given IP, and no worries

			 # what order we talk to the children

			($ip, $hostname) = split(/\|/, $response, 2);

			$hash{$ip} = $hostname;

		}

		 # resolve all the logfiles lines held in the log buffer array..

		for (my $line = 0; $line <=$#buffer; $line++) {

			 # get next buffered line

			($ip, $rest) = split(/ /, $buffer[$line], 2);

			 # separate IP from rest and replace with cached hostname

			printf STDOUT ("%s %s", $hash{$ip}, $rest);

		}

	}

}

########################################

sub child {

	 # arg = numeric ID - how the parent refers to me

	my $me = shift;

	 # add trap for alarm signals.

	$SIG{'ALRM'} = sub { die "alarmed"; };

	 # create a socket to communicate with parent

	socket(INBOUND, AF_UNIX, SOCK_STREAM, $PROTOCOL)

		|| die "Error with Socket: !$\n";

	$filename = "./.socket.$parent.$me";

	bind(INBOUND, sockaddr_un($filename))

		|| die "Error Binding $filename: $!\n";

	listen(INBOUND, 5) || die "Error Listening: $!\n";

	my ($ip, $send_back);

	my $talk = FileHandle->new;

	 # accept a connection from the parent process. We only ever have

	 # have one connection where we exchange 1 line of info with the

	 # parent.. 1 line in (IP address), 1 line out (IP + hostname).

	accept($talk, INBOUND) || die "Error Accepting: $!\n";

	 # disable I/O buffering just in case

	$talk->autoflush;

	 # while the parent keeps sending data, we keep responding..

	while(($ip = $talk->getline)) {

		chomp($ip);

		 # resolve the IP if time permits and send back what we found..

		$send_back = sprintf("%s|%s", $ip, &nslookup($ip));

		$talk->print($send_back."\n");

	}

}

# perform a time restricted hostname lookup.

sub nslookup {

	 # get the IP as an arg

	my $ip = shift;

	my $hostname = undef;

	 # do the hostname lookup inside an eval. The eval will use the

	 # already configured SIGnal handler and drop out of the {} block

	 # regardless of whether the alarm occured or not.

	eval {

		alarm($TIMEOUT);

		$hostname = gethostbyaddr(gethostbyname($ip), AF_INET);

		alarm(0);

	};

	if ($@ =~ /alarm/) {

		 # useful for debugging perhaps..

		# print "alarming, isn't it? ($ip)";

	}

	 # return the hostname or the IP address itself if there is no hostname

	$hostname ne "" ? $hostname : $ip;

}

#!/usr/local/bin/perl

# This script is used to detect people trying to abuse the security hole which

# existed in A CGI script direstributed with Apache 1.0.3 and earlier versions.

# You can redirect them to here using the "<Location /cgi-bin/phf*>" suggestion

# in httpd.conf.  

#

# The format logged to is

#    "[date] remote_addr remote_host [date] referrer user_agent".

$LOG = "/var/log/phf_log";

require "ctime.pl";

$when = &ctime(time);

$when =~ s/\n//go;

$ENV{HTTP_USER_AGENT} .= " via $ENV{HTTP_VIA}" if($ENV{HTTP_VIA});

open(LOG, ">>$LOG") || die "boo hoo, phf_log $!";