#!/usr/local/bin/perl
#  *MUST* have the above line.  httpd cannot run this program without it!

#  Change this variable to your HARVEST_HOME
$ENV{'HARVEST_HOME'} = "/usr/local/harvest";
$HH=$ENV{'HARVEST_HOME'};

#  Set this to a location for BrokerQuery.log, or to /dev/null
#  $LOG = "/tmp/admin.log";
$LOG = "/tmp/admin.log";

$DIR = &mydir ($0);
$MYNAME = $0;
$ENV{'TMPDIR'} = "/tmp" unless defined($ENV{'TMPDIR'});
$ENV{'HARVEST_HOME'}= "/usr/local/harvest" unless defined($ENV{'HARVEST_HOME'});
unshift(@INC, "$ENV{'HARVEST_HOME'}/lib");

require 'socket.ph';	# not sys/socket.ph, we use $HARVEST_HOME/lib/socket.ph
require 'ctime.pl';	# we use $HARVEST_HOME/lib/ctime.pl

$debug		= 0;
$hostname_cmd	= 'hostname';
$hostname_cmd	= '/bin/hostname' if (-x '/bin/hostname');
$hostname_cmd	= '/usr/ucb/hostname' if (-x '/usr/ucb/hostname');

$CGI_NAME = 'http://' . $ENV{'SERVER_NAME'} . ':' . $ENV{'SERVER_PORT'};
$CGI_NAME .= $ENV{'SCRIPT_NAME'};

@tags = (       "Data-Directory", 
                "Debug-Options", 
                "Essence-Options", 
                "Gatherer-Options", 
                "Gatherd-Inetd", 
                "Gatherer-Host", 
                "Gatherer-Name",
                "Gatherer-Port",
                "Gatherer-Version",
                "HTTP-Proxy", 
                "Lib-Directory",
                "Local-Mapping",
                "Log-File",
                "Errorlog-File",
                "Post-Processing-Rules",
                "Refresh-Rate",
                "Time-To-Live",
                "Top-Directory",
                "Working-Directory",
        );

# ===== MAIN =================================================================

%RQ = &get_request;

if ($debug) {
	print "Content-Type: text/plain\r\n\r\n";
} else {
	print "Content-Type: text/html\r\n\r\n";
}

&dump_array (%ENV)	if ($debug);
print '-'x80 . "\n\n"	if ($debug);

&dump_array (%RQ)	if ($debug);
print '-'x80 . "\n\n"	if ($debug);

$cmd		= $RQ{'cmd'};
$gatherer	= $RQ{'gatherer'};

&read_gatherer_config ($gatherer);
&write_html_form;

exit 0;		# END OF PROGRAM

# ===== SUBROUTINES ==========================================================

sub read_gatherer_config {
	local ($name) = shift;

	$GCF="$HH/gatherers/$name/$name.cf";
        unless (open (GCF)) {
		print <<EOF;
Cannot open '$name' gatherer configuration file for reading.
Perhaps:

    - The gatherer does not exist.
    - File permissions deny the HTTP server userid access to the gatherer.
    - HARVEST_HOME is not correctly set in $MYNAME.
EOF
		return;
	}

        while (<GCF>) {
		print if ($debug);
		chop;
		s/#.*//;
		next unless (/./);
		if (/([^:]+):\s+(.*)/) {
			$CF{$1} = $2;
			print "\$CF{$1} = $2\n" if ($debug);
		}
	}
        close (GCF);
}


sub write_html_form {
	print "<PRE>\n";
	print "<FORM METHOD=POST ACTION=$CGI_NAME>\n";
	foreach $tag (@tags) {
		print ' ' x (22 - length($tag));
		print "<B>$tag</B>: ";
		print "<INPUT NAME=\"$tag\" SIZE=40 VALUE=\"$CF{$tag}\">\n";
	}
	print "</FORM>\n";
	print "</PRE>\n";
}


