#!/usr/bin/perl
#$rcs = ' $Id: search.pl,v 1.14 2000/04/10 22:08:18 perlfect Exp $ ' ;

# Perlfect Search
#
# Copyright (C) 1999-200 Giorgos Zervas <giorgos@perlfect.com>
# 
# 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307
# USA

use locale;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
use Fcntl;
use Perlfect::Template;

# added program path to @INC because it fails to find ./conf.pl if started from
# other directory
{ 
  # block is for $1 not mantaining its value
  $0 =~ /(.*)\//;
  push @INC, $1 if $1;
}

package AnyDBM_File;
@ISA = qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File) unless @ISA;

for (@ISA) {
  last if eval "require $_";
}

package main;
require 'conf.pl';

my %inv_index_db;
my %docs_db;
my %desc_db;
my %titles_db;
my %terms_db;

tie %inv_index_db, AnyDBM_File, $INV_INDEX_DB_FILE, O_RDONLY, 0755 or die "Cannot open $INV_INDEX_DB_FILE: $!";   
tie %docs_db,      AnyDBM_File, $DOCS_DB_FILE, O_RDONLY, 0755      or die "Cannot open $DOCS_DB_FILE: $!";   
tie %desc_db,      AnyDBM_File, $DESC_DB_FILE, O_RDONLY, 0755      or die "Cannot open $DESC_DB_FILE: $!";   
tie %titles_db,    AnyDBM_File, $TITLES_DB_FILE, O_RDONLY, 0755    or die "Cannot open $TITLES_DB_FILE: $!";   
tie %terms_db,     AnyDBM_File, $TERMS_DB_FILE, O_RDONLY, 0755     or die "Cannot open $TERMS_DB_FILE: $!";   

my (@force, @not, @other);
my (@docs, @valid_docs);
my %answer;

my $query = new CGI;

if (create_query()) { #if some valid documents exist
  apply_booleans();
  answer_query();
}  

my $html = cast_template();
print $query->header;
print $html;

sub answer_query {
  my @term_ids = (@force, @other);

  my %valid_docs;
  map { $valid_docs{$_} = 1 } @valid_docs;

  foreach my $term_id (@term_ids) {
    my %v = unpack('f*', $inv_index_db{$term_id});
    foreach my $doc_id (keys %v) {
      $answer{$doc_id} += $v{$doc_id} if exists $valid_docs{$doc_id};
    }
  }
}

sub apply_booleans {
  #locate the valid documents by applying the booleans
  my ($term_id, $doc_id, $first_doc_id);
  my %v;
  my (@ary, @not_docs);

  my %not_docs;
  map { $not_docs{$_} = 1} @not_docs;

  foreach $term_id (@not) {
    %v = unpack("f*", $inv_index_db{$term_id});
    foreach $doc_id (keys %v) {
      push @not_docs, $doc_id unless exists $not_docs{$doc_id};
    }
  }
  
  if (@force) {
    $first_doc_id = pop @force;
    %v  = unpack("f*", $inv_index_db{$first_doc_id});
    @valid_docs = keys %v; 
    foreach $term_id (@force) {
      %v = unpack("f*", $inv_index_db{$term_id});
      @ary = keys %v;
      @valid_docs = intersection(\@valid_docs, \@ary);
    }
    push @force, $first_doc_id;
  } else {
    @valid_docs = keys %docs_db;
  }

  @valid_docs = minus(\@valid_docs, \@not_docs);
}

sub create_query {
  my $query_str = $query->param('q');
  my @terms = split " ", $query_str;
  my $buffer;
  my ($sterm, $nterm);
  
  foreach my $term (@terms) {
    $buffer = normalize($term);
    foreach my $nterm (split " ",$buffer) {
      $sterm = stem($nterm);
      if ($term =~ /^\+/) {
	if ($terms_db{$sterm}) {
	  push @force, $terms_db{$sterm};
	} else {
	  return 0;
	}
      } elsif ($term =~ /^\-/) {
	push @not, $terms_db{$sterm} if $terms_db{$sterm};
      } else {
	push @other, $terms_db{$sterm} if $terms_db{$sterm};
      }
    }
  }

  return 1;
}

