#!/usr/bin/perl
#$rcs = ' $Id: indexer.pl,v 1.36 2000/04/10 22:07:24 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 Fcntl;
use locale;

# 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) {
  print "Using $_...\n" and last if eval "require $_";
}

package main;
require 'conf.pl';

$|=1;

my $DN  = 0;  #documents number
my $TN  = 0;  #terms number

my @stopwords;
my @no_index;

my %inv_index_db;
my %docs_db;
my %desc_db;
my %title_db;
my %terms_db;
my %df_db;
my %tf_db;

tie %inv_index_db, AnyDBM_File, $INV_INDEX_TMP_DB_FILE, O_CREAT|O_RDWR, 0755 or die "Cannot open $INV_INDEX_TMP_DB_FILE: $!";   
tie %docs_db,      AnyDBM_File, $DOCS_TMP_DB_FILE, O_CREAT|O_RDWR, 0755      or die "Cannot open $DOCS_TMP_DB_FILE: $!";   
tie %desc_db,      AnyDBM_File, $DESC_TMP_DB_FILE, O_CREAT|O_RDWR, 0755      or die "Cannot open $DESC_TMP_DB_FILE: $!";   
tie %titles_db,    AnyDBM_File, $TITLES_TMP_DB_FILE, O_CREAT|O_RDWR, 0755    or die "Cannot open $TITLES_TMP_DB_FILE: $!";   
tie %terms_db,     AnyDBM_File, $TERMS_TMP_DB_FILE, O_CREAT|O_RDWR, 0755     or die "Cannot open $TERMS_TMP_DB_FILE: $!";   
tie %df_db,        AnyDBM_File, $DF_DB_FILE, O_CREAT|O_RDWR, 0755            or die "Cannot open $DF_DB_FILE: $!";
tie %tf_db,        AnyDBM_File, $TF_DB_FILE, O_CREAT|O_RDWR, 0755            or die "Cannot open $TF_DB_FILE: $!";

print "Loading \'no index\' regular expressions:\n";
load_excludes();
print "Loading stopwords...";
my $stopwords_regex = load_stopwords();
print "Done.\n";

print "Starting crawler...\n";
crawl($DOCUMENT_ROOT.$INDEXER_START_DIR);
print "Crawler finished($DN files, $TN terms)\n\n";

print "Calculating weight vectors: \n";
weights();

print "Removing unused db files:\n";

print "\t$TF_DB_FILE...";
if (unlink $TF_DB_FILE) {
  print "ok\n";
} else {
  warn "Cannot unlink $TF_DB_FILE: $!";
}

print "\t$DF_DB_FILE...";
if (unlink $DF_DB_FILE) {
  print "ok\n";
} else {
  warn "Cannot unlink $DF_DB_FILE: $!";
}

print "Renaming newly created db files...\n";
rename_db();

print "Indexer finished.\n";

sub crawl {
  my $dir = $_[0];
  my $doc_id;
  my $file;
  
  print $dir,"\n";

  chdir $dir or (warn "Cannot chdir $dir: $!" and next);
  opendir(DIR, $dir) or (warn "Cannot open $dir: $!" and next);
  my @contents = readdir DIR;
  closedir(DIR);

  my @dirs  = grep {-d and not /^\.{1,2}$/} @contents; 
  my @files = grep {-f and /^.+\.(.+)$/ and grep {/^\Q$1\E$/} @EXT} @contents;
  
  FILE: foreach my $f (@files) {
    $file = $dir."/".$f;
    $file =~ s/\/\//\//og;

    foreach my $regexp (@no_index) {
      next FILE if $file =~ m/^$regexp$/;
    }
    
    $doc_id = record_file($file);
    index_file($file, $doc_id);
  }

  DIR: foreach my $d (@dirs) {
    $file = $dir."/".$d;
    $file =~ s/\/\//\//og;
    
    foreach my $regexp (@no_index) {
      next DIR if $file =~ /^$regexp$/;
    }
    crawl($file);
  }
}

sub index_file {
  my ($file, $doc_id) = @_;
  my ($term, $term_id);
  my $buffer;
  my %tf;

  undef $/;
  open(FILE, $file) or (warn "Cannot open $file: $!" and next);
  $buffer = <FILE>;
  close(FILE); 
  $/ = "\n";  

  print "\t $doc_id: $file\n";

  record_desc($doc_id, $buffer);    
  $buffer = normalize($buffer);
  
  foreach (split " ", $buffer) {
    $_ = substr $_, 0, $STEMCHARS if $STEMCHARS;
    if (length $_ >= $MINLENGTH) {
      $term_id = record_term($_);
      ++$tf{$term_id};
    }
  }
  
  foreach (keys %tf) {
    $df_db{$_}++;
    $tf_db{$_} = '' unless defined $tf_db{$_};
    $tf_db{$_} .= pack("ww", $doc_id, $tf{$_}); 
  }
}

