File Coverage

blib/lib/WE_Frontend/Indexer/Htdig.pm

Criterion	Covered	Total	%
statement	6	154	3.9
branch	0	74	0.0
condition	0	17	0.0
subroutine	2	7	28.5
pod	1	4	25.0
total	9	256	3.5

# -*- perl -*-

#
# $Id: Htdig.pm,v 1.18 2006/12/01 10:12:56 cmuellermeta Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2002 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: [e-mail]
# WWW:  http://www.rezic.de/eserte/
#

package WE_Frontend::Indexer::Htdig;

use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);

## XXX Maybe some day ...
# sub new {
#     my $class = shift;
#     my(%args) = @_;
#     my $self = {};
#     if ($args{-searchengine}) {
# 	WEsiteinfo::SearchEngine
#     }
# }

sub conf {
    my($conf, $lang) = @_;
    $conf =~ s/%\{lang\}/$lang/g;
    $conf;
}

sub conf_is_lang_dependent {
    my($conf) = @_;
    $conf =~ /%\{lang\}/ ? 1 : 0;
}

sub search {
    my(%args) = @_;
    my $words = delete $args{-words} || die "No words specified";
    my $conf  = delete $args{-conf};
    my $lang  = delete $args{-lang};
    my $query = delete $args{-query};
    my $debug = delete $args{-debug};
    my $https_hack = delete $args{-httpshack};
    my $transform  = delete $args{-transform};
    my $method = delete $args{-method};

    if (keys %args) { warn "Unknown arguments: " . join(", ", %args) } # XXXdie?

    local %ENV = %ENV;
    delete $ENV{REQUEST_METHOD}; # security barrier in htsearch
    # Location of htdig in the standard FreeBSD port, after a normal
    # unaltered install and a Debian 3.0 install. Sometimes $ENV{PATH} is
    # empty, so supply additional reasonable defaults.
    local $ENV{PATH} .= ":/usr/local/share/apache/cgi-bin:/opt/www/cgi-bin:/usr/lib/cgi-bin:/usr/bin:/bin";

    if ($debug) {
	warn "Current path is $ENV{PATH}";
    }

    require CGI;
    my $q = CGI::new($query);
    $q->param("words", $words);
    $q->param("format", "perl");
    $q->param("method", $method) if defined $method;

    my $conf_path = conf($conf, $lang) if defined $conf;
    my @htsearch_cmd = ("htsearch",
			(defined $conf ? ("-c", $conf_path) : ()),
			$q->query_string);
    open(HTSEARCH, "-|") or do {
	if ($debug) {
	    warn "Execute: @htsearch_cmd";
	}
	exec @htsearch_cmd;
	die "Can't execute htsearch command (@htsearch_cmd), PATH is $ENV{PATH}: $!";
    };

    # overread header
    while() {
	chomp;
	last if /^\r?$/;
    }

    # slurp generated perl data dump
    local $/ = undef;
    my $perlcode = ;
    #warn $perlcode;

    require Safe;
    my $cpt = Safe->new;
    my $obj = $cpt->reval($perlcode);

    my $nr = 0;
    die "Error while evaluating perl code result from htsearch call:\n@htsearch_cmd.\n" .
	"Code: " . join("\n", map { sprintf "%4d %s", ++$nr, $_ }
			split /\n/, $perlcode) . "\n" .
	"Error: $@\n" .
	(defined $conf ? "Configuration file is $conf_path\n" : "Using standard configuration file\n")
	    if !$obj;

    while(my($key,$val) = each %$obj) {
	if ($key =~ /(.*)_urlenc$/) {
	    my $real_key = $1;
	    $obj->{$real_key} = CGI::unescape($val);
	} elsif ($key eq 'list') {
	    for my $obj (@$val) {
		while(my($key,$val) = each %$obj) {
		    if ($key =~ /(.*)_urlenc$/) {
			$obj->{$1} = CGI::unescape($val);
		    }
		}
	    }
	}
    }

    my $parse_href = sub {
	my $href = shift;
	my($pageurl, $pagenumber);
	if (my($url, $querystring) = $href =~ /^(.*?)\?(.*)$/) {
	    my $q = CGI->new($querystring);
	    if (defined $lang && !defined $q->param("lang")) {
		$q->param("lang", $lang);
	    }
	    if (!defined $q->param("page")) {
		warn "Can't get page parameter from $href";
		$pagenumber = undef;
	    } else {
		$pagenumber = $q->param("page");
	    }
	    my $new_href = "$url?" . $q->query_string;
	    $pageurl = $new_href;
	} else {
	    warn "Can't parse URL $href";
	}
	($pageurl, $pagenumber);
    };

    if ($obj->{"pagelist"}) {
	my @pageurllist;
	my @pagenumberlist;
	my @hrefs = $obj->{"pagelist"} =~ m{href="(.*?)"}g;
	for my $href (@hrefs) {
	    my($pageurl, $pagenumber) = $parse_href->($href);
	    if (defined $pageurl) {
		push @pageurllist, $pageurl;
		push @pagenumberlist, $pagenumber;
	    }
	}
	# Add this page
	if ($pagenumberlist[0] != 1) {
	    unshift @pageurllist, undef; # undef means: this page
	    unshift @pagenumberlist, 1;
	} else {
	SEARCH: {
		for my $i (0 .. $#pagenumberlist) {
		    if ($i+1 != $pagenumberlist[$i]) {
			# current page is in the middle of the list
			splice @pagenumberlist, $i, 0, $i+1;
			splice @pageurllist, $i, 0, undef;
			last SEARCH;
		    }
		}
		# otherwise it's the last page
		push @pageurllist, undef;
		push @pagenumberlist, $#pagenumberlist+2;
	    }
	}
	$obj->{pageurllist}    = \@pageurllist;
	$obj->{pagenumberlist} = \@pagenumberlist;
    }

    for my $dir (qw(prev next)) {
	if ($obj->{$dir."page"}) {
	    my($href) = $obj->{$dir."page"} =~ m{href="(.*?)"};
	    my($pageurl, $pagenumber) = $parse_href->($href);
	    if (defined $pageurl) {
		$obj->{$dir."pageurl"} = $pageurl;
		$obj->{$dir."pagenumber"} = $pagenumber;
	    }
	}
    }

    if ($https_hack && $obj->{list}) {
	for my $hit (@{ $obj->{list} }) {
	    $hit->{url} =~ s{^http://}{https://};
	}
    }

    # words is documented, but not available?
    if (!exists $obj->{words}) {
	$obj->{words} = $words;
    }

    if ($transform) {
	$transform->($obj);
    }

    $obj;
}

sub generate_conf {
    my($c, %args) = @_;

    my $debug = $args{-debug};

    my $lang = $args{-lang};

    my $tpl  = $args{-htdigconftemplate} || $c->searchengine->htdigconftemplate;
    my $conf = $args{-htdigconf} || $c->searchengine->htdigconf;
    my $lang_conf = conf($conf, $lang);
    if (conf_is_lang_dependent($lang_conf)) {
	die "-lang should be supplied for language independent conf specification $conf";
    }

    if (!defined $tpl) {
	if ($debug) {
	    warn "No template config defined, we're done with $lang_conf.\n";
	}
	return $lang_conf;
    }

    my @dependents;
    if ($args{-dependents}) {
	@dependents = @{ $args{-dependents} };
    } else {
	(my $pkgfile = __PACKAGE__) =~ s{::}{/}g;
	# XXX what if module is named WEsiteinfo_project.pm and WEprojectinfo_project.pm?
	push @dependents,
	    $INC{"WEsiteinfo.pm"}, $INC{"WEprojectinfo.pm"},
	    $tpl,
	    $INC{"$pkgfile.pm"};
    }

    # is the configuration file current?
    my $conf_is_old = 0;
    if (!-e $lang_conf) {
	$conf_is_old = 1;
    } else {
	for my $dep (grep { defined $_ } @dependents) {
	    if (!-e $lang_conf || -M $dep < -M $lang_conf) {
		$conf_is_old = 1;
		last;
	    }
	}
    }

    if (!$conf_is_old) {
	warn "htdig config file $lang_conf is current, we're done.\n";
	return $lang_conf;
    }

    my $long_lang;
    if (defined $lang) {
	$long_lang = {en => "english",
		      de => "german",
		      it => "italian",
		      fr => "french",
		      kr => "korean",
		      ru => "russian",
		      es => "spanish",
		      pt => "portugese",
		      hu => "hungarian",
		     }->{$lang};
	warn "long_lang is not defined for $lang"
	    if !defined $long_lang;
    }

    # regenerate conf file
    require Template;
    # XXX Don't duplicate this --- already found in we_search.cgi and
    # we_redisys.cgi
    my $t = Template->new
	(ABSOLUTE => 1,
	 POST_CHOMP => 0,
	 INCLUDE_PATH => [$c->paths->site_templatebase,
			  $c->paths->we_templatebase,
			 ],
	 EVAL_PERL => 1,
	 PLUGIN_BASE => ["WE_" . $c->project->name . "::Plugin",
			 "WE_Frontend::Plugin"]
	);
    if ($debug) {
	warn "Create config file $lang_conf from $tpl.\n";
    }
    my $conf_header = <
# DO NOT EDIT THIS FILE!
# Generated automatically by:
#   module: @{[ __PACKAGE__ ]}
#   user:   @{[ (getpwuid($<))[0] ]}
#   date:   @{[ scalar localtime ]}
EOF
    $t->process
	($tpl,
	 {c        => $c,
	  config   => $c, # for compatibility
	  lang     => $lang,
	  longlang => $long_lang,
	  # strip dash from args keys
	  args     => [map { (substr($_, 1) => $args{$_}) } keys(%args)],
	  conf_header => $conf_header,
	 }, $lang_conf)
	or die $t->error;

    return $lang_conf;
}

1;

__END__