$limits $sorts $date_ranges_select
EOF
}
#=====================================================================
# This routine creates the results header display
#
#
#
#
sub results_header {
my $results = shift;
my $config = $results->{config};
my $q = $results->{q};
my $limits = '';
if ( $results->{DateRanges_time_low} && $results->{DateRanges_time_high} ) {
my $low = scalar localtime $results->{DateRanges_time_low};
my $high = scalar localtime $results->{DateRanges_time_high};
$limits = <
EOF
}
#=====================================================================
# This routine formats a single result
#
#
sub show_result {
my ($results, $result ) = @_;
my $conf = $results->{conf};
my $DocTitle = $conf->{title_property} || 'swishtitle';
my $title = $result->{$DocTitle} || $result->{swishdocpath};
my $props = '';
if ( $conf->{display_props} ) {
my $length = 0;
for ( @{$conf->{display_props}} ) {
my $label = $conf->{name_labels}{$_} || $_;
$length = length($label) if length($label) > $length;
}
$props = join "\n",
'
Results limited to dates $low to $high
EOF
}
my $links = '';
$links .= ' Page:' . $results->{PAGES}
if $results->{PAGES};
$links .= qq[ Previous $results->{PREV_COUNT}]
if $results->{PREV_COUNT};
$links .= qq[ Next $results->{NEXT_COUNT}]
if $results->{NEXT_COUNT};
$results->{LINKS} = $links;
$links = qq[$links
$links
$limits
Results for $user_query
$results->{FROM} to $results->{TO} of $results->{HITS} results.
Run time: $results->{RUN_TIME} |
Search time: $results->{SEARCH_TIME}
',
map ( {
'
';
}
my $PathPrePend = $conf->{prepend_path} || '';
my $description = '';
if ( $conf->{description_prop} ) {
$description = $result->{$conf->{description_prop}} || '';
}
return <'
. ( $conf->{name_labels}{$_} || $_ )
. ': '
. ''
. $result->{$_}
. ''
. '
Response brought to you by MOD_PERL perl.apache.org'
: '';
return <
';
}
my $sorts = '';
if ( $conf->{sorts} ) {
$sorts = join "\n",
'Sort by:',
'',
qq[Reverse Sort];
}
return ( $check, $limits, $sorts );
}
#==================================================
# Format and return the date range options
#
#--------------------------------------------------
sub get_date_ranges {
my ( $q, $results ) = @_;
my $conf = $results->{conf};
return '' unless $conf->{date_ranges};
# pass parametes, and a hash to store the returned values.
my %fields;
DateRanges::DateRangeForm( $q, $conf->{date_ranges}, \%fields );
# Set the layout:
my $string = '
Limit to: '
. ( $fields{buttons} ? "$fields{buttons}
" : '' )
. ( $fields{date_range_button} || '' )
. ( $fields{date_range_low}
? " $fields{date_range_low} through $fields{date_range_high}"
: '' );
return $string;
}
#================================================================================
# Parse out the date limits from the form or from GET request
#
#---------------------------------------------------------------------------------
sub get_date_limits {
my $results = shift;
my $q = $results->{q};
# Are date ranges enabled?
return 1 unless $results->{conf}{date_ranges};
eval { require DateRanges };
if ( $@ ) {
$results->{MESSAGE} = 'Missing module "DateRanges"';
delete $results->{conf}{date_ranges};
return 0;
}
my %limits;
unless ( DateRanges::DateRangeParse( $q, \%limits ) ) {
$results->{MESSAGE} = $limits{DateRanges_error} || 'Bad date range selection';
return 0;
}
$results->{DateRanges_time_low} = $limits{DateRanges_time_low};
$results->{DateRanges_time_high} = $limits{DateRanges_time_high};
# Allow searchs just be date if not "All dates" search
${$results->{query}} = $NotAWord if !${$results->{query}} && $limits{DateRanges_time_high};
my $conf = $results->{conf};
my $sh = $results->{sh};
my $limit_prop = $conf->{date_ranges}{property_name};
# $$$ need to fix for generalized interface!
if ( $limits{DateRanges_time_low} && $limits{DateRanges_time_high} ) {
push @{$sh->{commands}}, ( '-L', 'swishlastmodified', $limits{DateRanges_time_low}, $limits{DateRanges_time_high} );
}
return 1;
}
#================================================================
# Set the sort order
#----------------------------------------------------------------
sub set_sort_order {
my $results = shift;
my $q = $results->{q};
my $sh = $results->{sh};
my $conf = $results->{conf};
return 1 unless $conf->{sorts};
# Now set sort option - if a valid option submitted (or you could let swish-e return the error).
my %sorts = map { $_, 1 } @{$conf->{sorts}};
if ( $q->param('sort') && $sorts{ $q->param('sort') } ) {
my $direction = $q->param('sort') eq 'swishrank'
? $q->param('reverse') ? 'asc' : 'desc'
: $q->param('reverse') ? 'desc' : 'asc';
# $sh->{sortorder} = ['-s', $q->param('sort'), $direction ];
push @{$sh->{commands}}, ( '-s', $q->param('sort'), $direction );
if ( $conf->{secondary_sort} && $q->param('sort') ne $conf->{secondary_sort}[0] ) {
# push @{$sh->{sortorder}}, @SecondarySort;
push @{$sh->{commands}}, ref $conf->{secondary_sort} ? @{ $conf->{secondary_sort} } : $conf->{secondary_sort};
}
} else {
$results->{MESSAGE} = 'Invalid Sort Option Selected';
return;
}
return 1;
}
#============================================
# This function parses the CGI parameters,
# and runs the query if a query was entered
#
# Pass:
# $q - a CGI object
#
# Returns:
# a reference to a hash with an error message or results
#
sub run_query {
my ( $q, $conf ) = @_;
# set up the query string to pass to swish.
my $query = $q->param('query') || '';
for ( $query ) { # trim the query string
s/\s+$//;
s/^\s+//;
}
# initialize the request search hash
my $sh = {
prog => $conf->{swish_binary},
maxhits => $conf->{page_size},
q => $q,
commands => [], # commands passed to swish
query => \$query,
};
# Save the index file
push @{$sh->{commands}}, '-f', ref $conf->{swish_index} ? @{ $conf->{swish_index} } : $conf->{swish_index};
# initialize the results hash (should be called "self")
my %results = (
conf => $conf,
q => $q,
query => \$query,
sh => $sh, # request hash
);
# Read in the date limits, if any.
return \%results unless get_date_limits( \%results );
unless ( $query ) {
$results{MESSAGE} = 'Please enter a query string' if $q->param('submit');
return \%results;
}
if ( length( $query ) > 100 ) {
$results{MESSAGE} = 'Please enter a shorter query';
return \%results;
}
my $query_simple = $query; # without metaname
$q->param('query', $query ); # clean up the query, if needed.
# Adjust the query string for metaname search
my $metaname = $q->param('metaname') || '';
if ( $metaname && $metaname ne 'ALL' ) {
unless ( grep { $metaname eq $_ } @{$conf->{metanames}} ) {
$results{MESSAGE} = 'Bad MetaName provided';
return \%results;
}
# prepend metaname to search, if required.
$query = $metaname . "=($query)";
$sh->{metaname} = $metaname;
}
# Set the starting position
my $start = $q->param('start') || 0;
$start = 0 unless $start =~ /^\d+$/ && $start >= 0;
$sh->{startnum} = $start + 1;
# Set the sort option, if any
return \%results unless set_sort_order( \%results );
my $ret;
# Trap the call - not portable.
eval {
local $SIG{ALRM} = sub { die "Timed out\n" };
alarm 10;
$ret = run_swish( \%results );
};
# error conditions
if ( $@ ) {
$results{MESSAGE} = $@;
return \%results;
}
unless ( ref $ret ) {
$results{MESSAGE} = $ret;
return \%results;
}
if ( ! @{$ret->{FILES}} ) {
$results{MESSAGE} = 'Failed to find results';
return \%results;
}
# Build href for repeated search via GET
my $href = $q->script_name . '?' .
join( '&',
map { "$_=" . $q->escape( $q->param($_) ) }
grep { $q->param($_) } qw/query metaname sort reverse/
);
if ( $conf->{date_ranges} ) {
my $dr = DateRanges::GetDateRangeArgs( $q );
$href .= "&" . $dr if $dr;
}
my $hits = @{$ret->{FILES}};
# Return the template fields
my $results = {
%results, # results array as setup above (including {FILES}
QUERY => $q->escapeHTML( $query ),
QUERY_HREF => $href, # for running this query again
QUERY_SIMPLE=> $query_simple, # the query w/o any metanames - same as QUERY if metanames are not used
MY_URL => $q->script_name,
SHOWING => $hits,
HITS => $ret->{header}{'number of hits'} || 0,
RUN_TIME => $ret->{header}{'run time'} || 'unknown',
SEARCH_TIME => $ret->{header}{'search time'} || 'unknown',
FROM => $start + 1,
TO => $start + $hits,
MOD_PERL => $ENV{MOD_PERL},
};
set_page( $results, $q );
return $results;
}
#========================================================
# Sets prev and next page links.
# Feel free to clean this code up!
#
# Pass:
# $resutls - reference to a hash (for access to the headers returned by swish)
# $q - CGI object
#
# Returns:
# Sets entries in the $results hash
#
sub set_page {
my ( $results, $q ) = @_;
my $Page_Size = $results->{conf}{page_size};
my $start = $results->{FROM} - 1; # Current starting record
my $prev = $start - $Page_Size;
$prev = 0 if $prev < 0;
if ( $prev < $start ) {
$results->{PREV} = $prev;
$results->{PREV_COUNT} = $start - $prev;
}
my $last = $results->{HITS} - 1;
my $next = $start + $Page_Size;
$next = $last if $next > $last;
my $cur_end = $start + scalar @{$results->{FILES}} - 1;
if ( $next > $cur_end ) {
$results->{NEXT} = $next;
$results->{NEXT_COUNT} = $next + $Page_Size > $last
? $last - $next + 1
: $Page_Size;
}
# Calculate pages ( is this -1 correct here? )
my $pages = int (($results->{HITS} -1) / $Page_Size);
if ( $pages ) {
my @pages = 0..$pages;
my $max_pages = 10;
if ( @pages > $max_pages ) {
my $current_page = int ( $start / $Page_Size - $max_pages/2) ;
$current_page = 0 if $current_page < 0;
if ( $current_page + $max_pages - 1 > $pages ) {
$current_page = $pages - $max_pages;
}
@pages = $current_page..$current_page + $max_pages - 1;
unshift @pages, 0 if $current_page;
push @pages, $pages unless $current_page + $max_pages - 1 == $pages;
}
$results->{PAGES} =
join ' ', map {
my $page_start = $_ * $Page_Size;
my $page = $_ + 1;
$page_start == $start
? $page
: qq[$page];
} @pages;
}
}
#============================================
# Returns compiled regular expressions for matching
#
# Pass:
# Reference to headers hash
#
# Returns an array (or undef)
# $wordchar_regexp = used for splitting the text
# $extract_regexp = used to extract a word to match against
# $query_regexp = used for matching words
#
sub set_match_regexp {
my $header = shift;
my ($query, $wc, $ignoref, $ignorel ) =
@{$header}{'parsed words',qw/wordcharacters ignorefirstchar ignorelastchar/};
return unless $wc && $query; # Shouldn't happen
$wc = quotemeta $wc;
my $match_string =
join '|',
map { substr( $_, -1, 1 ) eq '*'
? quotemeta( substr( $_, 0, -1) ) . "[$wc]*?"
: quotemeta
}
grep { ! /^(and|or|not|["()=])$/oi }
split /\s+/, $query;
return unless $match_string;
for ( $ignoref, $ignorel ) {
if ( $_ ) {
$_ = quotemeta;
$_ = "([$_]*)";
} else {
$_ = '()';
}
}
$wc .= 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; # Warning: dependent on tolower used while indexing
# Now, wait a minute. Look at this more, as I'd hope that making a
# qr// go out of scope would release the compiled pattern.
return $ENV{MOD_PERL}
? (
qr/([^$wc]+)/, # regexp for splitting into swish-words
qr/^$ignoref([$wc]+?)$ignorel$/i, # regexp for extracting out the words to compare
qr/^(?:$match_string)$/, # regexp for comparing extracted words to query
# Must force lower case before testing
)
: (
qr/([^$wc]+)/o, # regexp for splitting into swish-words
qr/^$ignoref([$wc]+?)$ignorel$/oi, # regexp for extracting out the words to compare
qr/^(?:$match_string)$/o, # regexp for comparing extracted words to query
# Must force lower case before testing
);
}
#============================================
# Run swish-e and gathers headers and results
# Currently requires fork() to run.
#
# Pass:
# $sh - an array with search parameters
#
# Returns:
# a reference to a hash that contains the headers and results
# or possibly a scalar with an error message.
#
sub run_swish {
my $results = shift;
my $sh = $results->{sh};
my $conf = $results->{conf};
my $q = $results->{q};
my @properties;
my %seen;
# Gather up the properties specified
for ( qw/ title_property description_prop display_props / ) {
push @properties, ref $conf->{$_} ? @{$conf->{$_}} : $conf->{$_}
if $conf->{$_} && !$seen{$_}++;
}
my %display_props = map { $_, 1 } @properties;
# add in the default props - a number must be first
@properties = (qw/swishreccount swishrank swishdocpath/, @properties );
my $fh = gensym;
my $pid = open( $fh, '-|' );
die "Failed to fork: $!\n" unless defined $pid;
if ( !$pid ) { # in child
my @cmd = (
$sh->{prog},
-w => ${$sh->{query}},
@{$sh->{commands}},
-b => $sh->{startnum},
-m => $sh->{maxhits},
-H => 9,
-x => join( '\t', map { "<$_>" } @properties ) . '\n',
);
exec @cmd or die "Failed to exec '$sh->{prog}' Error:$!";
}
# read in from child
my %ret;
my @results;
my @regexps; # regular expressions used for highlighting
my $regexp_set;
my $stemmer_function;
my $highlight = $conf->{highlight_words} || 0;
my $highlight_prop = $conf->{description_prop} || 'swishdescription';
my $trim_prop = $highlight_prop;
my $meta = $sh->{metaname} || '';
# If a meta search, and it is also a display prop, then highlight that.
if ( $meta && $meta ne 'ALL' ) {
if ( $display_props{$meta} ) {
$highlight_prop = $meta;
} else {
$highlight = 0;
}
}
delete $display_props{swishdescription}; # This is to prevent running escapeHTML on this property -- so big, and storedescrition is stripped
$trim_prop = 0 if $highlight && $trim_prop eq $highlight_prop;
while (<$fh>) {
chomp;
# This will not work correctly with multiple indexes
if ( /^# ([^:]+):\s+(.+)$/ ) {
$ret{header}{ lc($1) } = $2;
next;
}
# return errors as text
return $1 if /^err:\s*(.+)/;
# Found a result
if ( /^\d/ ) {
my %h;
@h{@properties} = split /\t/;
push @results, \%h;
# This can't be escapeHTML'd
$h{save_swishdocpath} = $h{swishdocpath};
# Escape display properties (except swishdescription)
$h{$_} = $q->escapeHTML( $h{$_} ) for keys %display_props;
# Trim down the description if no highlight, or if highlighting some other property
# Not very nice. The highlighting code would limit by words
if ( $trim_prop && $h{$trim_prop} ) {
my $max = $conf->{max_chars} || 500;
if ( length $h{$trim_prop} > $max ) {
$h{$trim_prop} = substr( $h{$trim_prop}, 0, $max) . ' ...';
}
}
if ( $highlight && $highlight_prop && exists $h{$highlight_prop} ) {
# This is to prepare for highlighting - only do first time
unless ( $regexp_set++ ) {
@regexps = set_match_regexp( $ret{header} );
if ( $ret{header}{'stemming applied'} =~ /^(?:1|yes)$/i ) {
eval { require SWISH::Stemmer };
if ( $@ ) {
$ret{MESSAGE} = 'Stemmed index needs Stemmer.pm to highlight';
} else {
$stemmer_function = \&SWISH::Stemmer::SwishStem;
}
}
}
# Now do the actual highlighting
$h{$highlight_prop} =
highlight( $results, \$h{$highlight_prop}, $stemmer_function, @regexps );
}
}
# Might check for "\n." for end of results.
}
$results->{header} = $ret{header};
$results->{FILES} = \@results;
return $results;
}
#==========================================================================
# This routine highlights words in source text
# Source text must be plain text.
#
# This is a very basic highlighting routine that fails for phrase searches.
#
# The text returned contains highlighted words, plus a few words on either side to give
# context of the results.
#
# Pass:
# the text to highlight, a transformation function (normally a stemmer function)
# and pre-compiled regular expressions
#
# Returns:
# the highlighted text
#
sub highlight {
my ( $results, $text_ref, $stemmer_function, $wc_regexp, $extract_regexp, $match_regexp ) = @_;
my $last = 0;
my $Show_Words = $results->{conf}{show_words} || 10;
my $Occurrences = $results->{conf}{occurrences} || 5;
my $Max_Words = $results->{conf}{max_words} || 100;
my $On = $results->{conf}{highlight_on} || '';
my $Off = $results->{conf}{highlight_off} || '';
# Should really call unescapeHTML(), but then would need to escape from escaping.
my @words = split /$wc_regexp/, $$text_ref;
return 'No Content saved: Check StoreDescription setting' unless @words;
my @flags;
$flags[$#words] = 0; # Extend array.
my $occurrences = $Occurrences ;
my $pos = $words[0] eq '' ? 2 : 0; # Start depends on if first word was wordcharacters or not
while ( $Show_Words && $pos <= $#words ) {
if ( $words[$pos] =~ /$extract_regexp/ ) {
my ( $begin, $word, $end ) = ( $1, $2, $3 );
my $test = $stemmer_function
? $stemmer_function->($word)
: lc $word;
$test ||= lc $word;
# Not check if word matches
if ( $test =~ /$match_regexp/ ) {
$words[$pos] = "$begin$On$word$Off$end";
my $start = $pos - $Show_Words + 1;
my $end = $pos + $Show_Words - 1;
if ( $start < 0 ) {
$end = $end - $start;
$start = 0;
}
$end = $#words if $end > $#words;
$flags[$_]++ for $start .. $end;
# All done, and mark where to stop looking
if ( $occurrences-- <= 0 ) {
$last = $end;
last;
}
}
}
$pos += 2; # Skip to next wordchar word
}
my $dotdotdot = ' ...';
my @output;
my $printing;
my $first = 1;
my $some_printed;
if ( $Show_Words ) {
for my $i ( 0 ..$#words ) {
if ( $last && $i >= $last && $i < $#words ) {
push @output, $dotdotdot;
last;
}
if ( $flags[$i] ) {
push @output, $dotdotdot if !$printing++ && !$first;
push @output, $words[$i];
$some_printed++;
} else {
$printing = 0;
}
$first = 0;
}
}
if ( !$some_printed ) {
for my $i ( 0 .. $Max_Words ) {
last if $i >= $#words;
push @output, $words[$i];
}
}
push @output, $dotdotdot if !$printing;
return join '', @output;
}
1;
__END__
=head1 NAME
swish.cgi -- Example Perl script for searching with the SWISH-E search engine.
=head1 DESCRIPTION
C
Search Our Website
...
Now, you know that the program compiles and will run from the command line.
Next, try accessing the script from a web browser.
If you see the contents of the CGI script instead of its output then your web server is
not configured to run the script. You will need to look at settings like ScriptAlias, SetHandler,
and Options.
If an error is reported (such as Internal Server Error or Forbidden)
you need to locate your web server's error_log file
and carefully read what the problem is. Contact your web administrator for help.
=head1 Spidering
There are two ways to spider with swish-e. One uses the "http" input method that uses code that's
part of swish. The other way is to use the new "prog" method along with a perl helper program called
C