CGI::Application::Search - Base class for CGI::App Swish-e site engines

    package My::Search;
    use base 'CGI::Application::Search';

    sub cgiapp_init {
        my $self = shift;
        $self->param(
            'SWISHE_INDEX' => 'my-swishe.index',
            'TEMPLATE'     => 'search_results.tmpl',
        );
    }

    sub cgiapp_prerun {
        my $self  = shift;
        my $query = $self->query;

        # let the user turn context highlighting off
        $self->param('HIGHLIGHT' => 0) if $query->param('highlight_off');

        # let the user change which property is used in the sort
        my $sort_by = $query->param('sort_by');
        $self->param('SORT_BY' => $sort_by) if $sort_by;
    }

    1;

    <a href="?rm=highlight_remote_page;url=http%3A%2F%2Fexample.com%2Fabout_us%2Findex.html;keywords=Us">about us</a>

    <a href="?rm=highlight_local_page;path=%2Fabout_us%2Findex.html;keywords=Us">about us</a>

    sub setup {
        my $self = shift;
        # do your thing
        ...
        $self->SUPER::setup();
    }

    ?foo_start=123&foo_end=234

  -L foo 123 234

    swishrank asc

package CGI::Application::Search;
use base 'CGI::Application';
use strict;
use warnings;
use Carp;
use CGI::Application::Plugin::AnyTemplate;
use Data::Page;
use File::Spec::Functions qw(catfile splitpath catdir);
use Number::Format qw(format_bytes format_number);
use HTML::FillInForm;
use Time::HiRes;
use Time::Piece;
use POSIX qw(ceil);
use Text::Context;
use Unicode::Normalize;
use Encode qw(decode_utf8 encode_utf8);
use File::Slurp qw(read_file);

our $VERSION = '1.13';
our (
    $DEBUG,                # a debug flag
    @SUGGEST_CACHE,        # cached suggestions
    $SUGGEST_CACHE_TIME    # time of the last cache
);
$SUGGEST_CACHE_TIME = 0;

# some thing that will never appear in any doc that let's us return everything
our $BLANK_SEARCH = 'not asdfqweasdfasdflqkqoiqnwlekjiquwoienlkqw';

# load SWISH::API and complain if not available.  This is done here
# and not in Makefile.PL because SWISH::API is not on CPAN.  It's part
# of the Swish-e distribution.
BEGIN {
    eval "use SWISH::API";
    croak(<<END) if $@;

Unable to load SWISH::API.  This module is included in the Swish-e
distribution, inside the perl/ directory.  Please see the
CGI::Application::Search documentation for more details.

Error returned was: $@

END
}

__PACKAGE__->add_callback(
    init => sub {
        my $self = shift;
        return unless $self->param('UTF8');
        my $q = $self->query;
        $q->charset('UTF-8');

        # mark the strings as UTF8 so other stuff doesn't have to worry about it
        my @names = $q->param();
        foreach my $name (@names) {
            my @values = $q->param($name);
            foreach my $i (0 .. $#values) {
                # don't do filehandles
                next if lc(ref $values[$i]) eq 'fh';
                $values[$i] = Unicode::Normalize::NFC(decode_utf8($values[$i]));
            }

            $q->param($name => @values);
        }
    }
);

sub show_search {
    my $self = shift;
    my $q    = $self->query();

    my $tmpl_file;

    # if we have a user specified template
    if ($self->param('TEMPLATE')) {
        $tmpl_file = $self->param('TEMPLATE');

    } else {
        # what type of template do we want?
        my $ext = $self->param('TEMPLATE_TYPE') eq 'TemplateToolkit' ? '.tt' : '.tmpl';

        # is it an AJAX template?
        $tmpl_file = ($self->param('AJAX') ? 'ajax_' : '') . "search_results$ext";
        $tmpl_file = catfile($self->param('DEFAULT_TEMPLATE_PATH'), $tmpl_file);
    }
    my $tmpl = $self->template->load($tmpl_file);

    # give it all the stuff in $self
    $tmpl->param(self => $self);
    foreach my $param qw(
      searched elapsed_time keywords hits first_page
      last_page prev_page next_page pages start_num
      stop_num total_entries
      ) {
        $tmpl->param($param => $self->param($param))
          if ($self->param($param));
      }

      # add this url to the template too
      $tmpl->param(url => $q->url(-absolute => 1, path_info => 1));

    # add the possible ajax flag
    $tmpl->param(ajax => $q->param('ajax'));

    my $output = $tmpl->output();

    # don't use FiF if we are using AJAX
    unless ($self->param('AJAX') && $q->param('ajax')) {
        my $filler = HTML::FillInForm->new();
        $output = $filler->fill(
            scalarref => ref($output) ? $output : \$output,
            fobject => $q,
            ($self->param('FIF_DEFAULTS') ? %{$self->param('FIF_DEFAULTS')} : ())
        );
    }
    return $output;
}

