package OpenGuides::SuperSearch;
use strict;
our $VERSION = '0.05';

use CGI qw( :standard );
use CGI::Wiki::Plugin::Locator::UK;
use File::Spec::Functions qw(:ALL);
use OpenGuides::Template;
use OpenGuides::Utils;
use Parse::RecDescent;

=head1 NAME

OpenGuides::SuperSearch - Search form generation and processing for OpenGuides.

=head1 DESCRIPTION

Does search stuff for OpenGuides.  Distributed and installed as part of
the OpenGuides project, not intended for independent installation.
This documentation is probably only useful to OpenGuides developers.

=head1 SYNOPSIS

  use CGI;
  use Config::Tiny;
  use OpenGuides::SuperSearch;

  my $config = Config::Tiny->read( "wiki.conf" );
  my $search = OpenGuides::SuperSearch->new( config => $config );
  my %vars = CGI::Vars();
  $search->run( vars => \%vars );

=head1 METHODS

=over 4

=item B<new>

  my $config = Config::Tiny->read( "wiki.conf" );
  my $search = OpenGuides::SuperSearch->new( config => $config );

=cut

sub new {
    my ($class, %args) = @_;
    my $config = $args{config};
    my $self   = { config => $config };
    bless $self, $class;

    my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );

    $self->{wiki}     = $wiki;
    $self->{wikimain} = $config->{_}{script_url} . $config->{_}{script_name};
    $self->{css}      = $config->{_}{stylesheet_url};
    $self->{head}     = $config->{_}{site_name} . " Search";

    my $locator = CGI::Wiki::Plugin::Locator::UK->new;
    $wiki->register_plugin( plugin => $locator );
    $self->{locator} = $locator;

    return $self;
}

=item B<run>

  my %vars = CGI::Vars();
  $search->run(
                vars           => \%vars,
                return_output  => 1,   # defaults to 0
                return_tt_vars => 1,  # defaults to 0
              );

The C<return_output> parameter is optional.  If supplied and true, the
stuff that would normally be printed to STDOUT will be returned as a
string instead.

The C<return_tt_vars> parameter is also optional.  If supplied and
true, the template is not processed and the variables that would have
been passed to it are returned as a hash.  This parameter takes
precedence over C<return_output>.

These two parameters exist to make testing easier; you probably don't
want to use them in production.

=back

=cut

