source: trunk/lib/OpenGuides/Search.pm @ 716

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

Renaming OpenGuides::SuperSearch? to OpenGuides::Search and supersearch.cgi to search.cgi - bug #17.

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