sub _apply_range_values {
    my ($self, $search) = @_;
    my $q = $self->query;
    if ($self->param('EXTRA_RANGE_PROPERTIES')) {
        foreach my $prop (@{$self->param('EXTRA_RANGE_PROPERTIES')}) {
            my ($start, $stop) = ($q->param("${prop}_start"), $q->param("${prop}_stop"));
            if (defined $start and defined $stop) {
                $search->SetSearchLimit($prop, $start, $stop);
            }
        }
    }
}

sub perform_search {
    my $self = shift;
    my $q    = $self->query;

    # if we have any keywords
    my $keywords = $q->param('keywords');
    if (defined $keywords && !$self->param('results')) {
        my $index = $self->param('SWISHE_INDEX');

        # make sure the index exists and is readable
        croak "Index file $index does not exist!"
          unless (-e $index);

        $self->param('searched' => 1);
        my $start_time = Time::HiRes::time();

        # create my swish-e object
        my $swish = SWISH::API->new($index);
        croak "Problem reading $index : " . $swish->ErrorString
          if ($swish->Error);
        my $search = $swish->new_search_object();

        # add any range values
        $self->_apply_range_values($search);

        # set which property to sort by if given
        my $sort_by = $self->param('SORT_BY');
        $search->set_sort($sort_by) if $sort_by;

        my $search_query = $self->generate_search_query($keywords);

        # if we got one
        if (defined $search_query) {

            my $results = $search->execute($search_query);
            if ($swish->Error) {
                carp "Unable to create query: " . $swish->ErrorString
                  if ($DEBUG);
                return $self->show_search();
            }

            $self->param('elapsed_time' => format_number(Time::HiRes::time - $start_time, 3, 1));

            # create my pager and then go to the start page
            $self->_get_paging_vars($results);
            my @words = $self->_get_search_terms($swish, $search, $results, $keywords);
            $self->param(
                'hits' => $self->_process_results($swish, $search, $results, $search_query));
        } else {
            return $self->show_search();
        }
    }

    # if there are any extra properties used in the search, make them available to
    # the templates with the value in the query object
    my @extra_props;
    push(@extra_props, @{$self->param('EXTRA_PROPERTIES')}) if $self->param('EXTRA_PROPERTIES');
    push(@extra_props, @{$self->param('EXTRA_RANGE_PROPERTIES')})
      if $self->param('EXTRA_RANGE_PROPERTIES');
    foreach my $prop (@extra_props) {
        $self->param($prop => $q->param($prop));
    }
    $self->param('keywords' => $keywords);
    return $self->show_search();
}

sub highlight_remote_page {
    my $self = shift;
    my $q    = $self->query();
    my $url  = $q->param('url');

    # if it's relative, get the hostname and make it absolute
    if ($url !~ /^https?:\/\//) {
        $url = $q->url(-base => 1) . $url;
    }
    return $self->_hilight_page($url);
}

sub _hilight_page {
    my ($self, $page) = @_;
    my $content;

    # Search::Tools::HiLiter doesn't like blank searches so handle those on our own
    if( -e $page ) {
        $content = decode_utf8(read_file($page));
    } else {
        require HTTP::Request;
        require LWP::UserAgent;
        my $ua  = LWP::UserAgent->new();
        my $request  = HTTP::Request->new( GET => $page);
        my $response = $ua->request($request);
        if ( $response->is_error ) {
            warn "Error: Couldn't get '$page': response code " . $response->code . "\n";
            return;
        }

        $content = $response->content;
    }

    my $search_query = $self->query->param('keywords');
    if( $search_query && $search_query ne $BLANK_SEARCH ) {
        eval { require Search::Tools::HiLiter };
        if ($@) {
            warn "Could not load Search::Tools::HiLiter so no hilighting will be done: $@";
        } else {
            $content = Search::Tools::HiLiter->new(
                tag    => $self->param('HIGHLIGHT_TAG'),
                class  => $self->param('HIGHLIGHT_CLASS'),
                colors => $self->param('HIGHLIGHT_COLORS'),
                query  => $search_query,
            )->hilite($content);
        }
    }
    return $content;
}

