#!@PERL@
#############################################################################
#
#  search.cgi - Customizable WWW Interface to the Harvest Broker
#
#  Usage: Called as a CGI proccess from httpd
#
#############################################################################
#
#  Harvest Indexer http://harvest.sourceforge.net/
#  -----------------------------------------------
#
#  The Harvest Indexer is a continued development of code developed by
#  the Harvest Project. Development is carried out by numerous individuals
#  in the Internet community, and is not officially connected with the
#  original Harvest Project or its funding sources.
#
#  Please mail lee@arco.de if you are interested in participating
#  in the development effort.
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#

$ENV{'HARVEST_HOME'} = "@prefix@"
    unless defined($ENV{'HARVEST_HOME'});

# Uncomment this if you have problems with European 8-BIT characters on SunOS.
#$ENV{'LANG'} = "C";
#$ENV{'LC_CTYPE'} = "iso_8859_1";

#  Set this to a location for search.log, or to /dev/null
#$BQLOG = "@prefix@/logs/search.log";
$BQLOG = "/dev/null";

$rcsid = '$Id: search.in,v 2.20 2002/07/27 16:25:00 sxw Exp $';

# $expire
# Temporary files are deleted after this many hours.  Or, more precisely, when
# this program is run, files older than $expire hours are deleted.
#
# $tmp_dir
# This is the location where temporary files are kept. This directory needs a
# permissive access mode, so that the 'nobody' user (or whatever
# user httpd uses) can write and delete files there.  It is a fatal error if
# this directory does not exist, or cannot be written in.
#
# $tmp_www
# This prefaces the URL file reference that leads to the 'Next' and 'Previous'
# pages of results, e.g.:
#     http://www.some.host/tmp/875722836-6913-2.html
#

###### configure these locally! #######
$expire  = 1;				# expiration interval, in hours
$tmp_dir = "$ENV{HARVEST_HOME}/tmp";	# dir for temp files
$tmp_www = "/Harvest/tmp";		# URL path pointing to $tmp_dir
######    end configuration     #######

#--- Image "powered by Harvest"
$rHarvestIcon = "http://www.rediris.es/poweredHarvest18.gif";
#--- Image to use as weigth icon
$rWeightIcon = "http://www.rediris.es/weightHarvest01.gif";
#--- URL of the search home page
$rSearchPage = "http://www.xxx.com/search.html";
#--- URL of displaySOIF script
$rDisplaySoifPage = "http://www.rediris.es/harvest/cgi-bin/displaySOIF.rediris";
#--- Elements before and after de current page in the navigation bar
$rNavPart    = 5;

# If name is nph-search.cgi, then we behave as an nph- cgi (ie send more
# headers, and use unbuffered output).

$nph = $0 =~ /nph-/;

@X = split ('/', $0);
$MYNAME = pop @X;
$DIR = join ('/', @X);
$ENV{'TMPDIR'} = "/tmp" unless defined($ENV{'TMPDIR'});
unshift(@INC, "$ENV{'HARVEST_HOME'}/lib");

not_configured() unless (-d $ENV{'HARVEST_HOME'});

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

$debug		= 0;
$hp_url		= '';
$brokers	= $ENV{'HARVEST_HOME'} . '/brokers/Brokers.cf';

$rIndex		= 0;
$rWeight	= 0;
$rGreaterWeight	= 0;
$rResult        = "";
$rNavigationBar = "";
$rTotHtmlFiles  = 0;


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

foreach $sig ('HUP', 'QUIT', 'TSTP', 'TERM', 'ABRT') {
	$SIG{$sig} = 'sigdie';
}

foreach $sig ('ALRM') {
	$SIG{$sig} = 'sigharddie';
}

# Parse the CGI request.
%RQ = &get_request;
$debug = 1 if defined $RQ{'debug'};
foreach $key (keys %RQ) { $RQ{$key} =~ s/\n/ /g; }

# Send the MIME header *now* if we're in debug mode this means it will always
# be text/html, but means when can see debugging information from parse_config

send_header() if $debug;

# Read in the 'master config' file.
&parse_config ("$DIR/lib/search.cf");
&parse_defaults;

$CFG{'rcsid'} = $rcsid;

# Parse a broker-specific config file (included as the following HTML - )
#  <INPUT TYPE="hidden" NAME="brokerqueryconfig" VALUE="foo.cf">

print "opening $DIR/lib/",&option('brokerqueryconfig'),"\n" if ($debug);
&parse_config ("$DIR/lib/".&option('brokerqueryconfig'))
	if ( -f "$DIR/lib/".&option('brokerqueryconfig') );
&parse_defaults;

# We can't send the MIME header *until* we've read the broker-specific file
# (as they might change it in there) - so we have to wait until now to send
# it.

send_header() unless $debug;

# Now - once we're sure that a MIME header has been sent, we can validate
# their input

&fatal ('NoQuery')	if (%RQ == ());
&fatal ('rcsid')	if ($RQ{'version'} ne "");
&dump_array (%RQ)	if ($debug);
&dump_array (%DEF)	if ($debug);
#&dump_array (%ENV)	if ($debug);

# EXTRACT QUERY OPTIONS
#
$lifetime	= &option('lifetime');
$userquery	= &option('query');
$category	= &option('category');
$userclass	= &option('class');
$caseflag	= &option('caseflag')   	eq 'on' ? 1 : 0;
$wordflag	= &option('wordflag')   	eq 'on' ? 1 : 0;
$csumflag	= &option('csumflag')   	eq 'on' ? 1 : 0;
$opaqflag	= &option('opaqueflag')		eq 'on' ? 1 : 0;
$descflag	= &option('descflag')     	eq 'on' ? 1 : 0;
$noregex	= &option('noregexflag')    	eq 'on' ? 1 : 0;
$maxresult	= &option('maxresultflag');
$maxfiles	= &option('maxobjflag');
$maxlines	= &option('maxlineflag');
$perpage 	= &option('perpageflag');
$errors		= &option('errorflag');
$broker 	= &option('broker') ||
		  &option('host');
