home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.sunet.sepub/pictures
/
2014.11.ftp.sunet.se-pictures.tar
/
ftp.sunet.se
/
pub
/
pictures
/
ACiD-artpacks
/
www
/
mirrors
/
acheron
/
cgi-bin
/
discus
/
board-search.cgi
< prev
next >
Wrap
Text File
|
1999-01-26
|
12KB
|
391 lines
#!/usr/bin/perl
$discus_conf = '/usr/local/www/www.acheron.org/discus_admin_245059122/discus.conf';
#Discus board search script
#-------------------------------------------------------------------------------
# This script is copyright (c) 1998 by DiscusWare, LLC, all rights reserved.
# Its use is subject to the license agreement that can be found at the following
# URL: http://www.chem.hope.edu/discus/license
#-------------------------------------------------------------------------------
# To enable multiple selection of topics, you can enable one of
# the following two options. However, this makes the interface
# look not-so-good.
# $multiple = "MULTIPLE SIZE=1";
# $multiple = "MULTIPLE";
#------------------------------------------------------------------------------
if (open (FILE, "$discus_conf")) {
@file = <FILE>;
close (FILE);
$evals = "";
foreach $line (@file) {
if ($line =~ /^(\w+)=(.*)/) {
$varname = $1;
$value = $2;
$value =~ s/'/\\'/g; $value =~ s/\r//g;
$evals .= "\$$varname='$value'; ";
}
}
eval($evals);
require "$admin_dir/source/src-board-subs-common";
} else {
print "Content-type: text/html\n\n";
print "<HTML><HEAD><TITLE>Script Execution Error</TITLE></HEAD>\n";
print "<BODY BGCOLOR=#ffffff TEXT=#000000>\n";
print "<H1>Script Execution Error</H1>\n";
print "Discus scripts could not execute because the discus.conf file\n";
print "could not be opened.";
print "<P>Reason: <FONT COLOR=#ff0000><B>$!</B></FONT>" if $!;
print "<P>This generally indicates a setup error of some kind.\n";
print "Consult the <A HREF=\"http://www.chem.hope.edu/discus/rc\">Discus ";
print "Resource Center</A> for troubleshooting information.</BODY></HTML>\n";
exit(0);
}
&parse_form;
&read_cookie;
if ($FORM{'query'} eq "") {
($bg, $tx, $li, $vl, $al, $face, $size, $image) = &ex('extract_colorsonly', 1);
$str = "$L{BSCH_TITLE}";
open (TOPIC, "$message_dir/board-topics.html");
@topic = <TOPIC>;
close (TOPIC);
$optionstring = "";
foreach $line (@topic) {
if ($line =~ /<!-Top: (\d+)-!>/) {
$num = $1;
&extract ("//$num/$num.$ext");
if (-e "$message_dir/$num") {
$optionstring .= "<OPTION VALUE=\"$me_number\">$me_name\n";
} else {
@auth = &ex('validate_auths', $num);
$optionstring .= "<OPTION VALUE=\"$me_number\">$me_name\n" if grep(/^$num$/, @auth);
}
}
}
&header;
&ex('printuntil', 1, 1, 0, "$L{BSCH_TITLE}");
print <<EOFILE;
<FONT SIZE=4><CENTER><B>$L{BSCH_TITLE}</B></CENTER></FONT>
<HR>
<FORM ACTION="$script_url/board-search.$cgi_extension" METHOD=POST>
$L{BSCH_INSTR}<P>
<TABLE>
<TR>
<TD><FONT FACE="$face" SIZE="$size"><B>$L{BSCH_SEARCHFOR}</B></FONT></TD>
<TD><INPUT SIZE=35 NAME=query TYPE=TEXT></TD>
</TR>
<TR>
<TD><FONT FACE="$face" SIZE="$size"><B>$L{BSCH_TOPICS}</B></FONT></TD>
<TD><SELECT NAME=searchwhere $multiple>
EOFILE
print "<OPTION VALUE=ALL>$L{BSCH_ALLTOPICS}\n";
if ($pro) {
&ex('get_preferences', 1);
if ($PREF{'favorites'} ne "") {
print "<OPTION VALUE=\"$PREF{'favorites'}\" SELECTED>$L{MY_FAVORITES}\n";
}
}
print $optionstring;
print "</SELECT></TD></TR>\n";
print <<EOFORM;
<TR>
<TD><FONT FACE="$face" SIZE="$size"><B>$L{BSCH_LOOKIN}</B></FONT></TD>
<TD><SELECT SIZE=1 NAME=lookin>
<OPTION VALUE=1>$L{BSCH_TITLESOF}
<OPTION VALUE=2>$L{BSCH_AUTHORS}
<OPTION VALUE=3 SELECTED>$L{BSCH_TEXT}
<OPTION VALUE=4>$L{BSCH_ALLOFTHESE}
</SELECT></TD>
</TR>
<TR>
<TD><FONT FACE="$face" SIZE="$size"><B>$L{BSCH_TYPEOFPAGE}</B></FONT></TD>
<TD><SELECT SIZE=1 NAME=typepage>
<OPTION VALUE=1>$L{BSCH_TYPEOFPAGE_1}
<OPTION VALUE=3>$L{BSCH_TYPEOFPAGE_3}
</SELECT></TD>
</TR>
<TR>
<TD><FONT FACE="$face" SIZE="$size"><B>$L{BSCH_LIMITTO}</B></FONT></TD>
<TD><SELECT SIZE=1 NAME=limit>
<OPTION VALUE=1>$L{BSCH_LIMIT_1DAY}
<OPTION VALUE=2>$L{BSCH_LIMIT_2DAY}
<OPTION VALUE=7>$L{BSCH_LIMIT_7DAY}
<OPTION VALUE=14>$L{BSCH_LIMIT_14DAY}
<OPTION VALUE=30 SELECTED>$L{BSCH_LIMIT_30DAY}
<OPTION VALUE=0>$L{BSCH_LIMIT_NONE}
</SELECT></TD>
</TR>
</TABLE>
<P>
EOFORM
print "<INPUT TYPE=SUBMIT VALUE=\"$L{BSCHBUTTONTEXT}\"></TD></TR></TABLE>";
print "</FORM>\n";
&ex('printuntil', 3, 17, 0, "", 0, 1);
exit(0);
}
$q = $FORM{'query'};
$w = $FORM{'searchwhere'};
$l = $FORM{'lookin'};
$t = $FORM{'limit'};
$y = $FORM{'typepage'};
# Build up topics list that is to be searched
undef @topics;
open (TOPICS, "$message_dir/board-topics.html"); @tf = <TOPICS>; close (TF);
@tf2 = grep(/<!-Top:/, @tf);
foreach $line (@tf2) {
if ($line =~ m|<!-Top: (\d+)-!>|) {
$topic = $1;
if (-e "$message_dir/$topic") {
$secured{$topic} = 0;
push (@topics, $topic) if (grep(/^$topic$/, split(/,/, $w)) || $w eq "ALL");
} else {
$secured{$topic} = 1;
@auth = &ex('validate_auths', $topic);
if (grep(/^$topic$/, @auth)) {
push (@topics, $topic) if (grep(/^$topic$/, split(/,/, $w)) || $w eq "ALL");
}
}
}
}
# Build up list of files that are to be searched
undef @files; undef @match; undef %seenfile;
if ($l == 3 || $t != 0 || $l == 2 || $y == 1) {
$timecutoff = time - (60*60*24*$t) if $t;
open (LOG, "$admin_dir/log.txt"); @LOG = <LOG>; close (LOG);
foreach $line (reverse(@LOG)) {
($index, $who, $time, $where, $ip1, $ip2, $source, $postby) = split(/;/, $line);
$postby{$where} = "$index-----$postby\n$postby{$where}";
next if $seenfile{$where};
last if $time < $timecutoff;
($tn, $pn) = split(/\//, $where);
if (grep(/^$tn$/, @topics)) {
push (@files, $where);
$seenfile{$where} = 1;
}
}
} else {
foreach $topic (@topics) {
&recurse_find($topic, $topic);
}
if ($l == 4) {
open (LOG, "$admin_dir/log.txt"); @LOG = <LOG>; close (LOG);
foreach $line (reverse(@LOG)) {
($index, $who, $time, $where, $ip1, $ip2, $source, $postby) = split(/;/, $line);
$postby{$where} = "$index-----$postby\n$postby{$where}";
}
}
}
# Score each page based on hits
undef %score;
undef %context;
undef %wordseen;
while ($q =~ m|"([^"]+)"|g) {
$b = $`; $a = $';
$m = $1; $m =~ s/\s/!!!SPACE!!!/g;
$q = join("", $b, $m, $a);
}
@words = split(/\s+/, $q);
foreach $word (@words) {
if ($word =~ m|^-|) {
$r = -1; $word = $';
} elsif ($word =~ m|^\+|) {
$r = 1; $word = $';
} else {
$r = 0;
}
$word =~ s/!!!SPACE!!!/ /g; # Undo space conversion above
$word = &escape_input($word); # Make search string escaped as when posting
$word =~ s/([^\w\s])/\\$1/g; # Quote any possible meta characters
if ($r == -1) {
push (@badword, $word);
} elsif ($r == 1) {
push (@require, $word);
}
}
@words = grep(/\S/, @words);
foreach $where (@files) {
($topic, $page) = split(/\//, $where);
if ($head{$where} eq "") {
($head{$where}, $lm{$where}, $sublist{$where}, $message{$where}) = &search_get_page($topic, $page);
}
if ($l == 1 || $l == 4) {
while ($head{$where} =~ m|<!--Level (\d+): (\d+)/(.*)-->|g) {
$ms = $3;
foreach $word (@words) {
while ($ms =~ m|$word|ig) {
$wordseen{$where} .= "\n$word\n";
$score{$where} += 1;
}
}
}
}
if ($l == 2 || $l == 4) {
$ms = &unescape($postby{$where});
foreach $word (@words) {
while ($ms =~ /(.*)($word)(.*)/gi) {
$wordseen{$where} .= "\n$word\n";
$score{$where} += 1;
$o = $1; $t = $2; $h = $3;
if ($o =~ m|^(\d+)-----|) {
$o = $'; $m = $&;
}
$context{$where} .= "$m$L{BSCH_AUTHOR} $o$t$h\n";
}
}
}
if ($l == 3 || $l == 4) {
while ($message{$where} =~ m|<!-Post: (\d+)-!>([\s\S]+)<!-/Post: \1-!>|g) {
$postnum = $1; $ms = $2;
$ms =~ m|<P>\n(.*)\s+(.*)|; $o = $1; $t = $2;
if ($o =~ m|^<!-NOTE:|) {
$ms = $t;
} else {
$ms = $o;
}
# Note: the following code was written this way because of a bug
# in SGI Perl 4... I know it's dreadful :)
while ($ms =~ /<IMG SRC="[^"]*" ALT="([^"]*)">/) {
$ms = join("", $`, "[$2]", $');
}
while ($ms =~ /<([^>]*)>/) {
$ms = join("", $`, $');
}
while ($ms =~ /(\d+);/) {
$ms = join("", $`, $');
}
# End Perl 4 workaround
foreach $word (@words) {
# Another workaround
$msg = $ms;
while ($msg =~ m|($word)|i) {
$msg = $';
$a = substr($', 0, 30); $b = substr($`, -30, 30); $w = $1;
$a =~ m|^(.*)|; $a = $1;
$b =~ m|(.*)$|; $b = $1;
$score{$where} += 1;
$wordseen{$where} .= "\n$word\n";
$context{$where} .= "$postnum-----$b$w$a\n";
}
}
}
}
}
foreach $file (@files) {
if ($score{$file} == 0) {
$file = ""; next;
}
foreach $w (@badword) {
$file = "" if $wordseen{$file} =~ m|\n$w\n|;
}
foreach $w (@require) {
$file = "" if $wordseen{$file} !~ m|\n$w\n|;
}
}
@files_s = sort by_score (grep(/\S/, @files));
&header;
&ex('printuntil', 1, 1, 0, "$L{BSCHRESULTS}");
print "<FONT SIZE=+1><CENTER><B>$L{BSCHRESULTS}</B></CENTER></FONT><HR>\n";
$pages = scalar(@files_s);
if ($pages == 0) {
$reply = $L{BSCH_0HITS};
} elsif ($pages == 1) {
$reply = $L{BSCH_1HIT};
} else {
$reply = $L{BSCH_MANYHITS};
}
$q = $FORM{'query'};
$reply =~ s/\%query/$q/g;
$reply =~ s/\%results/$pages/g;
print $reply;
print "<P>\n";
$mc = 0;
foreach $file (@files_s) {
undef %cs; $where = $file;
($topic, $page) = split(/\//, $file);
if ($head{$where} eq "") {
($head{$where}, $lm{$where}, $sublist{$where}, $message{$where}) = &search_get_page($topic, $page);
}
@head = split(/\n/, $head{$file});
($topicstr) = grep(/<!--Topic: (\d+)/, @head);
$topicstr =~ m|<!--Topic: (\d+)/(.*)-->|; $topic = $1;
$navbar = $2;
foreach $line (@head) {
if ($line =~ m|<!--Level \d+: \d+/(.*)-->|) {
$navbar .= ": $1";
}
}
$mc += 1;
print "$mc. ";
$show = "<A HREF=\"$message_url/$file.$ext" if $secured{$topic} == 0;
$show = "<A HREF=\"$script_url/board-auth.$cgi_extension?file=/$file.$ext&lm=$lm{$file}" if $secured{$topic} == 1;
$show .= "?$lm{$file}" if (!$noqm && $secured{$topic} == 0);
print $show;
print "\"><B>";
print $navbar;
print "</B></A>\n";
print "<BLOCKQUOTE><FONT SIZE=-1>\n";
foreach $word (@words) {
$context{$file} =~ s/($word)/<B>$1<\/B>/gi;
}
@context = split(/\n/, $context{$file}); @context = grep(/\S/, @context);
$ctr = 0;
foreach $line (@context) {
next if $cs{$line};
if ($line =~ m|^(\d+)-----|) {
$pn = $1; $line = $';
$line =~ s/<B>([^<]+)<\/B>/$show#POST$pn"><B>$1<\/B><\/A>/g;
}
print "$L{BSCH_DOT} $line<BR>\n";
$cs{$line} = 1; $ctr += 1;
last if $ctr > 7;
}
print "</FONT></BLOCKQUOTE>\n";
print "<P>\n";
}
&ex('printuntil', 3, 17, 0, "", 0, 1);
exit(0);
sub by_score {
return -1 if $score{$a} > $score{$b};
return 1 if $score{$b} > $score{$a};
return 0;
}
sub recurse_find {
local ($topic, $page) = @_;
local ($where, $line);
$where = "$topic/$page";
($head{$where}, $lm{$where}, $sublist{$where}, $message{$where}) = &search_get_page($topic, $page);
foreach $line (split(/\n/, $sublist{$where})) {
if ($line =~ m|<!-Top: (\d+)-!>|) {
&recurse_find($topic, $1);
}
}
push (@files, $where);
}
sub search_get_page {
($topic, $page) = @_;
return ("", "", "", "") if ($topic == 0 || $page == 0);
local ($file, $temp);
$temp = $/;
undef $/;
if ($secured{$topic} == 0) {
open (FILE, "$message_dir/$topic/$page.$ext");
} else {
open (FILE, "$secdir/$topic/$page.$ext");
}
($file) = <FILE>;
close (FILE);
$file =~ m|<HTML>|; $head = $`;
$file =~ m|\s<A NAME="(\w+)">|; $lm = $1;
$file =~ m|<!--Messages-->([\s\S]*)<!--/Messages-->|; $msg = $1;
$file =~ m|<!--Sublist-->([\s\S]*)<!--/Sublist-->|; $sl = $1;
$/ = $temp;
return ($head, $lm, $sl, $msg);
}
sub escape_input {
local ($stringin) = @_;
$_ = $stringin;
s/&/&/g; s/</\</g; s/>/\>/g; s/"/"/g; s/\\\\/\/g;
s/\\\{/{/g; s/\\\}/}/g; s/\\,/,/g; s/\(/(/g;
s/\)/)/g; s/\[/[/g; s/\]/]/g; s/\*/*/g; s/\+/+/g;
s/\|/|/g; s/'/'/g; s/\r\n/\n/g; s/\r/\n/g; s/\n/ <BR>/g;
return $_;
}