sub cast_template {
  my %h;
  my $template = new Perlfect::Template($SEARCH_TEMPLATE);
  my $rank = 0;

  $h{script_name} = "Perlfect Search $VERSION";
  $h{query_str}   = $query->param('q');
  $h{results_num} = keys %answer;
  
  my $current_page = $query->param('p');
  $current_page ||= 1;

  my $first = ($current_page - 1) * $RESULTS_PER_PAGE; 
  my $last  = $first + $RESULTS_PER_PAGE - 1;
  
  my $real_last = keys %answer;
  if ($last >= $real_last) {
    $last = $real_last - 1;
  }
  
  foreach ((sort {$answer{$b} <=> $answer{$a}} keys %answer)[$first..$last]) {
    my $score = sprintf "%.2f", $answer{$_};
    $template->cast_loop ("results", [{rank => $first+(++$rank), 
				       url => $BASE_URL.$docs_db{$_}, 
				       title => $titles_db{$_}, 
				       score => $score,
				       description => $desc_db{$_},
				      }]);
  }
  $template->finalize("results");
  
  my $last_page = ceil($real_last, $RESULTS_PER_PAGE);
  $last_page ||= 1;
  my $query_str = CGI::escape($query->param('q'));
  if ($current_page == 1) {
    $h{previous} = "";
    if ($last_page > $current_page) {
      $h{next} = "<A href=\"$SEARCH_URL?q=".$query_str."&p=2\"> Next</A>";  
    } else {
      $h{next} = "";
    }
  } elsif ($current_page == $last_page) {
    $h{previous} = "<A href=\"$SEARCH_URL?q=".$query_str."&p=".($last_page-1)."\">Previous </A>";  
    $h{next} = "";
  } else {
    $h{previous} = "<A href=\"$SEARCH_URL?q=".$query_str."&p=".($current_page-1)."\">Previous </A>";  
    $h{next} = "<A href=\"$SEARCH_URL?q=".$query_str."&p=".($current_page+1)."\"> Next</A>";  
  }
  
  for (1..$last_page) {
    if ($_ != $current_page) {
      $h{navbar} .= "<A href=\"$SEARCH_URL?q=".$query_str."&p=$_\">$_</A> ";
    } else {
      $h{navbar} .= "<B>$_</B> ";
    }
  }

  $h{current_page} = $current_page;
  $h{total_pages}  = $last_page;
  $h{search_url}   = $SEARCH_URL;

  $template->cast(\%h);
  return $template->html;
}

sub normalize {
  my $buffer = $_[0];

  $buffer =~ s/-(\s*\n\s*)?//g; # join parts of hyphenated words

  if ($INDEX_NUMBERS) {
    $buffer =~ s/(<[^>]*>)|(&\w+;)/ /gs;
  } else {
    $buffer =~ s/(\b\d+\b)|(<[^>]*>)|(&\w+;)/ /gs;
  }

  $buffer =~ tr/a-zA-Z0-9_/ /cs;
  return lc $buffer;
}

sub stem {
  my $str = $_[0];
  $str = substr $str, 0, $STEMCHARS if $STEMCHARS;
  return $str;
}

sub ceil {
  my $x = $_[0];
  my $y = $_[1];

  if ($x % $y == 0) {
    return $x / $y;
  } else {
    return int($x / $y + 1);
  }
}

sub intersection {
  my ($ra, $rb) = @_;
  my @i;
  
  foreach my $doc_id (@{$ra}) {
    push @i, $doc_id if grep {/^$doc_id$/} @{$rb};
  }

  return @i;
}

sub minus {
  my ($ra, $rb) = @_;
  my @i;

  foreach my $doc_id (@{$ra}) {
    push @i, $doc_id unless grep {/^$doc_id$/} @{$rb};
  }
  
  return @i;
}