#$verbflag	= &option('verbose')    	eq "" ? 0 : 1;
$version	= &option('version')		eq "" ? 0 : 1;
$hp_url		= &option('hp_url');
@atts		= split (/\s+/, &option('attribute'));
$sort		= &option('sort');


foreach $a (@atts) {
	$attributes .= " #attribute \"$a\"";
}

# SECURITY CHECKS AND TRANSLATION ON BROKER HOST,PORT
#
$errmsg = <<"EOF";
<TITLE>$broker not found</TITLE>
<PRE>
$MYNAME doesn't know the broker

    <B>$broker</B>

Either it is not in the allowed list, or perhaps
$brokers is not readable.
</PRE>
EOF
&fatal($errmsg)
	unless (@hostport = &get_host_port ($broker));

# HACKS FOR BROKEN LYNX BROWSER
#
$errors = 0 if ($errors eq 'None');
$errors = 1 if ($errors eq '1 Error');
$errors = 2 if ($errors eq '2 Errors');

# SET THE LIFETIME
#
$BQlife = $CFG{'Timeout'};
$BQlife = $lifetime + 300 if ($lifetime ne "");
alarm ($BQlife);

### # SANITY CHECKS
### #
### &fatal ('NoReplica')	if ($host eq "No Replicas");
### &fatal ('Misconfig')	if ($host eq "" || $port == 0);

# CHECK QUERY STRING FOR COMMON MISTAKES
#
$userquery =~ s/^\s+//;			# remove leading whitespace
$userquery =~ s/\s+$//;			# remove trailing whitespace

$userquery = &entities($userquery); # translate SGML entities

unless ( $userquery =~ /\s+and\s+/i || $userquery =~ /\s+or\s+/i
      || $userquery =~ /:\s+/  || $userquery =~ /\"/) {
    if ($category ne "anytext") {
	@X = split (/\s+/, $userquery);
	for ($i=0; $i<=$#X; $i++) {
	    $X[$i] =~ s/^\+(.*)/$1/;      # remove leading +
	    $X[$i] =~ s/^\-(.*)/NOT $1/;  # replace leading - by NOT
	    $X[$i] =~ s/\,//;             # remove commata: not supported by broker
	    # put quotes around unknown characters
	    $X[$i] = "\"$X[$i]\"" if ($X[$i] =~ /[^ \w\d-]/);
	    $X[$i] = "$category:$X[$i]" if (($category ne "any") && ($category ne ""));
	}
	$userquery = join (' AND ', @X);
    } else {
	@X = split (/\s+/, $userquery);
	for ($i=0; $i<=$#X; $i++) {
	    $X[$i] = "\"$X[$i]\"" if ($X[$i] =~ /\W/);
	    $X[$i] = "(keywords:$X[$i] OR title:$X[$i] OR body:$X[$i] OR headings:$X[$i] OR address:$X[$i])"
	}
	$userquery = join (' AND ', @X);
    }
}

# BUILD QUERY STRING
#
$query  = "";
$query .= $userclass . " AND " if ($userclass ne "");

#----------------------------------------------------------------------
# JMM - 19960619
# We use the metatag "DC.Language" to specify the language os the page.
# We can search only the pages in a specific language if user selects
# it in the form (using the searchLang variable)
#---------------------------------------------------------------------,
#$query .= $userquery;

$rLang = $RQ{'searchLang'};
if ($rLang eq "es")
  { $query .= $userquery . " AND (\"DC.Language\" : es)"; }
elsif ($rLang eq "en")
  { $query .= $userquery . " AND (\"DC.Language\" : en)"; }
elsif ($rLang eq "ca")
  { $query .= $userquery . " AND (\"DC.Language\" : ca)"; }
elsif ($rLang eq "gl")
  { $query .= $userquery . " AND (\"DC.Language\" : gl)"; }
else
  { $query .= $userquery; }
#---------------------------------------------------------------------'

# BUILD BROKER QUERY
#
$bquery = "#USER";
$bquery .= " #opaque"				if ($opaqflag);
$bquery .= " #desc"				if ($descflag);
$bquery .= " #index timeout $lifetime"		if ($lifetime ne "");
$bquery .= " #index error $errors"		if ($errors ne "");
$bquery .= " #index maxresult $maxresult"	if ($maxresult ne "");
$bquery .= " #index maxfiles $maxfiles"		if ($maxfiles ne "");
$bquery .= " #index maxlines $maxlines"		if ($maxlines ne "");
$bquery .= " #index case";
$bquery .= $caseflag ? " insensitive" : " sensitive";
$bquery .= " #index matchword"			if ($wordflag);
$bquery .= " #index noregex"			if ($noregex);
$bquery .= $attributes;
$bquery .= " #END ";
$bquery .= $query;

$simple_query = $1 if ($query =~ /^.*partial-text\s*:\s+"(.*)".*$/io);

# Call Init Function
#
eval $CFG{'InitFunction'} if (defined ($CFG{'InitFunction'}));

# DO THE QUERY
#
$html_query = &html_escape ($query);
print &expand ($CFG{'ResultHeader'});
$connected = 0;

while ($#hostport > $[) {
	$host = shift (@hostport);
	$port = shift (@hostport);
	if ($SOCK = &client_socket ($host, $port)) {
		$connected = 1;
		last;
	}
}
&broker_down ($host, $port) unless ($connected);