sub highlight_local_page {
    my $self     = shift;
    my $q        = $self->query();
    my $doc_root = $self->param('DOCUMENT_ROOT');
    my $path     = $q->param('path');

    if (!$doc_root) {
        croak "You must define your DOCUMENT_ROOT to use this run mode!";
    }

    # make sure $path doesn't have any '/..' tricks in it
    $path =~ s/\/\.\.//g;

    my $file = catfile($doc_root, $path);
    return $self->_hilight_page($file);
}

sub suggestions {
    my $self = shift;

    if ($self->param('AUTO_SUGGEST')) {
        return $self->_auto_complete_results(
            $self->suggested_words($self->query->param('keywords')));
    } else {
        carp "Trying to use auto-suggest feature without AUTO_SUGGEST turned on!";
        return '';
    }
}

sub _auto_complete_results {
    my ($self, $values) = @_;
    my $html = '<ul>';
    foreach (@$values) {

        # straight from the CGI.pm bible.
        s/&/&amp;/g;
        s/\"/&quot;/g;    #"
        s/>/&gt;/g;
        s/</&lt;/g;
        s/'/&#39;/g;      #'
        $html .= "<li>$_</li>";
    }
    return $html . '</ul>';
}

sub new {
    my ($class, %args) = @_;
    # setup my defaults
    $args{PARAMS} = {
        SWISHE_INDEX       => catfile('data', 'swish-e.index'),
        PER_PAGE           => 10,
        HIGHLIGHT          => 1,
        HIGHLIGHT_TAG      => q(strong),
        HIGHLIGHT_CLASS    => 'hilite',
        HIGHLIGHT_COLORS   => [],
        DESCRIPTION_LENGTH => 250,
        TEMPLATE_TYPE      => 'HTMLTemplate',
        TEMPLATE_CONFIG    => undef,
        UTF8               => 1,
        $args{PARAMS} ? %{$args{PARAMS}} : (),
    };

    my $self = $class->SUPER::new(%args);

    # setup the template configs
    my $path = catdir((splitpath($INC{'CGI/Application/Search.pm'}))[1], 'Search', 'templates',);
    $self->param('DEFAULT_TEMPLATE_PATH' => $path);
    my %tmpl_config = (
        default_type                => $self->param('TEMPLATE_TYPE'),
        auto_add_template_extension => 0,
        include_paths               => [$self->tmpl_path, $path],
        HTMLTemplate                => {
            global_vars       => 1,
            loop_context_vars => 1,
            die_on_bad_params => 0,
            associate         => $self,
        },
        HTMLTemplateExpr => {
            global_vars       => 1,
            loop_context_vars => 1,
            die_on_bad_params => 0,
            associate         => $self,
        },
        TemplateToolkit => {
            ABSOLUTE       => 1,
            DEBUG_PROVIDER => 1,
            DEBUG          => 1,
        },
    );

    # add any overriding TEMPLATE_CONFIG options
    if ($self->param('TEMPLATE_CONFIG')) {
        $tmpl_config{$self->param('TEMPLATE_TYPE')} =
          {%{$tmpl_config{$self->param('TEMPLATE_TYPE')}}, %{$self->param('TEMPLATE_CONFIG')},};
    }
    $self->template->config(%tmpl_config);
    return $self;
}

sub setup {
    my $self = shift;
    $self->start_mode('show_search');
    $self->run_modes(
        [
            qw(
              show_search
              perform_search
              highlight_remote_page
              highlight_local_page
              suggestions
              )
        ]
    );
}