sub html_escape {
	$_ = shift;
	s/\&/\&amp;/g;		# do ampersand first!
	s/</\&lt;/g;
	s/>/\&gt;/g;
	s/\&amp;(\w+;)/\&\1/g;	# try putting some HTML back   &Circ;
	s/\&amp;(#\d+;)/\&\1/g;	# try putting some HTML back   &#38;
	$_;
}


sub dump_array {
	local (%A) =  @_;
	local ($key);
        foreach $key ( sort keys %A) {
                print "$key=$A{$key}\n";
        }
	1;
}

sub mydir {
	@D = split ('/', shift);
	pop @D;
	@D = (".") if (@D == ());
	join ('/', @D);
}

######################################################################
# Below is cgi.pl...
#
# &get_request;
# $area=$rqpairs{'area'};
# $title=$rqpairs{'title'};
# $name=$rqpairs{'name'};
# $msg = $rqpairs{'message'};
# $date = &get_date;
# chop($thishost = `hostname`);
# 
# # Check for blank title and URL
# #
# &failure ("Blank title")     	if ($title eq "");
# &failure ("Blank name")     	if ($name  eq "");
# &failure ("Empty message")   	if ($msg   eq "");
# &failure ("Empty subject area") if ($area  eq "");


# The CGI_HANDLERS deal with basic CGI POST or GET method request
# elements such as those delivered by an HTTPD form, i.e. a url
# encoded line of "=" separated key=value pairs separated by &'s

# Routines:
# get_request:	reads the request and returns both the raw and
#               processed version.
# url_decode:	URL decodes a string or array of strings
# html_header:	Transmits a HTML header back to the caller
# html_trailer: Transmits a HTML trailer back to the caller

# Author:
# 	James Tappin: sjt@xun8.sr.bham.ac.uk
#	School of Physics & Space Research University of Birmingham
#	Feb 1993.		

# Copyright & Disclaimer.
#	This set of routines may be freely distributed, modified and
#	used, provided this copyright & disclaimer remains intact.
#	This package is used at your own risk, if it does what you
#	want, good; if it doesn't, modify it or use something else--but
#	don't blame me. Support level = negligable (i.e. mail bugs but
#	not requests for extensions)

# Usage:
#	needs a 'require "cgi_handlers.pl";' line in the main script
#
#	&get_request;    will get the request and decode it into an
#			 indexed array %rqpairs, the raw request is in
#			 $request
#
#	... = &url_decode(LIST); will return a URL decoded version of
#			         the contents of LIST
#
#	&html_header(TITLE); 	will write to standard output an HTML
#				header (including the content-type
#				field) giving the document the title
#				specified by TITLE.
#
#	&html_trailer;		Writes a trailer to the html document
#				with the name of the script generating
#				it and the date (in UT).

sub get_request {

    # Subroutine get_request reads the POST or GET form request from STDIN
    # into the variable  $request, and then splits it into its
    # name=value pairs in the associative array %rqpairs.
    # The number of bytes is given in the environment variable
    # CONTENT_LENGTH which is automatically set by the request generator.

    # Encoded HEX values and spaces are decoded in the values at this
    # stage.

    # $request will contain the RAW request. N.B. spaces and other
    # special characters are not handler in the name field.

    if ($ENV{'REQUEST_METHOD'} eq "POST") {
	read(STDIN, $request, $ENV{'CONTENT_LENGTH'});
    } elsif ($ENV{'REQUEST_METHOD'} eq "GET" ) {
	$request = $ENV{'QUERY_STRING'};
    }

    &url_decode(split(/[&=]/, $request));
}

sub url_decode {
#	Decode a URL encoded string or array of strings 
#		+ -> space
#		%xx -> character xx

    foreach (@_) {
	tr/+/ /;
	s/%(..)/pack("c",hex($1))/ge;
    }
    #@_;

    # This gross stuff handles multiply defined attributes.  For example:
    #    foo=abc&foo=xyz
    # comes back as
    #    $RQ{'foo'} eq 'abc xyz'
    # Otherwise, the previous method just gave us one or the other.    -DW
    # 
    local ($k, $v);
    local (%Y);
    while (($k=shift @_) ne '' && ($v=shift @_) ne '') {
        $Y{$k} = defined $Y{$k} ? join (' ', $Y{$k}, $v) : $v;
    }
    %Y; 
}