sub run {
    my ($self, %args) = @_;
    $self->{return_output}  = $args{return_output}  || 0;
    $self->{return_tt_vars} = $args{return_tt_vars} || 0;
    my %vars = %{ $args{vars} || {} };
    my %tt_vars;

    $tt_vars{ss_version}  = $VERSION;
    $tt_vars{ss_info_url} = 'http://london.openguides.org/?Search_Script';

    # Strip out any non-digits from dist and OS co-ords; lat and long
    # also allowed '-' and '.'
    foreach my $param( qw( lat long ) ) {
        if ( defined $vars{$param} ) {
            $vars{$param} =~ s/[^-\.0-9]//g;
            # will check for definedness later as can be 0.
            delete $vars{$param} if $vars{$param} eq "";
	}
    }
    foreach my $param ( qw( os_x os_y distance_in_metres ) ) {
        if ( defined $vars{$param} ) {
            $vars{$param} =~ s/[^0-9]//g;
            # will check for definedness later as can be 0.
            delete $vars{$param} if $vars{$param} eq "";
	}
    }

    # Strip leading and trailing whitespace from search text.
    $vars{search} ||= ""; # avoid uninitialised value warning
    $vars{search} =~ s/^\s*//;
    $vars{search} =~ s/\s*$//;

    # Do we have an existing search? if so, do it.
    my $doing_search;
    if ( $vars{search}
         or ( ( (defined $vars{lat} && defined $vars{long})
                or (defined $vars{os_x} && defined $vars{os_y}) )
              && defined $vars{distance_in_metres} )
    ) {
        $doing_search = 1;
        $tt_vars{search_terms} = $vars{search};
        $tt_vars{dist} = $vars{distance_in_metres};
        foreach my $param ( qw( lat long os_x os_y ) ) {
            $tt_vars{$param} = $vars{$param};
	}
        $self->_perform_search( vars => \%vars );
    }

    if ( $self->{error} ) {
        $tt_vars{error_message} = $self->{error};
    } elsif ( $doing_search ) {
        my @results = values %{ $self->{results} || {} };
        my $numres = scalar @results;

        # For 0 or many we display results, for 1 we redirect to that page.
        if ( $numres == 1 && !$self->{return_tt_vars}) {
            my $node = $results[0]{name};
            my $output = CGI::redirect( $self->{wikimain} . "?"
                                        . CGI::escape($node) );
            return $output if $self->{return_output};
            print $output;
            exit;
        } else {
            # We browse through the results a page at a time.

            # Figure out which results we're going to be showing on this
            # page, and what the first one for the next page will be.
            my $startpos = $vars{next} || 0;
            $tt_vars{first_num} = $numres ? $startpos + 1 : 0;
            $tt_vars{last_num}  = $numres > $startpos + 20
                                    ? $startpos + 20
                                    : $numres;
            $tt_vars{total_num} = $numres;
            if ( $numres > $startpos + 20 ) {
                $tt_vars{next_page_startpos} = $startpos + 20;
            }

            # Sort the results - by distance if we're searching on that
            # or by score otherwise.
            if ( $vars{distance_in_metres} ) {
                @results = sort { $a->{distance} <=> $b->{distance} } @results;
	    } else {
                @results = sort { $a->{score} <=> $b->{score} } @results;
            }

            # Now snip out just the ones for this page.  The -1 is
            # because arrays index from 0 and people from 1.
            my $from = $tt_vars{first_num} ? $tt_vars{first_num} - 1 : 0;
            my $to   = $tt_vars{last_num} - 1; # kludge to empty arr for no res
            @results = @results[ $from .. $to ];

            $tt_vars{results} = \@results;
        }
    }

    $self->process_template( tt_vars => \%tt_vars );
}

# thin wrapper around OpenGuides::Template
sub process_template {
    my ($self, %args) = @_;
    my $tt_vars = $args{tt_vars} || {};

    $tt_vars->{not_editable} = 1;

    return %$tt_vars if $self->{return_tt_vars};

    my $output =  OpenGuides::Template->output(
                                                wiki     => $self->{wiki},
                                                config   => $self->{config},
                                                template => "supersearch.tt",
                                                vars     => $tt_vars,
                                              );
    return $output if $self->{return_output};

    print $output;
    return 1;
}

# method to populate $self with text of nodes potentially matching a query
# This could contain many more nodes than actually match the query
sub _prime_wikitext {
    my ($self, $op, @leaves) = @_;
    my $wiki = $self->{wiki};

    if ($op =~ /AND|OR/) {
	# Recurse into parse tree for boolean op nodes
	$self->_prime_wikitext(@$_) for @leaves;
    } elsif ($op eq 'NOT') {
	$self->_prime_wikitext(@leaves);
    } elsif ($op eq 'word') {
	foreach (@leaves) {
	    # Search title and body.
	    my %results = $wiki->search_nodes( $_ );
	    foreach my $node ( keys %results ) {
		next unless $node; # Search::InvertedIndex goes screwy sometimes
		my $key = $wiki->formatter->node_name_to_node_param( $node );
		my $text = $node . " " . $wiki->retrieve_node( $node );
		$self->{wikitext}{$key} ||= $self->_mungepage( $text );
	    }
	}

	my $meta_title = join '_',@leaves;
	my $matchstr = join ' ',@leaves;

	# Search categories.
	my @catmatches = $wiki->list_nodes_by_metadata(
				 metadata_type  => "category",
				 metadata_value => $meta_title,
				 ignore_case    => 1,
	);

	foreach my $node ( @catmatches ) {
		my $key = $wiki->formatter->node_name_to_node_param( $node );
		my $text = $node. " " . $wiki->retrieve_node( $node );
		$self->{wikitext}{$key} ||= $self->_mungepage( $text );
		# Append this category so the regex finds it later.
		$self->{wikitext}{$key} .= " [$matchstr]";
	}

	# Search locales.
	my @locmatches = $wiki->list_nodes_by_metadata(
				 metadata_type  => "locale",
				 metadata_value => $meta_title,
				 ignore_case    => 1,
	);
	foreach my $node ( @locmatches ) {
		my $key = $wiki->formatter->node_name_to_node_param( $node );
		my $text = $node. " " . $wiki->retrieve_node( $node );
		$self->{wikitext}{$key} ||= $self->_mungepage( $text );
		# Append this locale so the regex finds it later.
		$self->{wikitext}{$key} .= " [$matchstr]";
	}
    } # $op eq 'word'
} # sub _prime_wikitext
    
