#!/usr/local/bin/perl
# ice-form.pl -- cgi compliant ICE search interface
#
# ICE Version 1.5 beta 3 rev2
# March 2000
# (C) Christian Neuss / fax (425) 732-7343
#--- start of configuration --- put your changes here ---
# Title or name of your server:
# Example: local($title)="Search this server";
local($title)="Wild Boar Search Engine";
# search directories to present in the search dialogue
# Example:
# local(@directories)=(
# "DZSIM (/www/projects/dzsim)",
# "CSCW Laboratory (/www/projects/cscw-lab)",
# );
# local(@directories)=(
# "Next (/NextLibrary)",
# "WISE (/www/projects/wise)",
# "Multimedia Survey (/www/projects/mms)",
# "DZSIM (/www/projects/dzsim)",
# "CSCW Laboratory (/www/projects/cscw-lab)",
# "WWW-Schulung (/www/igd-a3/schulung)",
# );
# Location of the indexfile:
# Note: under Windows or Windows NT, add the drive letter
# Example: $indexfile='/usr/local/etc/httpd/index/index.idx';
$indexfile='/www/htdocs/domains/domain3/00095/www.wildboar.net/webdocs/cgi/ice/ice1-5/index.idx';
# Location of the thesaurus data file:
# Example: $thesfile='/igd/a3/home1/neuss/Perl/thes.dat';
# $thesfile='/igd/a3/home1/neuss/Perl/thes.dat';
$thesfile='/www/htdocs/domains/domain3/00095/www.wildboar.net/webdocs/cgi/ice/thes.dat';
# Document Root and Aliases for your server. The Document Root is
# the directory where the "top level" documents reside. Additional
# mappings can be set via the "Aliases" variable (which can be left
# empty if no additional mappings exist).
#
# Important hint: if you are unsure about how to set $docroot,
# look at the end of the index file. $docroot must be set so
# that it matches the paths found there.
#
# Example
# $docroot = '/usr3/webstuff/documents';
# %aliases = (
# '/projects', '/usr/stud/proj',
# '/people', '/usr3/webstuff/staff',
# );
#
$docroot = '/www/htdocs/domains/domain3/00095/www.wildboar.net/webdocs';
%aliases = (
);
# The following configuration settings are OPTIONAL
#
# you can localize the BODY tag, if you want. Use an absolute
# path such as the one given in the example if linking to a
# background image.
# Example:
# $BODY = '';
# Maximum number of hits to return
# Example:
# $MAXHITS=100;
$MAXHITS=50;
# Minimum length of word to be indexed (same as in ice-idx.pl)
# Example:
# $MINLEN=3;
$MINLEN=3;
#--- end of configuration --- you don't have to change anything below ---
local(@errStack);
# do the real work, but trap any errors
eval '&main';
# if an error has occured, log it to stdout
if($@){
&send_header("Error in Script"); # just in case
print "$@\n
";
}
# main loop
sub main {
# if this script is called up "by hand", run a test
unless($ENV{"SCRIPT_NAME"}){
if($ARGV[0] eq "-i"){
print &buildIndex();
}
local($word) = ($#ARGV==-1) ? "test" : join(" ",@ARGV) ;
print &performQuery($word);
return;
}
# if content_length is zero and query string is empty
if (($ENV{CONTENT_LENGTH}==0) &&
(length($ENV{"QUERY_STRING"})==0)){
# we're not decoding a form yet => send the form
&send_header("$title");
&send_index();
&send_trailer();
return;
}
# else: request from the web
%forms=&cgiparse();
if($forms{"BUILDINDEX"}){
&send_header("Site Index");
print &buildIndex();
&send_trailer();
return;
}
&send_header("Query Result");
print &performQuery($forms{KEYWORDS});
print "";
&send_index();
&send_trailer();
return;
}
sub performQuery {
local($query) = @_;
# remove non-word characters
$query = &html2text($query);
$query =~ tr/\(\)a-zA-Z0-9\-\xc0-\xff/ /cs;
$rawquery=$query;
$query =~ tr/a-zA-Z0-9\-\xc0-\xff/ /cs;
# remove leading and trailing whitespace
$query =~ s/^\s*(.*\S)\s*/$1/;
$pquery = $query;
$context = $forms{CONTEXT};
if($context =~ m:\(([^)]*)\):) {
$context=$1;
}else{
$context="";
}
$thesaurus = $forms{THESAURUS};
$substring = $forms{SUBSTRING};
$days = $forms{DAYS};
if(length($days)>0){ $pquery.=" -D $days"; }
if(length($thesaurus)>0){ $pquery.=" -T"; }
if(length($substring)>0){ $pquery.=" -S"; }
if(length($context)>0){ $pquery.=" @ $context"; }
# PJ: maybe optimize: if($#keywords>=0){
# compile the original query string into perl
# and store name in $match
$sub = 0; # get rid of warning
($match, $err, $sub)=&compilequery($rawquery);
sub downbynumber {$b <=> $a;}
local(@results) = sort downbynumber &getindex($pquery);
# problems?
return join(" ",@errStack) if(@errStack);
local($text,$hits);
foreach $w (@results){
$text .= "
".htmlForFile(split(/\n/,$w));
if (++$hits > $MAXHITS) {
return "$text
More than $MAXHITS hits. Use a more restrictive search
";
}
}
return "no matches found." unless ($text);
return "$text\n";
}
# configure this to build the HTML text entry for each file
sub htmlForFile {
local($freq,$file,$title,$time,@hits)=split(/\n/,$w);
local($url) = &translateback($file);
if(length($title)==0){
$title = $file;
$title =~ s|.*/(.*/.*)$|$1|g;
}
local($result) = " $title ";
$result .= join(" ","$time",@hits);
$result;
}
# print the CGI script header
sub send_header {
local($title)=@_;
print "Content-type: text/html\n\n";
print "\n", $title,"\n\n";
print $BODY? $BODY: "";
print "
$title
\n";
}
sub send_trailer {
print "";
}
# display the Forms interface
## PJ sollte extern gesetzt werden koennen. Muss hier gesetzt
## werden, falls das Form auch in den Results wieder gezeigt
## werden soll, da dann der workaround mit externem form
## nicht klappt.
sub send_index {
local($scriptname) = $ENV{"SCRIPT_NAME"};
print "Use the form below to specify your search, or consult the ";
print "site index";
print "
This searchable archive was implemented with the
ICE search engine (boolean patch pj9711)
END
}
# parse data from CGI request and store it as name/value pairs
sub cgiparse {
if ($ENV{'REQUEST_METHOD'} eq "POST") {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
} else {
$buffer = $ENV{'QUERY_STRING'};
}
local(@query_strings) = split("&", $buffer);
foreach $q (@query_strings) {
$q =~ s/\+/ /g;
($attr, $val) = split("=", $q);
$val =~ s/%/\n%/g;
local($tmpval);
foreach (split("\n",$val)){
if(m:%(\w\w):){
local($binval) = hex($1);
if(($binval>0)&&($binval<256)){
local($htmlval) = pack("C",$binval);
s/%$1/$htmlval/;
}
}
$tmpval .= $_;
}
$forms{$attr} = $tmpval;
}
%forms;
}
# parse query
sub parsequery{
local($query)=@_;
local($context,$thesaurus,$substr);
# preprocess whitespace and discard spaces after @ and -D
$query =~ tr/ \t/ /s;
$query =~ s/@ /@/g;
$query =~ s/-D /-D/g;
$query =~ s/^-D/ -D/g;
$_=$query;
# "optional URL context as @-sign"
if(m:^([^@]*)\s+@(.*)$:){
$context=$2;
$_=$1;
}
while(m:\s+-[SDT]\d*$:){
# "turn on "global" thesaurus" by adding -T"
if(m:^(.*)\s+-T$:){
$thesaurus="y";
# print "turn on thesaurus\n";
$_=$1;
}
# "turn on matching substrings by adding -S"
if(m:^(.*)\s+-S$:){
$substr="y";
# print "turn on substring matching\n";
$_=$1;
}
# "turn on modified since n days" by adding -D"
if(m:^(.*)\s+-D(\d+)$:){
$days=$2;
# print "turn on modified since $days\n";
$_=$1;
}
}
@list=split(/ /,$_);
$expectword="y" unless($days && $#list==-1);
foreach $w (@list){
$_ = $w;
tr/A-Z/a-z/;
if(/^and$/) {
if($expectword) {$err="$w"; last;}
$expectword="y";
$bool .= "&";
}elsif(/^or$/){
if($expectword) {$err="$w"; last;}
$expectword="y";
$bool .= "+";
}else{
unless($expectword) {
$bool .= "&";
}
$expectword="";
push(@querystring,$w);
}
}
if($expectword){
push(@errStack,"syntax error in query: must end with searchword!");
return;
}
if($err){
push(@errStack,"syntax error in query near '$err'!");
return;
}
return($context,$thesaurus,$substr,$bool,$days,@querystring);
}
# get index entries matching query
sub getindex{
local($context,$thes,$substr,$bool,$days,@query) = &parsequery(@_);
return if(@errStack);
local(@list,$count,$item,$w,@wordnum,$grepexpr);
local($limit,@allids,@keywords);
if($days){
$limit=time()-(60*60*24*$days) unless($days==0);
}
foreach $item (@query){
++$count;
local($w);
$_=$item;
local($thesflag)=$thes;
if (/{(.*)}/) {
$_ = $1;
$thesflag="y";
}
# convert e.g. "Picture" to "picture"
if(/^[A-Z][^A-Z]*$/){
tr/A-Z/a-z/;
}
# evaluate thesaurus
if ($thesflag && length($thesfile)>0) {
$wordnum{$_}=$count;
local(@synonyms)=split(/\n/,&thesread($thesfile,$_));
foreach $w (@synonyms){
push (@keywords,$w);
$wordnum{$w}=$count;
}
}
if(length($_)<$MINLEN) {
print "ignored: $_ (too short)