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

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

Encapsulate config data in OpenGuides::Config.

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