print "Sending <PRE> $bquery </PRE> to $host:$port<HR>\n" if ($debug);
&do_query ($SOCK, $bquery);
#print &expand ($CFG{'ResultTrailer'});

exit 0;		# END OF PROGRAM

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

# Send the appropriate HTTP headers

sub send_header {
    my $content = (defined $CFG{'ContentType'}) ?
	&expand($CFG{'ContentType'}) : "text/html";

    if ($nph) {
	$|=1;

	print "HTTP/1.0 200 OK\n";
	print "Server: $ENV{SERVER_SOFTWARE}\n";
    }
    print "Content-Type: $content\n\n";
}

# broker_host_port:
#
# If given a name, return the corresponding (host,port) pair.
# If given a host:port string, make sure it is a valid broker.

sub get_host_port {
	local ($broker) = @_;
	local ($name,$host,$port);
	local ($pattern);
	local (@hostport) = ();

	if ($broker =~ /([^:]+):(\d+)/) {		# given host:port
		$host = $1;
		$port = $2;
		return ($host,$port) unless ( -r $brokers );
		$pattern = '\S+\s+' . $host . '\s+' . $port;
	}
	else {						# given a name
		return () unless ( -r $brokers );	# cant translate name
		$broker_re = $broker;
		$broker_re =~ s/\W/\\$&/g;		# escape specials
		$pattern = '^' . $broker_re . '\s+\S+\s+\d+';
	}

	open (brokers) 	|| &fatal ("$brokers: $!\n");
	while (<brokers>) {
		chop;
		s/#.*//;				# strip comments
		s/^\s+//;				# leading whitespace
		s/\s+$//;				# trailing whitespace
		next unless (/$pattern/io);
		($name,$host,$port) = split;		# found match
		push (@hostport, $host);		# add host to array
		push (@hostport, $port);		# add port to array
	}
	close brokers;
	return (@hostport);				# not found
}


# do_query:

sub do_query {
	local ($S, $bquery) = @_;
	local ($nobjects) = 0;
	local ($nopaquelines) = 0;

	alarm(1600);	# after 30 minutes just kill it, CERN httpd won't do it

	print $S $bquery;
#	@T = (<$S>);
#	close ($S)	|| &fatal ("socket: $!\n");

	$/="\n";

	while (<$S>) {

	    if ($debug) {
		chop;
		print "|$_|\n";
	    }

	    next if (/^200 -/o);

	    # Broker homepage URL
	    if (/^126 - (.*)$/o) {
		$hp_url = $1 if ($hp_url eq '');
		next;
	    }

	    if (/^120 -/o || /^103 -/o || /^111 -/o) {
		$OBJ[++$#OBJ] = $_;
		last if (/^103 -/o || /^111 -/o);
	    } else {
		$OBJ[$#OBJ] .= $_;
	    }
	}
	close ($S) || &fatal ("socket: $!\n");

	$totnumber = (scalar (@OBJ)) - 1;

#----------------------------------------------------------------------
# JMM - 20010605
# We make calculations to obtain the navigator bar
#---------------------------------------------------------------------,
        $rTotHtmlFiles = ceil ($totnumber/$perpage);
        eval $CFG{'CreateNavBars'};
	print &expand ($CFG{'ResultSetBegin'});

	@first_page = &expand ($CFG{'ResultSetBegin'})
	    if $perpage && ! $current_page;
#---------------------------------------------------------------------'

	# @OBJ = sort bynml @OBJ if ($sort eq 'by-NML');
	&rank_objects(@OBJ,@RANK) if ($sort eq 'by-rank');

	while (($curobj || (undef %SOIF,$curobj = shift(@OBJ))) &&
	       (($_, $curobj) = split(/\n/, $curobj, 2))) {

	    # 124 - The description line of the match
	    if (/^124 - (\d+)/o) {
		$n = $1;
		next if ($n == 0);
		$desc = &html_escape (substr($curobj, 0, $n));
		$curobj = substr($curobj, $n);	# delete the data
		next;
	    }

	    # 127 - Attribute request
	    if (/^127 - ([^\s]+) (\d+)/o) {
		$att	= $1;
		$n	= $2;
		next if ($n == 0);
		$SOIF{$att} = &html_escape (substr($curobj, 0, $n));
		$curobj = substr($curobj, $n);	# delete the data
		next;
	    }

	    # 122 - Opaque data
	    if (/^122 - (.*)$/o) {
		$_ = &html_escape ($1);
		eval $CFG{'MatchedLineSub'};
		$opaque .= $_ . "\n" if (/\S/);
		$nopaquelines++;
		next;
	    }

	    # 101 - message to the user
	    if (/^101 - (.*)$/o) {
		$usermsg = $1;
		#print &expand ($CFG{'UserMessage'});
		next;
	    }

	    # 103 - end of broker results
	    # 111 - Error Message that ends Broker Results
	    if (/^103 - (.*)$/o || /^111 - (.*)$/o) {
		print &expand ($CFG{'ResultSetEnd'});
		push(@first_page, &expand ($CFG{'ResultSetEnd'}))
		    if $perpage && ! $current_page;
		$msg = $1;
		if ($msg =~ /PARSE ERROR/o) {
		    print &expand ($CFG{'ParseError'});
		} elsif ($msg =~ /heavily loaded/o) {
		    print &expand ($CFG{'BrokerLoad'});
		} elsif ($msg =~ /(\d+) Returned Object/o) {
#----------------------------------------------------------------------
# JMM - 20010604
# We write the number of objects returned in the ResultsBar
#----------------------------------------------------------------------
			$msg = "";
#----------------------------------------------------------------------
		    $nreturned = $1;
		    print &expand ($CFG{'EndBrokerResults'});
		    print &expand ($CFG{'EmptySetWarning'})
			if ($nreturned == 0);
		    print &expand ($CFG{'TruncateWarning'})
			if ($nopaquelines >= $maxresult);
		} else {
		    print &expand ($CFG{'FailBrokerResults'});
		}
		last;
	    }

	    # 120 - The URL of the match
	    if (/^120 - (.*)$/o) {
		$url = $1;
		$url =~ /^([^:]+):\/*([^\/]+)(.*)$/o;
		$A = $1;
		$H = $2;
		$P = $3;
		@X = split ('/', $P);
		$F = pop (@X);
		$D = join ("/", @X, "");
		$F = $url if ($url =~ /\/$/o);
		if ($A eq 'news') {
		    $F = $H;
		    $H = $P = $D = undef;
		}
		$objectnum = sprintf ($CFG{'ObjectNumPrintf'},
				      ++$nobjects);
		#print &expand ($CFG{'PrintUrl'});
		next;
	    }

	    # content summary URL
	    if (/^125 - (.*)$/o) {
		$cs_url = $1;
		$cs_url =~ /^([^:]+):\/*([^\/]+)(.*)$/o;
		$cs_a = $1;
		$cs_h = $2;
		$cs_p = $3;
		@X    = split ('/', $cs_p);
		$cs_f = pop (@X);
		$cs_d = join ("/", @X, "");
		$cs_f = $cs_url if ($cs_url =~ /\/$/o);
		next;
	    }

	    # 130 - Object Ends, start a new one
	    if (/^130/o) {
#----------------------------------------------------------------------
# JMM - 20010531
# We use the array "aWeight" to mantain the weigth of this object. We
# use it later to draw the balls.
#---------------------------------------------------------------------,
		$rWeight = $raWeight[$rIndex];
		$rIndex++;
#---------------------------------------------------------------------'

		eval $CFG{'PerObjectFunction'}
		if (defined ($CFG{'PerObjectFunction'}));
		$attributes = '';
		foreach $k (sort keys %SOIF) {
		    $att = $k;
		    $val = $SOIF{$k};
		    eval ($CFG{'PerAttributeFunction'});
		    $attributes .= &expand($CFG{'FormatAttribute'})
			if ($att ne ''); # $att may be deleted in search.cf
		}
		print &expand ($CFG{'PrintObject'});
		push(@first_page, &expand ($CFG{'PrintObject'}))
		    if $perpage && ! $current_page;
		&N_at_a_time(1)
		    if $perpage && 0==$nobjects%$perpage && $nobjects>0 && $nobjects != $totnumber;

#----------------------------------------------------------------------
# JMM - 20010531
# We have used $rWeight in $CFG{'PerObjectFunction'} and then we reset
# it
#---------------------------------------------------------------------,
		$rWeight = 0;
#---------------------------------------------------------------------'

		$opaque = "";
		$url	= "";
		$cs_url = "";
		$desc	= "";
		%SOIF	= ();
		next;
	    }
	}
	&N_at_a_time(0) if $perpage;
}

sub fatal {
	local ($key) = shift;
	local ($msg) = defined ($CFG{$key}) ? &expand ($CFG{$key}) : $key;
	print STDOUT "$msg";
	if (open(BQLOG, ">>$BQLOG")) {
		my $now = localtime;
		printf BQLOG ("[%s] %s: %s", $now, $0, $msg);
		close BQLOG;
	}
	exit(1);
}

# Perform simple variable substitution.  See Wall & Schwartz
# 'Programming Perl' book, p 217.
#
sub expand2 {
	$_ = shift;
	s/"/\\"/g;
	eval qq/"$_"/;
}

# Gross regexp's to do some ifdef-type substitutions
# Jonathan Rochkind, jrochkin@cs.oberlin.edu, 21 March 1996.
#
# Use:
#       <?foo>abcxyz</?foo>     becomes       abcxyz
#       <?>abcxyz</?>           is deleted
#
# so the user can conditionally include a section of text by
# enclosing it in <?$var>...</?$var>.  The section will be
# included if $var is not the null string.  If a newline
# follows </?> the newline is removed.
#
sub expand {
	$_ = &expand2 (shift);
	# First get rid of everything of the form "<?>Some Stuff</?>"
	local($begin) = 0;
	local($end) = 0;
	while ($begin != -1) {           # While there is still a <?>
	    $begin=index($_,'<?>');      # Find it's location.
	    unless ($begin == -1) {      # As long as we did find it....
	             # Find it's paired </?>
	        $end=index($_,'</?>',$begin)+4;
	             # Include the following \n too, if there...
	        if (substr($_,$end,1) eq "\n") { ++$end; }
	             # Now delete the whole "<?> ... </?>"
	        substr($_,$begin,$end-$begin) = "";
	    }
	}
	# Now just delete _all_ tags of the form <?x>, </?x>
	# Don't even bother matching them up in pairs,
	#     just delete them where you see em.
	s/<\?[^>]+>//g;     # delete all <?x>
	s/<\/\?[^>]+>//g;   # delete all </?x>
	s/\n\n*/\n/g;
	$_;
}



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;
	s/"/\&#34;/g;
	$_;
}


sub parse_config {
	local ($CF)	= shift;
	local ($out)	= 1;
	undef (local ($key));
	undef (local ($val));

	open (CF) || &fatal ("$CF: $!\n");

	while (<CF>) {
		next if (/^#/o);
		if ($out && /<(\w+)>/o) {
			$key = $1;
			$val = "";
			$out = 0;
			next;
		}
		if (!$out && /<\/$key>/) {
			#eval ("\$$key=$val");
			print "setting $key...\n" if ($debug);
			#print "to $val\n";
			chop ($CFG{$key} = $val);
			undef ($val);
			undef ($key);
			$out = 1;
			next;
		}
		chop, chop if (/[^\\]\\$/o);	# chop newline if esc'd
		$val .= $_ if (!$out && defined ($val));
	}
	close CF;
	1;
}

sub client_socket {
	local ($host, $port) = @_;
	local ($sockaddr) = 'S n a4 x8';
	local ($name, $aliases, $proto) = getprotobyname('tcp');
	local ($connected) = 0;

	# Lookup addresses for remote hostname
	#
	local($w,$x,$y,$z,@thataddrs) = gethostbyname($host);
	&fatal("Unknown Host: $host\n") unless (@thataddrs);

	# bind local socket to INADDR_ANY
	#
	local ($thissock) = pack($sockaddr, &AF_INET, 0, "\0\0\0\0");
	&fatal("socket: $!\n") unless
		socket (SOCK, &AF_INET, &SOCK_STREAM, $proto);
	&fatal("bind: $!\n") unless
		bind (SOCK, $thissock);

	# Try all addresses
	#
	foreach $thataddr (@thataddrs) {
		local ($that) = pack($sockaddr, &AF_INET, $port, $thataddr);
		@IP = unpack('C4', $thataddr);
		printf ("Trying connection to %d.%d.%d.%d<BR>\n", @IP)
			if ($debug);
		if (connect (SOCK, $that)) {
			$connected = 1;
			printf ("Connected to %d.%d.%d.%d!<BR>\n", @IP)
				if ($debug);
			last;
		}
	}
	return () unless ($connected);

	# Set socket to flush-after-write and return it
	#
	select (SOCK); $| = 1;
	select (STDOUT);
	return (SOCK);
}

sub sigharddie {
	kill ('KILL', $$);
}

sub sigdie {
	local ($sig) = @_;
	&fatal ('sigdie');
}

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

sub broker_down {
	local($host, $port) = @_;
	print STDOUT <<EOM;
<p>
Sorry, but the Broker on
<STRONG>$host, port $port</STRONG>
is currently unavailable.  Please try again later.
<p>
EOM
	&fatal("$host:$port: $!\n");
}

sub not_configured {
	print <<"EOM";
Content-type: text/html

<html>
<head>
<TITLE>$0 not properly installed</TITLE>
</head>
<body>
<STRONG>WARNING:</STRONG> You have not installed the WWW interface
to the Harvest Broker correctly.  The \$HARVEST_HOME directory
<PRE>        <STRONG>$ENV{'HARVEST_HOME'}</STRONG></PRE> does not exist.
<P>
Please refer to the current
<A HREF="http://harvest.sourceforge.net/harvest/doc/html/manual.html">Harvest
User's Manual</A>.
</body>
</html>
EOM
	exit 0;
}

# Read defaults from .cf

sub parse_defaults {
   local($attr,$value);
   local(@vars)=split(/\n/,$CFG{'Default'});
   while (@vars) {
	($attr,$value)=split(/:/,shift(@vars));
	$attr=~s/\s//g;
	$value=~s/^\s*//;
	$DEF{$attr}=$value;
   }
}

sub option {
   local($attr)=@_[0];
   return (defined $RQ{$attr}) ? $RQ{$attr} : $DEF{$attr};
}

######################################################################
# 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'};
    }

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

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 '' && ($#_ >= 0)) {
	$v=shift @_;
	$Y{$k} = defined $Y{$k} ? join (' ', $Y{$k}, $v) : $v;
    }
    %Y;
}

# sort the objects by number of matched lines
#
#sub bynml {
#	split(/\n/, $b) <=> split(/\n/, $a);	# number of lines in object
#}

# sort the objects by "rank". This is based on code from Wesley Alan Wright

sub rank_objects {
    local (@objects) = @_;
    local ($objnum) = 0;
    local (%ratings);
    local (@object_index);
    foreach $object (@objects) {
	$rank = 1;
	$lastline = ""; # hw - don't count repeated lines...
	split(/\n/,$object);
	foreach $line (@_) {

	    # $rawline=$line;

	    $line =~ s/\s{2,}/ /g;                # Remove multiple whitespaces
	    $line =~ s/(Matched line: )(.*)$/$2/;
	    $line =~ s/^(.*)\{(\d+)\}(.*)$/$1$3/; # Remove "{12}:" etc.

	    # if (open(BQLOG, ">>$BQLOG")) {
	    #	printf BQLOG ($rawline."\n");
	    #	printf BQLOG ($line."\n");
	    #	printf BQLOG ($rank."\n");
	    #	close BQLOG;
	    # }

	    if ($line ne $lastline) {

#----------------------------------------------------------------------
# JMM - 20010529
# We consider some metadata in Dublin Core format the most important
#---------------------------------------------------------------------,
		$rank = $rank + 10000 - length($line)
		   if (index($line,"dc.subject#") > 0);

		$rank = $rank + 5000 - length($line)
	      	   if (index($line,"dc.title#") > 0);

		$rank = $rank + 1000 - length($line)
		   if (index($line,"dc.description#") > 0);

		$rank = $rank + 500 - length($line)
	      	   if (index($line,"dc.creator#") > 0);

		$rank = $rank + 100 - length($line)
	      	   if (index($line,"dc.publisher#") > 0);

		$rank = $rank + 100 - length($line)
		   if (index($line,"dc.language#") > 0);
#---------------------------------------------------------------------'

		#title is most important
		$rank += 600 - length($line)*3
		    if (index($line,"title#") > 0 && length($line) < 200);

		#url is also important
		$rank += 150 - length($line)/1.5
		    if (index($line,"url#") > 0 && length($line) < 200);

		#there are some very long headings...
		$rank += 110 - length($line)/2
		    if (index($line,"headings#") > 0 && length($line)<200);

		# used for PDF, PS etc.
		$rank += 80 - length($line)/3
		    if (index($line,"description#") > 0 && length($line)<200);

		$rank += 60 if (index($line,"subject#") > 0);
		$rank += 30 if (index($line,"images#") > 0);

		# these are sometimes too long.
		$rank += 25 - length($line)/8
		    if (index($line,"url-references#") > 0 );

		# somehow redundant, not as important as it may seem...
		$rank += 20 if (index($line,"keywords#") > 0);

		$rank += 10 if (index($line,"body#") > 0);

		# Consider length of URL of every Page
		$rank += 400 - length($line)*2
		    if (index($line,"120 - ") == 0 && length($line) < 200);
	    }
	    $lastline = $line;
	}
	$ratings{$objnum} = $rank;
	$object_index[$objnum] = $objnum;
	$objnum++;
    }
#   pop off the "126" and "103" results (I hope they're at the end!)
    pop(@object_index);
    pop(@object_index);
    @sorted_index= sort byrate @object_index;
    $objnum=0;

#----------------------------------------------------------------------
# JMM - 20010605
# The first element has the higher weight. We need it to calculate
# the number of balls to show with an resource.
#---------------------------------------------------------------------,
    $rGreaterWeight = $ratings{$sorted_index[0]};
#---------------------------------------------------------------------'

    foreach $index (@sorted_index) {
	$OBJ[$objnum] = $objects[$index];
#----------------------------------------------------------------------
# JMM - 20010529
# We save the weight of each object.
#---------------------------------------------------------------------,
	$raWeight[$objnum] = $ratings{$index};
#---------------------------------------------------------------------'
	$objnum++;
    }
}

sub byrate {
    $ratings{$b} <=> $ratings{$a};
}


# translate SGML entities
# produced from
# perl -ne 'if (/^ *<.ENTITY *([\S]*) *CDATA *"&#([\d]+);".*>/)
#              { if ($2 <0x100) {printf "s/&$1;/\\x%x/g;\n", $2;}
# 		 else {printf "s/&$1;/\\\\#$2/g;\n";}}'

sub entities {
    $_ = $_[0];

    # ISO Latin 1
s/&nbsp;/\xa0/g;
s/&iexcl;/\xa1/g;
s/&cent;/\xa2/g;
s/&pound;/\xa3/g;
s/&curren;/\xa4/g;
s/&yen;/\xa5/g;
s/&brvbar;/\xa6/g;
s/&sect;/\xa7/g;
s/&uml;/\xa8/g;
s/&copy;/\xa9/g;
s/&ordf;/\xaa/g;
s/&laquo;/\xab/g;
s/&not;/\xac/g;
s/&shy;/\xad/g;
s/&reg;/\xae/g;
s/&macr;/\xaf/g;
s/&deg;/\xb0/g;
s/&plusmn;/\xb1/g;
s/&sup2;/\xb2/g;
s/&sup3;/\xb3/g;
s/&acute;/\xb4/g;
s/&micro;/\xb5/g;
s/&para;/\xb6/g;
s/&middot;/\xb7/g;
s/&cedil;/\xb8/g;
s/&sup1;/\xb9/g;
s/&ordm;/\xba/g;
s/&raquo;/\xbb/g;
s/&frac14;/\xbc/g;
s/&frac12;/\xbd/g;
s/&frac34;/\xbe/g;
s/&iquest;/\xbf/g;
s/&Agrave;/\xc0/g;
s/&Aacute;/\xc1/g;
s/&Acirc;/\xc2/g;
s/&Atilde;/\xc3/g;
s/&Auml;/\xc4/g;
s/&Aring;/\xc5/g;
s/&AElig;/\xc6/g;
s/&Ccedil;/\xc7/g;
s/&Egrave;/\xc8/g;
s/&Eacute;/\xc9/g;
s/&Ecirc;/\xca/g;
s/&Euml;/\xcb/g;
s/&Igrave;/\xcc/g;
s/&Iacute;/\xcd/g;
s/&Icirc;/\xce/g;
s/&Iuml;/\xcf/g;
s/&ETH;/\xd0/g;
s/&Ntilde;/\xd1/g;
s/&Ograve;/\xd2/g;
s/&Oacute;/\xd3/g;
s/&Ocirc;/\xd4/g;
s/&Otilde;/\xd5/g;
s/&Ouml;/\xd6/g;
s/&times;/\xd7/g;
s/&Oslash;/\xd8/g;
s/&Ugrave;/\xd9/g;
s/&Uacute;/\xda/g;
s/&Ucirc;/\xdb/g;
s/&Uuml;/\xdc/g;
s/&Yacute;/\xdd/g;
s/&THORN;/\xde/g;
s/&szlig;/\xdf/g;
s/&agrave;/\xe0/g;
s/&aacute;/\xe1/g;
s/&acirc;/\xe2/g;
s/&atilde;/\xe3/g;
s/&auml;/\xe4/g;
s/&aring;/\xe5/g;
s/&aelig;/\xe6/g;
s/&ccedil;/\xe7/g;
s/&egrave;/\xe8/g;
s/&eacute;/\xe9/g;
s/&ecirc;/\xea/g;
s/&euml;/\xeb/g;
s/&igrave;/\xec/g;
s/&iacute;/\xed/g;
s/&icirc;/\xee/g;
s/&iuml;/\xef/g;
s/&eth;/\xf0/g;
s/&ntilde;/\xf1/g;
s/&ograve;/\xf2/g;
s/&oacute;/\xf3/g;
s/&ocirc;/\xf4/g;
s/&otilde;/\xf5/g;
s/&ouml;/\xf6/g;
s/&divide;/\xf7/g;
s/&oslash;/\xf8/g;
s/&ugrave;/\xf9/g;
s/&uacute;/\xfa/g;
s/&ucirc;/\xfb/g;
s/&uuml;/\xfc/g;
s/&yacute;/\xfd/g;
s/&thorn;/\xfe/g;
s/&yuml;/\xff/g;

    # Cougar HTMLsym
s/&fnof;/\\#402/g;
s/&Alpha;/\\#913/g;
s/&Beta;/\\#914/g;
s/&Gamma;/\\#915/g;
s/&Delta;/\\#916/g;
s/&Epsilon;/\\#917/g;
s/&Zeta;/\\#918/g;
s/&Eta;/\\#919/g;
s/&Theta;/\\#920/g;
s/&Iota;/\\#921/g;
s/&Kappa;/\\#922/g;
s/&Lambda;/\\#923/g;
s/&Mu;/\\#924/g;
s/&Nu;/\\#925/g;
s/&Xi;/\\#926/g;
s/&Omicron;/\\#927/g;
s/&Pi;/\\#928/g;
s/&Rho;/\\#929/g;
s/&Sigma;/\\#931/g;
s/&Tau;/\\#932/g;
s/&Upsilon;/\\#933/g;
s/&Phi;/\\#934/g;
s/&Chi;/\\#935/g;
s/&Psi;/\\#936/g;
s/&Omega;/\\#937/g;
s/&alpha;/\\#945/g;
s/&beta;/\\#946/g;
s/&gamma;/\\#947/g;
s/&delta;/\\#948/g;
s/&epsilon;/\\#949/g;
s/&zeta;/\\#950/g;
s/&eta;/\\#951/g;
s/&theta;/\\#952/g;
s/&iota;/\\#953/g;
s/&kappa;/\\#954/g;
s/&lambda;/\\#955/g;
s/&mu;/\\#956/g;
s/&nu;/\\#957/g;
s/&xi;/\\#958/g;
s/&omicron;/\\#959/g;
s/&pi;/\\#960/g;
s/&rho;/\\#961/g;
s/&sigmaf;/\\#962/g;
s/&sigma;/\\#963/g;
s/&tau;/\\#964/g;
s/&upsilon;/\\#965/g;
s/&phi;/\\#966/g;
s/&chi;/\\#967/g;
s/&psi;/\\#968/g;
s/&omega;/\\#969/g;
s/&thetasym;/\\#977/g;
s/&upsih;/\\#978/g;
s/&piv;/\\#982/g;
s/&bull;/\\#8226/g;
s/&hellip;/\\#8230/g;
s/&prime;/\\#8242/g;
s/&Prime;/\\#8243/g;
s/&oline;/\\#8254/g;
s/&frasl;/\\#8260/g;
s/&weierp;/\\#8472/g;
s/&image;/\\#8465/g;
s/&real;/\\#8476/g;
s/&trade;/\\#8482/g;
s/&alefsym;/\\#8501/g;
s/&larr;/\\#8592/g;
s/&uarr;/\\#8593/g;
s/&rarr;/\\#8594/g;
s/&darr;/\\#8595/g;
s/&harr;/\\#8596/g;
s/&crarr;/\\#8629/g;
s/&lArr;/\\#8656/g;
s/&uArr;/\\#8657/g;
s/&rArr;/\\#8658/g;
s/&dArr;/\\#8659/g;
s/&hArr;/\\#8660/g;
s/&forall;/\\#8704/g;
s/&part;/\\#8706/g;
s/&exist;/\\#8707/g;
s/&empty;/\\#8709/g;
s/&nabla;/\\#8711/g;
s/&isin;/\\#8712/g;
s/&notin;/\\#8713/g;
s/&ni;/\\#8715/g;
s/&prod;/\\#8719/g;
s/&sum;/\\#8721/g;
s/&minus;/\\#8722/g;
s/&lowast;/\\#8727/g;
s/&radic;/\\#8730/g;
s/&prop;/\\#8733/g;
s/&infin;/\\#8734/g;
s/&ang;/\\#8736/g;
s/&and;/\\#8869/g;
s/&or;/\\#8870/g;
s/&cap;/\\#8745/g;
s/&cup;/\\#8746/g;
s/&int;/\\#8747/g;
s/&there4;/\\#8756/g;
s/&sim;/\\#8764/g;
s/&cong;/\\#8773/g;
s/&asymp;/\\#8776/g;
s/&ne;/\\#8800/g;
s/&equiv;/\\#8801/g;
s/&le;/\\#8804/g;
s/&ge;/\\#8805/g;
s/&sub;/\\#8834/g;
s/&sup;/\\#8835/g;
s/&nsub;/\\#8836/g;
s/&sube;/\\#8838/g;
s/&supe;/\\#8839/g;
s/&oplus;/\\#8853/g;
s/&otimes;/\\#8855/g;
s/&perp;/\\#8869/g;
s/&sdot;/\\#8901/g;
s/&lceil;/\\#8968/g;
s/&rceil;/\\#8969/g;
s/&lfloor;/\\#8970/g;
s/&rfloor;/\\#8971/g;
s/&lang;/\\#9001/g;
s/&rang;/\\#9002/g;
s/&loz;/\\#9674/g;
s/&spades;/\\#9824/g;
s/&clubs;/\\#9827/g;
s/&hearts;/\\#9829/g;
s/&diams;/\\#9830/g;

    # Cougar HTMLmisc
s/&quot;/\x22/g;
s/&amp;/\x26/g;
s/&lt;/\x3c/g;
s/&gt;/\x3e/g;
s/&OElig;/\\#338/g;
s/&oelig;/\\#339/g;
s/&Scaron;/\\#352/g;
s/&scaron;/\\#353/g;
s/&Yuml;/\\#376/g;
s/&circ;/\\#710/g;
s/&tilde;/\\#732/g;
s/&ensp;/\\#8194/g;
s/&emsp;/\\#8195/g;
s/&thinsp;/\\#8201/g;
s/&zwnj;/\\#8204/g;
s/&zwj;/\\#8205/g;
s/&lrm;/\\#8206/g;
s/&rlm;/\\#8207/g;
s/&ndash;/\\#8211/g;
s/&mdash;/\\#8212/g;
s/&lsquo;/\\#8216/g;
s/&rsquo;/\\#8217/g;
s/&sbquo;/\\#8218/g;
s/&ldquo;/\\#8220/g;
s/&rdquo;/\\#8221/g;
s/&bdquo;/\\#8222/g;
s/&dagger;/\\#8224/g;
s/&Dagger;/\\#8225/g;
s/&permil;/\\#8240/g;
s/&lsaquo;/\\#8249/g;
s/&rsaquo;/\\#8250/g;

    return($_);
}

# David Hoekman  Oct 1, 1997
# Split search results into segments, 'n' results at a time.  The value of
# 'n' is set by the $perpage variable, which is defined via the 'perpageflag'
# query option.  Each segment is written to a separate temporary file; the
# location of these files must be configured locally.  This routine also
# removes old temporary files, when they are older than a certain age.
#
sub N_at_a_time {

	local($more) = @_;
	local($previous_page, $next_page);
	local($tmp_prefix) = "$^T-${$}";	# prefix for temporary files

	# if this is the last page of results, remove old temporary files
	# (if $expire=3, then 3/24 sets a 3 hour expiration cycle)
	unless ($more) {
		chdir "$tmp_dir";
		foreach $file (<[1-9]*-[1-9]*-[1-9]*\.html>) {
			unlink "$file" if -M $file > $expire/24;
		}
	}

	# write stored 'first' page (duplicates data sent to STDOUT/browser)
	if (! $current_page) {
		$current_page = 1;
		open(TEMP,">$tmp_dir/$tmp_prefix-1.html") ||
			&fatal("<b>Error: cannot write temporary files at '$tmp_dir'!</b>");
		print TEMP "<html>\n";
		print TEMP &expand ($CFG{'ResultHeader'});
		print TEMP @first_page;
		print TEMP &expand ($CFG{'ResultSetEnd'});

#----------------------------------------------------------------------
# JMM - 20010531
# We change this lines to print the navigation bar $rNavigationBar (we
# constructed it when we evaluated $CFG{'CreateNavBars'})
#---------------------------------------------------------------------,
#		print TEMP qq{<BR>Total: $totnumber} if ($more && defined $sort);
		print TEMP "<p>\n<center>";
#		print TEMP qq{[<a href="/$tmp_www/$tmp_prefix-2.html">Next</a>]}
#			if $totnumber > $nobjects;
#		print TEMP qq{[<a href="$hp_url">New Search</a>]}
#			if $hp_url ne '';
##        	print TEMP "$rNavigationBar";
#---------------------------------------------------------------------'

                print TEMP "<p>\n</center>";

#----------------------------------------------------------------------
# JMM - 20010531
# We use $CFG{'ResultTrailer'} to finish the page
#---------------------------------------------------------------------,
#		print TEMP "</body></html>\n";
		print TEMP &expand ($CFG{'ResultTrailer'});
#---------------------------------------------------------------------'
		undef @first_page;
	}

	# finish off current page
	print &expand ($CFG{'ResultSetEnd'}) if $more;
	$previous_page = $current_page - 1; $next_page = $current_page + 1;
#----------------------------------------------------------------------
# JMM - 20010531
# We print the total later
#---------------------------------------------------------------------,
#	print qq{<BR>Total: $totnumber} if ($more && defined $sort);
#	print "<p>\n<center>";
#---------------------------------------------------------------------'

#----------------------------------------------------------------------
# JMM - 20010531
# We print the navigation bar
#---------------------------------------------------------------------,
#	print qq{[<a href="/$tmp_www/$tmp_prefix-$previous_page.html">Previous</a>]}
#		if $previous_page > 0;
#	print qq{[<a href="/$tmp_www/$tmp_prefix-$next_page.html">Next</a>]}
#		if $totnumber > $nobjects;
#	print qq{[<a href="$hp_url">New Search</a>]} if $hp_url ne '';
#	print "</center>\n";
#---------------------------------------------------------------------'

	print &expand ($CFG{'ResultTrailer'});

#----------------------------------------------------------------------
# JMM - 20010531
# We use $CFG{'ResultTrailer'} to finish the page
#---------------------------------------------------------------------,
#	print "</body>\n</html>\n";
#---------------------------------------------------------------------'
	return unless $more; # stop here if no more results!

	# increment page counter, open next results page
	$current_page++;
	close(TEMP);
	open(TEMP,">$tmp_dir/$tmp_prefix-$current_page.html") ||
		&fatal("<b>Error: cannot write temporary files at '$tmp_dir'!</b>");
	select(TEMP);

	# print beginning of next page
	print &expand ($CFG{'ResultHeader'});
	eval ($CFG{'CreateNavBars'});
	print &expand ($CFG{'ResultSetBegin'});
}

sub ceil {
	my $x = shift;
	$x += 1.0 unless ($x == int($x));
	return int($x);
}