sub generate_search_query {
    my $self     = shift;
    my $keywords = shift;
    my $q        = $self->query;

    # create a new swish-e search object
    my $search = $keywords || '';
    $search =~ s/=/\=/g;    # escape '=' just in case

    # add any EXTRA_PROPERTIES to the search
    if ($self->param('EXTRA_PROPERTIES')) {
        foreach my $prop (@{$self->param('EXTRA_PROPERTIES')}) {
            my $value = $q->param($prop);
            $search .= " and $prop=($value)" if defined $value && length $value;
        }
    }

    return $search || $BLANK_SEARCH;
}

sub suggested_words {
    my ($self, $phrase) = @_;

    # just get the last word in this phrase
    my @phrase_words = split(/\s+/, $phrase);
    my $word = pop(@phrase_words);

    my $want_to_cache = $self->param('AUTO_SUGGEST_CACHE');
    my $file          = $self->param('AUTO_SUGGEST_FILE');
    my @suggestions;

    if (!$file) {
        warn "AUTO_SUGGEST_FILE was not specified!";
        return [];
    } elsif (!-r $file) {
        warn "AUTO_SUGGEST_FILE $file is not readable!";
        return [];
    }

    # if we are going to use the cache (meaning we want to use
    # it and there's up-to-date data in there)
    my $file_mod_time = (stat($file))[9];
    if (    $want_to_cache
        and @SUGGEST_CACHE
        and $SUGGEST_CACHE_TIME >= $file_mod_time)
    {
        foreach my $cached (@SUGGEST_CACHE) {

            # if it starts with this $word
            if (index($cached, lc $word) == 0) {
                push(@suggestions, $cached);

                # else if this is the first mis-match
            } elsif (@suggestions) {
                last;
            }

            # if we have a limit and we've reached it
            # don't do any more
            if (    $self->param('AUTO_SUGGEST_LIMIT')
                and @suggestions >= $self->param('AUTO_SUGGEST_LIMIT'))
            {
                last;
            }
        }

        # else we don't have anything cached, so just load from the file
    } else {

        # reset it if we want to cache
        if ($want_to_cache) {
            @SUGGEST_CACHE      = ();
            $SUGGEST_CACHE_TIME = time();
        }

        # read each line from the AUTO_SUGGEST_FILE
        my $IN;
        open($IN, '<', $file)
          or die "Could not open $file for reading! $!";

        # now look at each line
      LINE: while (my $line = <$IN>) {

            # if we want to cache the words in this file
            if ($want_to_cache) {
                chomp($line);
                push(@SUGGEST_CACHE, $line);
            }

            # if it starts with this $word
            if (index($line, lc $word) == 0) {
                chomp($line) unless ($want_to_cache);
                push(@suggestions, $line);

                # else if we aren't caching, and this is the first mis-match
                # then we want to finish and close the file
            } elsif (@suggestions && !$want_to_cache) {
                last LINE;
            }

            # if we have a limit and we've reached it
            # don't do any more
            if (    $self->param('AUTO_SUGGEST_LIMIT')
                and @suggestions >= $self->param('AUTO_SUGGEST_LIMIT'))
            {
                last;
            }
        }
        close($IN)
          or die "Could not close $file! $!";
    }

    # if we have something in the phrase that's not
    # in the word, add the phrase before the suggestion
    if (@phrase_words) {
        my $prefix = join(' ', @phrase_words);
        @suggestions = map { "$prefix $_" } @suggestions;
    }
    return \@suggestions;
}

