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

Last change on this file since 578 was 578, checked in by Dominic Hargreaves, 17 years ago

copyright updates.

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