# method to filter out undesirable markup from the raw wiki text
sub _mungepage {
    my ($self, $text) = @_;

    # Remove HTML tags (sort of)
    $text =~ s/<.*?>//g;

    # Change WikiLinks into plain text
    $text =~ s/\[\[(.*?)\|(.*?)\]\]/$2/g;  # titled WikiLink
    $text =~ s/\[\[(.*?)\]\]/$1/g;         # normal WikiLink
    $text =~ s/\[(.*?) (.*?)\]/$2/g;       # titled web link
    
    # Remove WikiFormatting
    $text =~ s/=//g;      # heading
    $text =~ s/'''//g;    # bold
    $text =~ s/''//g;     # italic
    $text =~ s/\*//g;     # bullet point
    $text =~ s/----//g;   # horizontal rule

    # Change "#REDIRECT" to something prettier
    $text =~ s/\#REDIRECT/\(redirect\)/g;

    return $text;
}

# Populates either $self->{error} or $self->{results}
sub _perform_search {
    my ($self, %args) = @_;
    my %vars = %{ $args{vars} || {} };

    my $srh = $vars{search};

    # Perform text search if search terms entered, otherwise collect up
    # all nodes to check distance.
    if ( $srh ) {
        # Check for only valid characters in tainted search param
        # (quoted literals are OK, as they are escaped)
        if ( $srh !~ /^("[^"]*"|[\w \-',()!*%\[\]])+$/i) { #"
            $self->{error} = "Search expression contains invalid character(s)";
            return;
        }
        $self->_build_parser && exists($self->{error}) && return;
        $self->_apply_parser($srh);
    } else {
        my $wiki = $self->{wiki};
        my @all_nodes = $wiki->list_all_nodes;
        my $formatter = $wiki->formatter;
        my %results = map {
              my $name = $formatter->node_name_to_node_param( $_ );
              my %data = $wiki->retrieve_node( $_ );
              my $content = $wiki->format( @data{ qw( content metadata ) } );
              $content = $self->_mungepage( $content );
              my $summary = substr( $content, 0, 150 );
              $name => {
                         name    => $name,
                         score   => 0,
                         summary => $summary,
                       }
                          } @all_nodes;
        $self->{results} = \%results;
    }

    # Now filter by distance if required.
    my ($os_x, $os_y, $lat, $long, $dist) =
                         @vars{ qw( os_x os_y lat long distance_in_metres ) };
    if ( ( (defined $lat && defined $long)
           or (defined $os_x and defined $os_y)
                                                ) && $dist ) {
        my %results = %{ $self->{results} || {} };
        my @close;
        if ( defined $lat && defined $long ) {
            @close = $self->{locator}->find_within_distance(
                                                             lat    => $lat,
                                                             long   => $long,
                                                             metres => $dist,
                                                           );
	} else {
            @close = $self->{locator}->find_within_distance(
                                                             os_x   => $os_x,
                                                             os_y   => $os_y,
                                                             metres => $dist,
                                                           );
	}
        my %close_hash = map { $_ => 1 } @close;
        my @nodes = keys %results;
        foreach my $node ( @nodes ) {
            my $unmunged = $node; # KLUDGE
            $unmunged =~ s/_/ /g;
            if ( exists $close_hash{$unmunged} ) {
                my $distance;
	        if ( defined $lat && defined $long ) {
                    $distance = $self->{locator}->distance(
                                                 from_lat  => $lat,
                                                 from_long => $long,
					         to_node   => $unmunged,
                                                 unit      => "metres"
                                                          );
		} else {
                    $distance = $self->{locator}->distance(
                                                 from_os_x => $os_x,
                                                 from_os_y => $os_y,
					         to_node   => $unmunged,
                                                 unit      => "metres"
                                                          );
                }
                $results{$node}{distance} = $distance;                
	    } else {
                delete $results{$node};
            }
	}
        $self->{results} = \%results;
    }      
}

sub _build_parser {
    my $self = shift;

    # Build RecDescent grammar for search syntax.

    my $parse = Parse::RecDescent->new(q{

        search: list eostring {$return = $item[1]}

	list: comby(s)
            {$return = (@{$item[1]}>1) ? ['AND', @{$item[1]}] : $item[1][0]}

        comby: <leftop: term ',' term> 
            {$return = (@{$item[1]}>1) ? ['OR', @{$item[1]}] : $item[1][0]}

        term: '(' list ')' {$return = $item[2]}
            |        '-' term {$return = ['NOT', @{$item[2]}]}
#           |        word ':' term {$return = ['meta', $item[1], $item[3]];}
            |        '"' word(s) '"' {$return = ['word', @{$item[2]}]}
            |        word {$return = ['word', $item[1]]}
            |        '[' word(s) ']' {$return = ['title', @{$item[2]}]}
#	    |        m([/|\\]) m([^$item[1]]+) $item[1]
#	    		{ $return = ['regexp', qr($item[2])] }

        word: /[\w'*%]+/ {$return = $item[1]}
            
        eostring: /^\Z/
	
    });

    unless ( $parse ) {
        warn $@;
        $self->{error} = "can't create parse object";
        return;
    }
    
    $self->{parser} = $parse;
    return $self;
}

sub _apply_parser {
    my ($self,$search) = @_;
	
    # Turn search string into parse tree
    my $tree = $self->{parser}->search($search);
    unless ( $tree ) {
        $self->{error} = "Search syntax error";
        return;
    }

    #Prime the search
    $self->_prime_wikitext(@$tree);

    # Apply search and return results
    my %results = $self->_matched_items( tree => $tree );
    $self->{results} = \%results;
    return $self;
}

# called with parse tree
sub _matched_items {
    my ($self, %args) = @_;
    my $tree = $args{tree};
    my @tree_arr = @$tree;
    my $op = shift @tree_arr;
    my $meth = 'matched_'.$op;
    return $self->can($meth) ? $self->$meth(@tree_arr) : undef;
}



=head1 INPUT

=over

=item B<word>

a single word will be matched as-is. For example, a search on

  escalator

will return all pages containing the word "escalator".

=cut

sub matched_word {
    my $self = shift;
    my $wmatch = join '\W+',@_;
    $wmatch =~ s/%/\\w/g;
    $wmatch =~ s/\*/\\w*/g;

    return $self->_do_search($wmatch);
}

=item B<AND searches>

A list of words with no punctuation will be ANDed, for example:

  restaurant vegetarian

will return all pages containing both the word "restaurant" and the word
"vegetarian".

=cut

sub matched_AND {
    my ($self, @subsearches) = @_;

    # Do the first subsearch.
    my %results = $self->_matched_items( tree => $subsearches[0] );

    # Now do the rest one at a time and remove from the results anything
    # that doesn't come up in each subsearch.  Results that survive will
    # have a score that's the sum of their score in each subsearch.
    foreach my $tree ( @subsearches[ 1 .. $#subsearches ] ) {
        my %subres = $self->_matched_items( tree => $tree );
        my @pages = keys %results;
        foreach my $page ( @pages ) {
	    if ( exists $subres{$page} ) {
                $results{$page}{score} += $subres{$page};
	    } else {
                delete $results{$page};
            }
	}
    }

    return %results;
}

=item B<OR searches>

A list of words separated by commas (and optional spaces) will be ORed, 
for example:

  restaurant, cafe

will return all pages containing either the word "restaurant" or the
word "cafe".

=cut

sub matched_OR {
    my ($self, @subsearches) = @_;

    # Do all the searches.  Results will have a score that's the sum
    # of their score in each subsearch.
    my %results;
    foreach my $tree ( @subsearches ) {
        my %subres = $self->_matched_items( tree => $tree );
        foreach my $page ( keys %subres ) {
            if ( $results{$page} ) {
                $results{$page}{score} += $subres{$page}{score};
	    } else {
                $results{$page} = $subres{$page};
            }
        }
    }
    return %results;
}

=item B<NOT searches>

Words and phrases preceded by a minus sign are excluded, for example:

  restaurant -expensive

will return all pages that contain the word "restaurant" and do not 
contain "expensive".

Note that a NOT search is used to qualify an existing search, so you
cannot use -foo standalone to give you all pages without foo.

=cut

# matched_NOT - Form complement of hash against %wikitext
sub matched_NOT {
    my $self = shift;
    my %excludes = $self->_matched_items(tree => \@_);
    my %out = map {$_=>[0]} keys %{ $self->{wikitext} };

    delete $out{$_} for keys %excludes;
    return %out;
}

=item B<phrase searches>

Enclose phrases in double quotes, for example:

  "meat pie"

will return all pages that contain the exact phrase "meat pie" - not pages
that only contain, for example, "apple pie and meat sausage".

=cut

# matched_literal - we have a literal.
sub matched_literal {
    my $self = shift;
    my $lit = shift;
    $self->_do_search(quotemeta $lit);
}

sub intersperse {
    my $self = shift;
    my $pagnam = shift;
    
    my @mixed;   
    my $score = 0;
    
    for my $j (@_) {
        if (exists $j->{$pagnam}) {
            $score += $j->{$pagnam}[0];
            push @mixed,[$_,$j->{$pagnam}[$_]] for 1..$#{$j->{$pagnam}};
        }
    }
    
    my @interspersed = map $_->[1], sort {$a->[0] <=> $b->[0]} @mixed;
    
    unshift @interspersed,$score;
    
    return \@interspersed;
}

sub _do_search {
    my ($self, $wmatch) = @_;

    # Build regexp from parameter. Gobble upto 60 characters of
    # context either side.
    my $wexp = qr/\b.{0,60}\b$wmatch\b.{0,60}\b/is;
    my %results;

    # Search every wiki page for matches
    my %wikitext = %{ $self->{wikitext} || {} };
    while (my ($k,$v) = each %wikitext) {
        my @out;
        for ($v =~ /$wexp/g) {
            my $match .= "...$_...";
            $match =~ s/<[^>]+>//gs;
            $match =~ s!\b($wmatch)\b!<b>$&</b>!i;
            push @out,$match;
        }
        my $temp = $k;
        $temp =~ s/_/ /g;

        # Compute score and create summary.
        my $score = scalar @out;
        $score +=10 if $temp =~ /$wexp/;
        $results{$k} = {
                         score   => $score,
                         summary => join( "", @out ),
                         name    => $k,
                       }
          if $score;
    }
    
    return %results;
}

=head1 AUTHOR

The OpenGuides Project (openguides-dev@openguides.org)

=head1 COPYRIGHT

     Copyright (C) 2003-4 The OpenGuides Project.  All Rights Reserved.

The OpenGuides distribution is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<OpenGuides>

=cut

1;

__END__

# Not sure what this sub is meant to do.  It doesn't seem to match on [foo]
sub matched_title {
    my $wmatch = join '\W+',@_;
    $wmatch =~ s/%/\\w/g;
    $wmatch =~ s/\*/\\w*/g;

    my $wexp = qr/\b$wmatch\b/is;
    my %res;
    
    for (keys %wikitext) {
        $res{$_} = [10] if /$wexp/g;
    }
    
    %res;
}
