source: trunk/lib/OpenGuides/SuperSearch.pm @ 469

Last change on this file since 469 was 469, checked in by kake, 17 years ago

Added option of using Plucene for searching.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.0 KB
Line 
1package OpenGuides::SuperSearch;
2use strict;
3our $VERSION = '0.06';
4
5use CGI qw( :standard );
6use CGI::Wiki::Plugin::Locator::UK;
7use File::Spec::Functions qw(:ALL);
8use OpenGuides::Template;
9use OpenGuides::Utils;
10use Parse::RecDescent;
11
12=head1 NAME
13
14OpenGuides::SuperSearch - Search form generation and processing for OpenGuides.
15
16=head1 DESCRIPTION
17
18Does search stuff for OpenGuides.  Distributed and installed as part of
19the OpenGuides project, not intended for independent installation.
20This documentation is probably only useful to OpenGuides developers.
21
22=head1 SYNOPSIS
23
24  use CGI;
25  use Config::Tiny;
26  use OpenGuides::SuperSearch;
27
28  my $config = Config::Tiny->read( "wiki.conf" );
29  my $search = OpenGuides::SuperSearch->new( config => $config );
30  my %vars = CGI::Vars();
31  $search->run( vars => \%vars );
32
33=head1 METHODS
34
35=over 4
36
37=item B<new>
38
39  my $config = Config::Tiny->read( "wiki.conf" );
40  my $search = OpenGuides::SuperSearch->new( config => $config );
41
42=cut
43
44sub new {
45    my ($class, %args) = @_;
46    my $config = $args{config};
47    my $self   = { config => $config };
48    bless $self, $class;
49
50    my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
51
52    $self->{wiki}     = $wiki;
53    $self->{wikimain} = $config->{_}{script_url} . $config->{_}{script_name};
54    $self->{css}      = $config->{_}{stylesheet_url};
55    $self->{head}     = $config->{_}{site_name} . " Search";
56
57    my $locator = CGI::Wiki::Plugin::Locator::UK->new;
58    $wiki->register_plugin( plugin => $locator );
59    $self->{locator} = $locator;
60
61    return $self;
62}
63
64=item B<run>
65
66  my %vars = CGI::Vars();
67  $search->run(
68                vars           => \%vars,
69                return_output  => 1,   # defaults to 0
70                return_tt_vars => 1,  # defaults to 0
71              );
72
73The C<return_output> parameter is optional.  If supplied and true, the
74stuff that would normally be printed to STDOUT will be returned as a
75string instead.
76
77The C<return_tt_vars> parameter is also optional.  If supplied and
78true, the template is not processed and the variables that would have
79been passed to it are returned as a hash.  This parameter takes
80precedence over C<return_output>.
81
82These two parameters exist to make testing easier; you probably don't
83want to use them in production.
84
85=back
86
87=cut
88
89sub run {
90    my ($self, %args) = @_;
91    $self->{return_output}  = $args{return_output}  || 0;
92    $self->{return_tt_vars} = $args{return_tt_vars} || 0;
93    my %vars = %{ $args{vars} || {} };
94    my %tt_vars;
95
96    $tt_vars{ss_version}  = $VERSION;
97    $tt_vars{ss_info_url} = 'http://london.openguides.org/?Search_Script';
98
99    # Strip out any non-digits from dist and OS co-ords; lat and long
100    # also allowed '-' and '.'
101    foreach my $param( qw( lat long ) ) {
102        if ( defined $vars{$param} ) {
103            $vars{$param} =~ s/[^-\.0-9]//g;
104            # will check for definedness later as can be 0.
105            delete $vars{$param} if $vars{$param} eq "";
106        }
107    }
108    foreach my $param ( qw( os_x os_y distance_in_metres ) ) {
109        if ( defined $vars{$param} ) {
110            $vars{$param} =~ s/[^0-9]//g;
111            # will check for definedness later as can be 0.
112            delete $vars{$param} if $vars{$param} eq "";
113        }
114    }
115
116    # Strip leading and trailing whitespace from search text.
117    $vars{search} ||= ""; # avoid uninitialised value warning
118    $vars{search} =~ s/^\s*//;
119    $vars{search} =~ s/\s*$//;
120
121    # Do we have an existing search? if so, do it.
122    my $doing_search;
123    if ( $vars{search}
124         or ( ( (defined $vars{lat} && defined $vars{long})
125                or (defined $vars{os_x} && defined $vars{os_y}) )
126              && defined $vars{distance_in_metres} )
127    ) {
128        $doing_search = 1;
129        $tt_vars{search_terms} = $vars{search};
130        $tt_vars{dist} = $vars{distance_in_metres};
131        foreach my $param ( qw( lat long os_x os_y ) ) {
132            $tt_vars{$param} = $vars{$param};
133        }
134        $self->_perform_search( vars => \%vars );
135    }
136
137    if ( $self->{error} ) {
138        $tt_vars{error_message} = $self->{error};
139    } elsif ( $doing_search ) {
140        my @results = values %{ $self->{results} || {} };
141        my $numres = scalar @results;
142
143        # Clear out wikitext; we're done with this search.  (Avoids
144        # subsequent searches with this object erroneously matching things
145        # that matched this time.)  Do it here (ie at the last minute) to
146        # avoid screwing up "AND" searches.
147        delete $self->{wikitext};
148
149        # Redirect to a single result only if the title is a good enough match.
150        # (Don't try a fuzzy search on a blank search string - Plucene chokes.)
151        if ( $self->{search_string} ) {
152            my %fuzzies =
153                      $self->{wiki}->fuzzy_title_match($self->{search_string});
154            if ( $numres == 1
155                 && !$self->{return_tt_vars} && scalar keys %fuzzies) {
156                my $node = $results[0]{name};
157                my $output = CGI::redirect( $self->{wikimain} . "?"
158                                            . CGI::escape($node) );
159                return $output if $self->{return_output};
160                print $output;
161                exit;
162            }
163        }
164
165        # We browse through the results a page at a time.
166
167        # Figure out which results we're going to be showing on this
168        # page, and what the first one for the next page will be.
169        my $startpos = $vars{next} || 0;
170        $tt_vars{first_num} = $numres ? $startpos + 1 : 0;
171        $tt_vars{last_num}  = $numres > $startpos + 20
172                                                       ? $startpos + 20
173                                                       : $numres;
174        $tt_vars{total_num} = $numres;
175        if ( $numres > $startpos + 20 ) {
176            $tt_vars{next_page_startpos} = $startpos + 20;
177        }
178
179        # Sort the results - by distance if we're searching on that
180        # or by score otherwise.
181        if ( $vars{distance_in_metres} ) {
182            @results = sort { $a->{distance} <=> $b->{distance} } @results;
183        } else {
184            @results = sort { $b->{score} <=> $a->{score} } @results;
185        }
186
187        # Now snip out just the ones for this page.  The -1 is
188        # because arrays index from 0 and people from 1.
189        my $from = $tt_vars{first_num} ? $tt_vars{first_num} - 1 : 0;
190        my $to   = $tt_vars{last_num} - 1; # kludge to empty arr for no results
191        @results = @results[ $from .. $to ];
192
193        $tt_vars{results} = \@results;
194    }
195
196    $self->process_template( tt_vars => \%tt_vars );
197}
198
199# thin wrapper around OpenGuides::Template
200sub process_template {
201    my ($self, %args) = @_;
202    my $tt_vars = $args{tt_vars} || {};
203
204    $tt_vars->{not_editable} = 1;
205
206    return %$tt_vars if $self->{return_tt_vars};
207
208    my $output =  OpenGuides::Template->output(
209                                                wiki     => $self->{wiki},
210                                                config   => $self->{config},
211                                                template => "supersearch.tt",
212                                                vars     => $tt_vars,
213                                              );
214    return $output if $self->{return_output};
215
216    print $output;
217    return 1;
218}
219
220# method to populate $self with text of nodes potentially matching a query
221# This could contain many more nodes than actually match the query
222sub _prime_wikitext {
223    my ($self, %args) = @_;
224    my ($op, @leaves) = @{ $args{tree} };
225    my $wiki = $self->{wiki};
226
227    if ($op =~ /AND|OR/) {
228        # Recurse into parse tree for boolean op nodes
229        $self->_prime_wikitext( tree => $_ ) for @leaves;
230    } elsif ($op eq 'NOT') {
231        $self->_prime_wikitext( tree => \@leaves );
232    } elsif ($op eq 'word') {
233        foreach (@leaves) {
234            # Search title and body.
235            my %results = $wiki->search_nodes( $_ );
236            foreach my $node ( keys %results ) {
237                next unless $node; # Search::InvertedIndex goes screwy sometimes
238                my $key = $wiki->formatter->node_name_to_node_param( $node );
239                my $text = $node . " " . $wiki->retrieve_node( $node );
240                $self->{wikitext}{$key}{text} ||= $self->_mungepage( $text );
241            }
242        }
243
244        my $meta_title = join '_',@leaves;
245        my $matchstr = join ' ',@leaves;
246
247        # Search categories.
248        my @catmatches = $wiki->list_nodes_by_metadata(
249                                 metadata_type  => "category",
250                                 metadata_value => $meta_title,
251                                 ignore_case    => 1,
252        );
253
254        foreach my $node ( @catmatches ) {
255                my $key = $wiki->formatter->node_name_to_node_param( $node );
256                my $text = $node. " " . $wiki->retrieve_node( $node );
257                $self->{wikitext}{$key}{text} ||= $self->_mungepage( $text );
258                # Append this category so the regex finds it later.
259                $self->{wikitext}{$key}{text} .= " [$matchstr]";
260                $self->{wikitext}{$key}{category_match} = 1;
261        }
262
263        # Search locales.
264        my @locmatches = $wiki->list_nodes_by_metadata(
265                                 metadata_type  => "locale",
266                                 metadata_value => $meta_title,
267                                 ignore_case    => 1,
268        );
269        foreach my $node ( @locmatches ) {
270                my $key = $wiki->formatter->node_name_to_node_param( $node );
271                my $text = $node. " " . $wiki->retrieve_node( $node );
272                $self->{wikitext}{$key}{text} ||= $self->_mungepage( $text );
273                # Append this locale so the regex finds it later.
274                $self->{wikitext}{$key}{text} .= " [$matchstr]";
275                $self->{wikitext}{$key}{locale_match} = 1;
276        }
277    } # $op eq 'word'
278} # sub _prime_wikitext
279   
280# method to filter out undesirable markup from the raw wiki text
281sub _mungepage {
282    my ($self, $text) = @_;
283
284    # Remove HTML tags (sort of)
285    $text =~ s/<.*?>//g;
286
287    # Change WikiLinks into plain text
288    $text =~ s/\[\[(.*?)\|(.*?)\]\]/$2/g;  # titled WikiLink
289    $text =~ s/\[\[(.*?)\]\]/$1/g;         # normal WikiLink
290    $text =~ s/\[(.*?) (.*?)\]/$2/g;       # titled web link
291   
292    # Remove WikiFormatting
293    $text =~ s/=//g;      # heading
294    $text =~ s/'''//g;    # bold
295    $text =~ s/''//g;     # italic
296    $text =~ s/\*//g;     # bullet point
297    $text =~ s/----//g;   # horizontal rule
298
299    # Change "#REDIRECT" to something prettier
300    $text =~ s/\#REDIRECT/\(redirect\)/g;
301
302    return $text;
303}
304
305# Populates either $self->{error} or $self->{results}
306sub _perform_search {
307    my ($self, %args) = @_;
308    my %vars = %{ $args{vars} || {} };
309
310    my $srh = $vars{search};
311
312    # Perform text search if search terms entered, otherwise collect up
313    # all nodes to check distance.
314    if ( $srh ) {
315        # Check for only valid characters in tainted search param
316        # (quoted literals are OK, as they are escaped)
317        if ( $srh !~ /^("[^"]*"|[\w \-',()!*%\[\]])+$/i) { #"
318            $self->{error} = "Search expression contains invalid character(s)";
319            return;
320        }
321        $self->_build_parser && exists($self->{error}) && return;
322        $self->_apply_parser($srh);
323
324        # Now give extra bonus points to any nodes matching the entire
325        # search string verbatim.  This is really shonky and inefficient
326        # but then the whole of this module needs rewriting to be less
327        # ick in any case.
328        foreach my $page ( keys %{ $self->{results} } ) {
329            my $summary = $self->{results}{$page}{summary};
330            $summary =~ s/<\/?b>//g;
331            if ( $summary =~ /$self->{search_string}/i ) {
332                $self->{results}{$page}{score} += 5;
333              }
334        }
335    } else {
336        my $wiki = $self->{wiki};
337        my @all_nodes = $wiki->list_all_nodes;
338        my $formatter = $wiki->formatter;
339        my %results = map {
340              my $name = $formatter->node_name_to_node_param( $_ );
341              my %data = $wiki->retrieve_node( $_ );
342              my $content = $wiki->format( @data{ qw( content metadata ) } );
343              $content = $self->_mungepage( $content );
344              my $summary = substr( $content, 0, 150 );
345              $name => {
346                         name    => $name,
347                         score   => 0,
348                         summary => $summary,
349                       }
350                          } @all_nodes;
351        $self->{results} = \%results;
352    }
353
354    # Now filter by distance if required.
355    my ($os_x, $os_y, $lat, $long, $dist) =
356                         @vars{ qw( os_x os_y lat long distance_in_metres ) };
357    if ( ( (defined $lat && defined $long)
358           or (defined $os_x and defined $os_y)
359                                                ) && $dist ) {
360        my %results = %{ $self->{results} || {} };
361        my @close;
362        if ( defined $lat && defined $long ) {
363            @close = $self->{locator}->find_within_distance(
364                                                             lat    => $lat,
365                                                             long   => $long,
366                                                             metres => $dist,
367                                                           );
368        } else {
369            @close = $self->{locator}->find_within_distance(
370                                                             os_x   => $os_x,
371                                                             os_y   => $os_y,
372                                                             metres => $dist,
373                                                           );
374        }
375        my %close_hash = map { $_ => 1 } @close;
376        my @nodes = keys %results;
377        foreach my $node ( @nodes ) {
378            my $unmunged = $node; # KLUDGE
379            $unmunged =~ s/_/ /g;
380            if ( exists $close_hash{$unmunged} ) {
381                my $distance;
382                if ( defined $lat && defined $long ) {
383                    $distance = $self->{locator}->distance(
384                                                 from_lat  => $lat,
385                                                 from_long => $long,
386                                                 to_node   => $unmunged,
387                                                 unit      => "metres"
388                                                          );
389                } else {
390                    $distance = $self->{locator}->distance(
391                                                 from_os_x => $os_x,
392                                                 from_os_y => $os_y,
393                                                 to_node   => $unmunged,
394                                                 unit      => "metres"
395                                                          );
396                }
397                $results{$node}{distance} = $distance;               
398            } else {
399                delete $results{$node};
400            }
401        }
402        $self->{results} = \%results;
403    }     
404}
405
406sub _build_parser {
407    my $self = shift;
408
409    # Build RecDescent grammar for search syntax.
410
411    my $parse = Parse::RecDescent->new(q{
412
413        search: list eostring {$return = $item[1]}
414
415        list: comby(s)
416            {$return = (@{$item[1]}>1) ? ['AND', @{$item[1]}] : $item[1][0]}
417
418        comby: <leftop: term ',' term>
419            {$return = (@{$item[1]}>1) ? ['OR', @{$item[1]}] : $item[1][0]}
420
421        term: '(' list ')' {$return = $item[2]}
422            |        '-' term {$return = ['NOT', @{$item[2]}]}
423#           |        word ':' term {$return = ['meta', $item[1], $item[3]];}
424            |        '"' word(s) '"' {$return = ['word', @{$item[2]}]}
425            |        word {$return = ['word', $item[1]]}
426            |        '[' word(s) ']' {$return = ['title', @{$item[2]}]}
427#           |        m([/|\\]) m([^$item[1]]+) $item[1]
428#                       { $return = ['regexp', qr($item[2])] }
429
430        word: /[\w'*%]+/ {$return = $item[1]}
431           
432        eostring: /^\Z/
433       
434    });
435
436    unless ( $parse ) {
437        warn $@;
438        $self->{error} = "can't create parse object";
439        return;
440    }
441   
442    $self->{parser} = $parse;
443    return $self;
444}
445
446sub _apply_parser {
447    my ($self,$search) = @_;
448       
449    # Turn search string into parse tree
450    my $tree = $self->{parser}->search($search);
451    unless ( $tree ) {
452        $self->{error} = "Search syntax error";
453        return;
454    }
455
456    # Store search string too.
457    $self->{search_string} = $search;
458
459    #Prime the search
460    $self->_prime_wikitext( tree => $tree);
461
462    # Apply search and return results
463    my %results = $self->_matched_items( tree => $tree );
464    $self->{results} = \%results;
465    return $self;
466}
467
468# called with parse tree
469sub _matched_items {
470    my ($self, %args) = @_;
471    my $tree = $args{tree};
472    my @tree_arr = @$tree;
473    my $op = shift @tree_arr;
474    my $meth = 'matched_'.$op;
475    return $self->can($meth) ? $self->$meth(@tree_arr) : undef;
476}
477
478
479
480=head1 INPUT
481
482=over
483
484=item B<word>
485
486a single word will be matched as-is. For example, a search on
487
488  escalator
489
490will return all pages containing the word "escalator".
491
492=cut
493
494sub matched_word {
495    my $self = shift;
496    my $wmatch = join '\W+',@_;
497    $wmatch =~ s/%/\\w/g;
498    $wmatch =~ s/\*/\\w*/g;
499
500    return $self->_do_search($wmatch);
501}
502
503=item B<AND searches>
504
505A list of words with no punctuation will be ANDed, for example:
506
507  restaurant vegetarian
508
509will return all pages containing both the word "restaurant" and the word
510"vegetarian".
511
512=cut
513
514sub matched_AND {
515    my ($self, @subsearches) = @_;
516
517    # Do the first subsearch.
518    my %results = $self->_matched_items( tree => $subsearches[0] );
519
520    # Now do the rest one at a time and remove from the results anything
521    # that doesn't come up in each subsearch.  Results that survive will
522    # have a score that's the sum of their score in each subsearch.
523    foreach my $tree ( @subsearches[ 1 .. $#subsearches ] ) {
524        my %subres = $self->_matched_items( tree => $tree );
525        my @pages = keys %results;
526        foreach my $page ( @pages ) {
527            if ( exists $subres{$page} ) {
528                $results{$page}{score} += $subres{$page}{score};
529            } else {
530                delete $results{$page};
531            }
532        }
533    }
534
535    return %results;
536}
537
538=item B<OR searches>
539
540A list of words separated by commas (and optional spaces) will be ORed,
541for example:
542
543  restaurant, cafe
544
545will return all pages containing either the word "restaurant" or the
546word "cafe".
547
548=cut
549
550sub matched_OR {
551    my ($self, @subsearches) = @_;
552
553    # Do all the searches.  Results will have a score that's the sum
554    # of their score in each subsearch.
555    my %results;
556    foreach my $tree ( @subsearches ) {
557        my %subres = $self->_matched_items( tree => $tree );
558        foreach my $page ( keys %subres ) {
559            if ( $results{$page} ) {
560                $results{$page}{score} += $subres{$page}{score};
561            } else {
562                $results{$page} = $subres{$page};
563            }
564        }
565    }
566    return %results;
567}
568
569=item B<NOT searches>
570
571Words and phrases preceded by a minus sign are excluded, for example:
572
573  restaurant -expensive
574
575will return all pages that contain the word "restaurant" and do not
576contain "expensive".
577
578Note that a NOT search is used to qualify an existing search, so you
579cannot use -foo standalone to give you all pages without foo.
580
581=cut
582
583# matched_NOT - Form complement of hash against %wikitext
584sub matched_NOT {
585    my $self = shift;
586    my %excludes = $self->_matched_items(tree => \@_);
587    my %out = map { $_ => { score => 0} } keys %{ $self->{wikitext} };
588
589    delete $out{$_} for keys %excludes;
590    return %out;
591}
592
593=item B<phrase searches>
594
595Enclose phrases in double quotes, for example:
596
597  "meat pie"
598
599will return all pages that contain the exact phrase "meat pie" - not pages
600that only contain, for example, "apple pie and meat sausage".
601
602=cut
603
604# matched_literal - we have a literal.
605sub matched_literal {
606    my $self = shift;
607    my $lit = shift;
608    $self->_do_search(quotemeta $lit);
609}
610
611=back
612
613=head1 OUTPUT
614
615Results will be put into some form of relevance ordering.  These are
616the rules we have tests for so far (and hence the only rules that can
617be relied on):
618
619=over
620
621=item *
622
623A match on page title will score higher than a match on page category
624or locale.
625
626=item *
627
628A match on page category or locale will score higher than a match on
629page content.
630
631=item *
632
633Two matches in the title beats one match in the title and one in the content.
634
635=back
636
637=cut
638
639sub intersperse {
640    my $self = shift;
641    my $pagnam = shift;
642   
643    my @mixed;   
644    my $score = 0;
645   
646    for my $j (@_) {
647        if (exists $j->{$pagnam}) {
648            $score += $j->{$pagnam}[0];
649            push @mixed,[$_,$j->{$pagnam}[$_]] for 1..$#{$j->{$pagnam}};
650        }
651    }
652   
653    my @interspersed = map $_->[1], sort {$a->[0] <=> $b->[0]} @mixed;
654   
655    unshift @interspersed,$score;
656   
657    return \@interspersed;
658}
659
660sub _do_search {
661    my ($self, $wmatch) = @_;
662
663    # Build regexp from parameter. Gobble upto 60 characters of
664    # context either side.
665    my $wexp = qr/\b.{0,60}\b$wmatch\b.{0,60}\b/is;
666    my %results;
667
668    # Search every wiki page for matches
669    my %wikitext = %{ $self->{wikitext} || {} };
670    while (my ($k,$v) = each %wikitext) {
671        my @out;
672        for ($v->{text} =~ /$wexp/g) {
673            my $match = "...$_...";
674            $match =~ s/<[^>]+>//gs;
675            $match =~ s!\b($wmatch)\b!<b>$&</b>!i;
676            push @out,$match;
677        }
678        my $temp = $k;
679        $temp =~ s/_/ /g;
680
681        # Compute score and create summary.
682        my $score = scalar @out; # 1 point for each match in body/title/cats
683        $score += 10 if $temp =~ /$wexp/; # 10 points if title matches
684        # 3 points for cat/locale match.  Check $score too since this might
685        # be a branch of an AND search and the cat/locale match may have
686        # been for the other branch,
687        $score += 3  if $v->{category_match} and $score;
688        $score += 3  if $v->{locale_match} and $score;
689
690        $results{$k} = {
691                         score   => $score,
692                         summary => join( "", @out ),
693                         name    => $k,
694                       }
695          if $score;
696    }
697   
698    return %results;
699}
700
701=head1 AUTHOR
702
703The OpenGuides Project (openguides-dev@openguides.org)
704
705=head1 COPYRIGHT
706
707     Copyright (C) 2003-4 The OpenGuides Project.  All Rights Reserved.
708
709The OpenGuides distribution is free software; you can redistribute it
710and/or modify it under the same terms as Perl itself.
711
712=head1 SEE ALSO
713
714L<OpenGuides>
715
716=cut
717
7181;
719
720__END__
721
722# Not sure what this sub is meant to do.  It doesn't seem to match on [foo]
723sub matched_title {
724    my $wmatch = join '\W+',@_;
725    $wmatch =~ s/%/\\w/g;
726    $wmatch =~ s/\*/\\w*/g;
727
728    my $wexp = qr/\b$wmatch\b/is;
729    my %res;
730   
731    for (keys %wikitext) {
732        $res{$_} = [10] if /$wexp/g;
733    }
734   
735    %res;
736}
Note: See TracBrowser for help on using the repository browser.