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

Last change on this file since 685 was 685, checked in by Earle Martin, 16 years ago

add node summary to search results

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.6 KB
Line 
1package OpenGuides::SuperSearch;
2use strict;
3our $VERSION = '0.09';
4
5use CGI qw( :standard );
6use CGI::Wiki::Plugin::Locator::Grid;
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 OpenGuides::Config;
26  use OpenGuides::SuperSearch;
27
28  my $config = OpenGuides::Config->new( file => "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 = OpenGuides::Config->new( file => "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 $geo_handler = $config->geo_handler;
58    my %locator_params;
59    if ( $geo_handler == 1 ) {
60        %locator_params = ( x => "os_x", y => "os_y" );
61    } elsif ( $geo_handler == 2 ) {
62        %locator_params = ( x => "osie_x", y => "osie_y" );
63    } elsif ( $geo_handler == 3 ) {
64        %locator_params = ( x => "easting", y => "northing" );
65    }
66
67    my $locator = CGI::Wiki::Plugin::Locator::Grid->new( %locator_params );
68    $wiki->register_plugin( plugin => $locator );
69    $self->{locator} = $locator;
70
71    return $self;
72}
73
74=item B<wiki>
75
76  my $wiki = $search->wiki;
77
78An accessor; returns the underlying L<CGI::Wiki> object.
79
80=cut
81
82sub wiki {
83    my $self = shift;
84    return $self->{wiki};
85}
86
87=item B<config>
88
89  my $config = $search->config;
90
91An accessor; returns the underlying L<OpenGuides::Config> object.
92
93=cut
94
95sub config {
96    my $self = shift;
97    return $self->{config};
98}
99
100=item B<run>
101
102  my %vars = CGI::Vars();
103  $search->run(
104                vars           => \%vars,
105                return_output  => 1,   # defaults to 0
106                return_tt_vars => 1,  # defaults to 0
107              );
108
109The C<return_output> parameter is optional.  If supplied and true, the
110stuff that would normally be printed to STDOUT will be returned as a
111string instead.
112
113The C<return_tt_vars> parameter is also optional.  If supplied and
114true, the template is not processed and the variables that would have
115been passed to it are returned as a hash.  This parameter takes
116precedence over C<return_output>.
117
118These two parameters exist to make testing easier; you probably don't
119want to use them in production.
120
121=back
122
123=cut
124
125sub run {
126    my ($self, %args) = @_;
127    $self->{return_output}  = $args{return_output}  || 0;
128    $self->{return_tt_vars} = $args{return_tt_vars} || 0;
129
130    $self->process_params( $args{vars} );
131    if ( $self->{error} ) {
132        warn $self->{error};
133        my %tt_vars = ( error_message => $self->{error} );
134        $self->process_template( tt_vars => \%tt_vars );
135        return;
136    }
137
138    my %tt_vars = (
139                   ss_version  => $VERSION,
140                   ss_info_url => 'http://openguides.org/page/search_help'
141                  );
142
143    my $doing_search;
144
145    # Run a text search if we have a search string.
146    if ( $self->{search_string} ) {
147        $doing_search = 1;
148        $tt_vars{search_terms} = $self->{search_string};
149        $self->run_text_search;
150    }
151
152    # Run a distance search if we have sufficient criteria.
153    if ( defined $self->{distance_in_metres}
154         && defined $self->{x} && defined $self->{y} ) {
155        $doing_search = 1;
156        # Make sure to pass the criteria to the template.
157        $tt_vars{dist} = $self->{distance_in_metres};
158        if ( $self->config->geo_handler eq 1 ) {
159            $tt_vars{coord_field_1_value} = $self->{os_x};
160            $tt_vars{coord_field_2_value} = $self->{os_y};
161        } elsif ( $self->config->geo_handler eq 2 ) {
162            $tt_vars{coord_field_1_value} = $self->{osie_x};
163            $tt_vars{coord_field_2_value} = $self->{osie_y};
164        } elsif ( $self->config->geo_handler eq 3 ) {
165            $tt_vars{coord_field_1_value} = $self->{latitude};
166            $tt_vars{coord_field_2_value} = $self->{longitude};
167        }
168        $self->run_distance_search;
169    }
170
171    # If we're not doing a search then just print the search form.
172    unless ( $doing_search ) {
173        return $self->process_template( tt_vars => \%tt_vars );
174    }
175
176    # At this point either $self->{error} or $self->{results} will be filled.
177    if ( $self->{error} ) {
178        $tt_vars{error_message} = $self->{error};
179        $self->process_template( tt_vars => \%tt_vars );
180        return;
181    }
182
183    # So now we know that we have been asked to perform a search, and we
184    # have performed it.
185    #
186    # $self->{results} will be a hash of refs to hashes like so:
187    #   'Node Name' => {
188    #                    name     => 'Node Name',
189    #                    distance => $distance_from_origin_if_any,
190    #                    score    => $relevance_to_search_string
191    #                  }
192
193    my %results_hash = %{ $self->{results} || [] };
194    my @results = values %results_hash;
195    my $numres = scalar @results;
196
197    # If we only have a single hit, and the title is a good enough match
198    # to the search string, redirect to that node.
199    # (Don't try a fuzzy search on a blank search string - Plucene chokes.)
200    if ( $self->{search_string} && $numres == 1 && !$self->{return_tt_vars}) {
201        my %fuzzies = $self->wiki->fuzzy_title_match($self->{search_string});
202        if ( scalar keys %fuzzies ) {
203            my $node = $results[0]{name};
204            my $formatter = $self->wiki->formatter;
205            my $node_param = CGI::escape(
206                            $formatter->node_name_to_node_param( $node )
207                                        );
208            my $output = CGI::redirect( $self->{wikimain} . "?$node_param" );
209            return $output if $self->{return_output};
210            print $output;
211            return;
212        }
213    }
214
215    # If we had no hits then go straight to the template.
216    if ( $numres == 0 ) {
217        %tt_vars = (
218                     %tt_vars,
219                     first_num => 0,
220                     results   => [],
221                   );
222        return $self->process_template( tt_vars => \%tt_vars );
223    }
224
225    # Otherwise, we browse through the results a page at a time.
226
227    # Figure out which results we're going to be showing on this
228    # page, and what the first one for the next page will be.
229    my $startpos = $args{vars}{next} || 0;
230    $tt_vars{first_num} = $numres ? $startpos + 1 : 0;
231    $tt_vars{last_num}  = $numres > $startpos + 20 ? $startpos + 20 : $numres;
232    $tt_vars{total_num} = $numres;
233    if ( $numres > $startpos + 20 ) {
234        $tt_vars{next_page_startpos} = $startpos + 20;
235    }
236
237    # Sort the results - by distance if we're searching on that
238    # or by score otherwise.
239    if ( $self->{distance_in_metres} ) {
240        @results = sort { $a->{distance} <=> $b->{distance} } @results;
241    } else {
242        @results = sort { $b->{score} <=> $a->{score} } @results;
243    }
244
245    # Now snip out just the ones for this page.  The -1 is because
246    # arrays index from 0 and people from 1.
247    my $from = $tt_vars{first_num} ? $tt_vars{first_num} - 1 : 0;
248    my $to   = $tt_vars{last_num} - 1; # kludge to empty arr for no results
249    @results = @results[ $from .. $to ];
250
251    # Add the URL to each result hit.
252    my $formatter = $self->wiki->formatter;
253    foreach my $i ( 0 .. $#results ) {
254        my $name = $results[$i]{name};
255
256        # Add the one-line summary of the node, if there is one.
257        my %node = $self->wiki->retrieve_node($name);
258        $results[$i]{summary} = $node{metadata}{summary}[0];
259
260        my $node_param = $formatter->node_name_to_node_param( $name );
261        $results[$i]{url} = $self->{wikimain} . "?$node_param";
262    }
263
264    # Finally pass the results to the template.
265    $tt_vars{results} = \@results;
266    $self->process_template( tt_vars => \%tt_vars );
267}
268
269sub run_text_search {
270    my $self = shift;
271    my $searchstr = $self->{search_string};
272    my $wiki = $self->wiki;
273
274    # Create parser to parse the search string.
275    my $parser = Parse::RecDescent->new( q{
276
277        search: list eostring {$return = $item[1]}
278
279        list: comby(s)
280            {$return = (@{$item[1]}>1) ? ['AND', @{$item[1]}] : $item[1][0]}
281
282        comby: <leftop: term ',' term>
283            {$return = (@{$item[1]}>1) ? ['OR', @{$item[1]}] : $item[1][0]}
284
285        term: '(' list ')' {$return = $item[2]}
286            |        '-' term {$return = ['NOT', @{$item[2]}]}
287            |        '"' word(s) '"' {$return = ['phrase', join " ", @{$item[2]}]}
288            |        word {$return = ['word', $item[1]]}
289            |        '[' word(s) ']' {$return = ['title', @{$item[2]}]}
290
291        word: /[\w'*%]+/ {$return = $item[1]}
292
293        eostring: /^\Z/
294
295    } );
296
297    unless ( $parser ) {
298        warn $@;
299        $self->{error} = "Can't create parse object - $@";
300        return $self;
301    }
302
303    # Run parser over search string.
304    my $tree = $parser->search( $searchstr );
305    unless ( $tree ) {
306        $self->{error} = "Syntax error in search: $searchstr";
307        return $self;
308    }
309
310    # Run the search over the generated search tree.
311    my %results = $self->_run_search_tree( tree => $tree );
312    $self->{results} = \%results;
313    return $self;
314}
315
316sub _run_search_tree {
317    my ($self, %args) = @_;
318    my $tree = $args{tree};
319    my @tree_arr = @$tree;
320    my $op = shift @tree_arr;
321    my $method = "_run_" . $op . "_search";
322    return $self->can($method) ? $self->$method(@tree_arr) : undef;
323}
324
325=head1 INPUT
326
327=over
328
329=item B<word>
330
331a single word will be matched as-is. For example, a search on
332
333  escalator
334
335will return all pages containing the word "escalator".
336
337=cut
338
339sub _run_word_search {
340    my ($self, $word) = @_;
341    # A word is just a small phrase.
342    return $self->_run_phrase_search( $word );
343}
344
345=item B<AND searches>
346
347A list of words with no punctuation will be ANDed, for example:
348
349  restaurant vegetarian
350
351will return all pages containing both the word "restaurant" and the word
352"vegetarian".
353
354=cut
355
356sub _run_AND_search {
357    my ($self, @subsearches) = @_;
358
359    # Do the first subsearch.
360    my %results = $self->_run_search_tree( tree => $subsearches[0] );
361
362    # Now do the rest one at a time and remove from the results anything
363    # that doesn't come up in each subsearch.  Results that survive will
364    # have a score that's the sum of their score in each subsearch.
365    foreach my $tree ( @subsearches[ 1 .. $#subsearches ] ) {
366        my %subres = $self->_run_search_tree( tree => $tree );
367        my @pages = keys %results;
368        foreach my $page ( @pages ) {
369          if ( exists $subres{$page} ) {
370                $results{$page}{score} += $subres{$page}{score};
371              } else {
372                delete $results{$page};
373            }
374        }
375      }
376
377    return %results;
378}
379
380=item B<OR searches>
381
382A list of words separated by commas (and optional spaces) will be ORed,
383for example:
384
385  restaurant, cafe
386
387will return all pages containing either the word "restaurant" or the
388word "cafe".
389
390=cut
391
392sub _run_OR_search {
393    my ($self, @subsearches) = @_;
394
395    # Do all the searches.  Results will have a score that's the sum
396    # of their score in each subsearch.
397    my %results;
398    foreach my $tree ( @subsearches ) {
399        my %subres = $self->_run_search_tree( tree => $tree );
400        foreach my $page ( keys %subres ) {
401          if ( $results{$page} ) {
402                $results{$page}{score} += $subres{$page}{score};
403              } else {
404                $results{$page} = $subres{$page};
405            }
406        }
407      }
408    return %results;
409}
410
411=item B<phrase searches>
412
413Enclose phrases in double quotes, for example:
414
415  "meat pie"
416
417will return all pages that contain the exact phrase "meat pie" - not pages
418that only contain, for example, "apple pie and meat sausage".
419
420=cut
421
422sub _run_phrase_search {
423    my ($self, $phrase) = @_;
424    my $wiki = $self->wiki;
425
426    # Search title and body.
427    my %contents_res = $wiki->search_nodes( $phrase );
428
429    # Rationalise the scores a little.  The scores returned by
430    # CGI::Wiki::Search::Plucene are simply a ranking.
431    my $num_results = scalar keys %contents_res;
432    foreach my $node ( keys %contents_res ) {
433        $contents_res{$node} = int( $contents_res{$node} / $num_results ) + 1;
434    }
435
436    # It'll be a real phrase (as opposed to a word) if it has a space in it.
437    # In this case, dump out the nodes that don't match the search exactly.
438    # I don't know why the phrase searching isn't working properly.  Fix later.
439    if ( $phrase =~ /\s/ ) {
440        my @tmp = keys %contents_res;
441        foreach my $node ( @tmp ) {
442            my $content = $wiki->retrieve_node( $node );
443            unless ( $content =~ /$phrase/i || $node =~ /$phrase/i ) {
444                delete $contents_res{$node};
445            }
446        }
447    }
448
449    my %results = map { $_ => { name => $_, score => $contents_res{$_} } }
450                      keys %contents_res;
451
452    # Bump up the score if the title matches.
453    foreach my $node ( keys %results ) {
454        $results{$node}{score} += 10 if $node =~ /$phrase/i;
455    }
456
457    # Search categories.
458    my @catmatches = $wiki->list_nodes_by_metadata(
459                                 metadata_type  => "category",
460                                 metadata_value => $phrase,
461                                 ignore_case    => 1,
462    );
463
464    foreach my $node ( @catmatches ) {
465        if ( $results{$node} ) {
466            $results{$node}{score} += 3;
467        } else {
468            $results{$node} = { name => $node, score => 3 };
469        }
470    }
471
472    # Search locales.
473    my @locmatches = $wiki->list_nodes_by_metadata(
474                                 metadata_type  => "locale",
475                                 metadata_value => $phrase,
476                                 ignore_case    => 1,
477    );
478
479    foreach my $node ( @locmatches ) {
480        if ( $results{$node} ) {
481            $results{$node}{score} += 3;
482        } else {
483            $results{$node} = { name => $node, score => 3 };
484        }
485    }
486
487    return %results;
488}
489
490=back
491
492=head1 SEARCHING BY DISTANCE
493
494To perform a distance search, you need to supply one of the following
495sets of criteria to specify the distance to search within, and the
496origin (centre) of the search:
497
498=over
499
500=item B<os_dist, os_x, and os_y>
501
502Only works if you chose to use British National Grid in wiki.conf
503
504=item B<osie_dist, osie_x, and osie_y>
505
506Only works if you chose to use Irish National Grid in wiki.conf
507
508=item B<latlong_dist, latitude, and longitude>
509
510Should always work, but has a habit of "finding" things a couple of
511metres away from themselves.
512
513=back
514
515You can perform both pure distance searches and distance searches in
516combination with text searches.
517
518=cut
519
520# Note this is called after any text search is run, and it is only called
521# if there are sufficient criteria to perform the search.
522sub run_distance_search {
523    my $self = shift;
524    my $x    = $self->{x};
525    my $y    = $self->{y};
526    my $dist = $self->{distance_in_metres};
527
528    my @close = $self->{locator}->find_within_distance(
529                                                        x      => $x,
530                                                        y      => $y,
531                                                        metres => $dist,
532                                                      );
533
534    if ( $self->{results} ) {
535        my %close_hash = map { $_ => 1 } @close;
536        my %results = %{ $self->{results} };
537        my @candidates = keys %results;
538        foreach my $node ( @candidates ) {
539            if ( exists $close_hash{$node} ) {
540                my $distance = $self->_get_distance(
541                                                     node => $node,
542                                                     x    => $x,
543                                                     y    => $y,
544                                                   );
545                $results{$node}{distance} = $distance;
546            } else {
547                delete $results{$node};
548            }
549        }
550        $self->{results} = \%results;
551    } else {
552        my %results;
553        foreach my $node ( @close ) {
554            my $distance = $self->_get_distance (
555                                                     node => $node,
556                                                     x    => $x,
557                                                     y    => $y,
558                                                   );
559            $results{$node} = {
560                                name     => $node,
561                                distance => $distance,
562                              };
563        }
564        $self->{results} = \%results;
565    }
566    return $self;
567}
568
569sub _get_distance {
570    my ($self, %args) = @_;
571    my ($node, $x, $y) = @args{ qw( node x y ) };
572    return $self->{locator}->distance(
573                                       from_x  => $x,
574                                       from_y  => $y,
575                                       to_node => $node,
576                                       unit    => "metres"
577                                     );
578}
579
580sub process_params {
581    my ($self, $vars_hashref) = @_;
582    my %vars = %{ $vars_hashref || {} };
583
584    # Make sure that we don't have any data left over from previous invocation.
585    # This is useful for testing purposes at the moment and will be essential
586    # for mod_perl implementations.
587    delete $self->{x};
588    delete $self->{y};
589    delete $self->{distance_in_metres};
590    delete $self->{search_string};
591
592    # Strip out any non-digits from distance and OS co-ords.
593    foreach my $param ( qw( os_x os_y osie_x osie_y
594                            osie_dist os_dist latlong_dist ) ) {
595        if ( defined $vars{$param} ) {
596            $vars{$param} =~ s/[^0-9]//g;
597            # 0 is an allowed value but the empty string isn't.
598            delete $vars{$param} if $vars{$param} eq "";
599        }
600    }
601
602    # Latitude and longitude are also allowed '-' and '.'
603    foreach my $param( qw( latitude longitude ) ) {
604        if ( defined $vars{$param} ) {
605            $vars{$param} =~ s/[^-\.0-9]//g;
606            # 0 is an allowed value but the empty string isn't.
607            delete $vars{$param} if $vars{$param} eq "";
608        }
609    }
610
611    # Set $self->{distance_in_metres}, $self->{x}, $self->{y},
612    # depending on whether we got
613    # OS co-ords or lat/long.  Only store parameters if they're complete,
614    # and supported by our method of distance calculation.
615    if ( defined $vars{os_x} && defined $vars{os_y} && defined $vars{os_dist}
616         && $self->config->geo_handler eq 1 ) {
617        $self->{x} = $vars{os_x};
618        $self->{y} = $vars{os_y};
619        $self->{distance_in_metres} = $vars{os_dist};
620    } elsif ( defined $vars{osie_x} && defined $vars{osie_y}
621         && defined $vars{osie_dist}
622         && $self->config->geo_handler eq 2 ) {
623        $self->{x} = $vars{osie_x};
624        $self->{y} = $vars{osie_y};
625        $self->{distance_in_metres} = $vars{osie_dist};
626    } elsif ( defined $vars{latitude} && defined $vars{longitude}
627              && defined $vars{latlong_dist} ) {
628        # All handlers can do lat/long, but they all do it differently.
629        if ( $self->config->geo_handler eq 1 ) {
630            require Geography::NationalGrid::GB;
631            my $point = Geography::NationalGrid::GB->new(
632                Latitude  => $vars{latitude},
633                Longitude => $vars{longitude},
634            );
635            $self->{x} = $point->easting;
636            $self->{y} = $point->northing;
637        } elsif ( $self->config->geo_handler eq 2 ) {
638            require Geography::NationalGrid::IE;
639            my $point = Geography::NationalGrid::IE->new(
640                Latitude  => $vars{latitude},
641                Longitude => $vars{longitude},
642            );
643            $self->{x} = $point->easting;
644            $self->{y} = $point->northing;
645        } elsif ( $self->config->geo_handler eq 3 ) {
646            require Geo::Coordinates::UTM;
647            my ($zone, $x, $y) = Geo::Coordinates::UTM::latlon_to_utm(
648                                                $self->config->ellipsoid,
649                                                $vars{latitude},
650                                                $vars{longitude},
651                                              );
652            $self->{x} = $x;
653            $self->{y} = $y;
654        }
655        $self->{distance_in_metres} = $vars{latlong_dist};
656    }
657
658    # Store os_x etc so we can pass them to template.
659    foreach my $param ( qw( os_x os_y osie_x osie_y latitude longitude ) ) {
660        $self->{$param} = $vars{$param};
661    }
662
663    # Strip leading and trailing whitespace from search text.
664    $vars{search} ||= ""; # avoid uninitialised value warning
665    $vars{search} =~ s/^\s*//;
666    $vars{search} =~ s/\s*$//;
667
668    # Check for only valid characters in tainted search param
669    # (quoted literals are OK, as they are escaped)
670    # This regex copied verbatim from Ivor's old supersearch.
671    if ( $vars{search}
672         && $vars{search} !~ /^("[^"]*"|[\w \-',()!*%\[\]])+$/i) {
673        $self->{error} = "Search expression $vars{search} contains invalid character(s)";
674        return $self;
675    }
676    $self->{search_string} = $vars{search};
677
678    return $self;
679}
680
681# thin wrapper around OpenGuides::Template
682sub process_template {
683    my ($self, %args) = @_;
684
685    my $tt_vars = $args{tt_vars} || {};
686    $tt_vars->{not_editable} = 1;
687    $tt_vars->{not_deletable} = 1;
688    return %$tt_vars if $self->{return_tt_vars};
689    my $output =  OpenGuides::Template->output(
690                                                wiki     => $self->wiki,
691                                                config   => $self->config,
692                                                template => "supersearch.tt",
693                                                vars     => $tt_vars,
694                                              );
695    return $output if $self->{return_output};
696
697    print $output;
698    return 1;
699}
700
701=head1 OUTPUT
702
703Results will be put into some form of relevance ordering.  These are
704the rules we have tests for so far (and hence the only rules that can
705be relied on):
706
707=over
708
709=item *
710
711A match on page title will score higher than a match on page category
712or locale.
713
714=item *
715
716A match on page category or locale will score higher than a match on
717page content.
718
719=item *
720
721Two matches in the title beats one match in the title and one in the content.
722
723=back
724
725=cut
726
727=head1 AUTHOR
728
729The OpenGuides Project (openguides-dev@openguides.org)
730
731=head1 COPYRIGHT
732
733     Copyright (C) 2003-2004 The OpenGuides Project.  All Rights Reserved.
734
735The OpenGuides distribution is free software; you can redistribute it
736and/or modify it under the same terms as Perl itself.
737
738=head1 SEE ALSO
739
740L<OpenGuides>
741
742=cut
743
7441;
Note: See TracBrowser for help on using the repository browser.