sub weights {
  my ($weight, $term_id, $doc_id);
  my $step = $TN / 50;
  my $count = 0;
  
  $step = 1 if $step < 1;

  print "0%  10%  20%  30%  40%  50%  60%  70%  80%  90%  100%\n";
  print "|----|----|----|----|----|----|----|----|----|----|\n";
  print ">";


  foreach $term_id (keys %tf_db) {
    my $weights = $inv_index_db{$term_id} || '';
    my $df = $df_db{$term_id};
    my %tdf = unpack("w*",$tf_db{$term_id}); 
    $count++;
    print "\b >" unless $count % $step;
    foreach $doc_id (keys %tdf) {
      #print "weight = $tdf{$doc_id} * log ($DN / $df\n";
      $weight = $tdf{$doc_id} * log ($DN / $df);
      $weights .= pack("ff", $doc_id, $weight);
    }
    undef %tdf;
    $inv_index_db{$term_id} = $weights;
  }
  print "\n";
}

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 =~ s/$stopwords_regex//gio;
  $buffer =~ tr/a-zA-Z0-9_/ /cs;
  return lc $buffer;
}

sub record_file {
  my $file = $_[0];

  $file =~ m/^$DOCUMENT_ROOT(.*)$/;
  $file = $1;
  unless ($file =~ /^\//) {
    $file = "/".$file;
  }

  ++$DN;
  $docs_db{$DN} = $file;
  return $DN;
}

sub record_parent {
  my $file = $_[0];

  $buffer =~ m/<META\s+name\s*=\s*[\"\']?parentpage[\"\']? content=[\"\']?(.*?)[\"\']?>/is;
  if($buffer =~ m/body=(.*)$/) { $parent = $1 } else { die "invalid filename" }

  ++$DN;
  $docs_db{$DN} = $parent;
  return $DN;
}

sub record_desc {
  my ($doc_id, $buffer) = @_;
  my ($desc, $title);
  my @desc_ary;

  $buffer =~ m/<META\s+name\s*=\s*[\"\']?description[\"\']? content=[\"\']?(.*?)[\"\']?>/is;
  $desc = $1;
  
  unless ($desc) {
    $buffer =~ m/<BODY.*?>(.*)<\/BODY>/is;
    $desc = $1;
    $desc =~ s/<.+?>/ /gis; #strip html
    $desc =~ tr/\n\r/ /s;
    @desc_ary = split " ", $desc;
    $desc = $1;
    $desc = join " ", @desc_ary[0..$DESC_WORDS];
  }
  $desc_db{$doc_id} = $desc;

  $buffer =~ m/<TITLE>(.*?)<\/TITLE>/is;
  $title = $1;
  $title ||= "Untitled";
  $titles_db{$doc_id} = $title;
}

sub record_term {
  my $term = $_[0];

  print STDERR "Warning: record_term($term): No term was supplied\n" unless $term;

  if ($terms_db{$term}) {
    return $terms_db{$term};
  } else {
    ++$TN;
    $terms_db{$term} = $TN;
    return $TN;
  }
}

sub load_excludes {
  if (-e $NO_INDEX_FILE) {
    open (FILE, $NO_INDEX_FILE) or (warn "Cannot open $NO_INDEX_FILE: $!" and next);
    while (<FILE>) {
      chomp;
      $_ =~ s/\r//g;        # get rid of carriage returns      
      $_ =~ s/(\#.*)//g;    # ingore comments
      $_ =~ s/[\/\s]*$//;   # remove any trailing spaces and slashes
      print "\t- $_\n";
      
      $_ = quotemeta;       # escape all non-alphanumeric characters
      $_ =~ s/\\\*/\.\*/g;  # except for the * which is replaced by .*
      push @no_index, $_;
    }
    close (FILE);
  } else {
    print STDERR "Warning: $NO_INDEX_FILE missing.";
  }
}

sub rename_db {
  my @files = (
	       [$TERMS_TMP_DB_FILE, $TERMS_DB_FILE],
	       [$DOCS_TMP_DB_FILE, $DOCS_DB_FILE],
	       [$TITLES_TMP_DB_FILE, $TITLES_DB_FILE],
	       [$DESC_TMP_DB_FILE, $DESC_DB_FILE],
	       [$INV_INDEX_TMP_DB_FILE, $INV_INDEX_DB_FILE],
	      );

  foreach (@files) {
    if (-e $_->[0]) {
      print "\t ", $_->[0], " to ", $_->[1], "\n";
      rename $_->[0], $_->[1] or (warn "Cannot rename $_: $!" and next);
    } else {
      warn "File ", $_->[0], " doesn't exist: $!" and next;
    }
  }
}

sub load_stopwords {
  my @stopwords;
  my $stopwords_regex;

  open (FILE, $STOPWORDS_FILE) or (warn "Cannot open $STOPWORDS_FILE: $!" and next);
  while (<FILE>) {
    chomp;
    $_ =~ s/\r//g; # get rid of carriage returns
    push @stopwords, $_;
  }
  close(FILE);
  $stopwords_regex = '\b(' . join('|', @stopwords) . ')\b';

  return $stopwords_regex;
}