#-------------------------PRIVATE METHODS-----------------------
sub _process_results {
    my ($self, $swish, $search, $results, $search_query) = @_;

    # now let's go through the results and build our loop
    my @result_loop = ();
    my $count       = 0;

    # while we still have more results
    while (my $current = $results->NextResult) {
        my %tmp = (
            reccount    => $current->Property('swishreccount'),
            rank        => $current->Property('swishrank'),
            title       => $current->Property('swishtitle'),
            path        => $current->Property('swishdocpath'),
            size        => format_bytes($current->Property('swishdocsize')),
            description => $current->Property('swishdescription') || '',
            last_modified =>
              localtime($current->Property('swishlastmodified'))->strftime('%B %d, %Y'),
        );

        # now add any EXTRA_PROPERTIES that we want to show
        if ($self->param('EXTRA_PROPERTIES')) {
            $tmp{$_} = eval { $current->Property($_) }
              foreach (@{$self->param('EXTRA_PROPERTIES')});
        }
        if ($self->param('EXTRA_RANGE_PROPERTIES')) {
            $tmp{$_} = eval { $current->Property($_) }
              foreach (@{$self->param('EXTRA_RANGE_PROPERTIES')});
        }

        my $description = $tmp{description};
        if ($description) {

            # if we want to zero in on the context
            if ($self->param('DESCRIPTION_CONTEXT')) {

                # get the keywords from the swish search
                my @keywords = ();
                foreach my $kw ($results->ParsedWords($self->param('SWISHE_INDEX'))) {

                    # remove boolean operators 'and', 'or' and 'not'
                    my $lc_kw = lc($kw);
                    if ($lc_kw ne 'and' && $lc_kw ne 'or' && $lc_kw ne 'not') {
                        push(@keywords, $kw);
                    }
                }

                # now get the context
                my $context = Text::Context->new($description, @keywords,);
                $description = $context->as_text();
            }

            # if we want to highlight the description
            if ($self->param('HIGHLIGHT') && $search_query && $search_query ne $BLANK_SEARCH) {
                eval { require Search::Tools::HiLiter };
                if ($@) {
                    warn "Could not load Search::Tools::HiLiter so no hilighting will be done: $@";
                } else {
                    my $hl = Search::Tools::HiLiter->new(
                        tag    => $self->param('HIGHLIGHT_TAG'),
                        class  => $self->param('HIGHLIGHT_CLASS'),
                        colors => $self->param('HIGHLIGHT_COLORS'),
                        query  => $search_query,
                    );
                    $description = $hl->plain($description);
                }
            }

            # now make sure it's the appropriate length
            $tmp{description} = substr($description, 0, $self->param('DESCRIPTION_LENGTH'));
        }
        push(@result_loop, \%tmp);

        # only go as far as the number per page
        ++$count;
        last if ($count == $self->param('PER_PAGE'));
    }
    return \@result_loop;
}

sub _get_search_terms {
    my ($self, $swish, $search, $results, $keywords) = @_;
    my @phrases = ();
    my %terms   = ();

    while ($keywords =~ /\G\s*"([^"]+)"/g) {
        push(@phrases, $1);
    }

    $keywords =~ s/"[^"]+?"//g;

    # remove stop words from highlighting
    # for some reason swish-e doesn't remove boolean operators as stop words... which
    # is probably good so that they actually get used in the searches, but still...
    my %stop_words = ();
    foreach my $word ($results->RemovedStopwords($self->param('SWISHE_INDEX')), 'and', 'or', 'not')
    {
        $stop_words{$word} = 1;
    }
    $stop_words{$_} = 1 foreach qw(and or not);

    for my $word (split(/\s+/, $keywords)) {
        if ($word) {
            next if $stop_words{$word};
            $terms{$word} = 1;
        }
    }

    # now look at the stems of these words
    $terms{$swish->fuzzify($swish->index_names, $_)->WordList} = 1 foreach (keys %terms);
    return keys %terms, @phrases;
}

# create a loop of pages with the first page, at most five pages before
# the current page, the current page, at most five pages after the current page
# and then the last page
sub _get_paging_vars {
    my ($self, $results) = @_;
    my @pages = ();

    # create my pager from the 'page' parameter in CGI or just use the first page
    my $page_num = $self->query->param('page') || 1;
    my $pager = Data::Page->new($results->Hits, $self->param('PER_PAGE'), $page_num);

    # go to the result that we want to look at first
    $results->SeekResult($pager->first - 1);

    # now let's create the paging summary vars
    $self->param('total_entries' => $pager->total_entries);
    $self->param('start_num'     => $pager->first);
    $self->param('stop_num'      => $pager->last);
    $self->param('next_page'     => $pager->next_page);
    $self->param('prev_page'     => $pager->previous_page);
    $self->param('first_page'    => $pager->first_page eq $page_num);
    $self->param('last_page'     => $pager->last_page eq $page_num);

    foreach (($page_num - 5) .. ($page_num + 5)) {
        # if we are in a real range
        if (($_ > 0) && ($_ <= ceil($pager->total_entries / $self->param('PER_PAGE')))) {
            my %hash = (page_num => $_, current => $_ eq $page_num);
            push(@pages, \%hash);
        }
    }
    $self->param(pages => \@pages) if ($#pages);
}

1;

__END__