Open-ILS/src/perlmods/lib/OpenILS/WWW/AutoSuggest.pm

   1 package OpenILS::WWW::AutoSuggest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Apache2::Log;
   7 use Apache2::Const -compile => qw(
   8     OK HTTP_NOT_ACCEPTABLE HTTP_INTERNAL_SERVER_ERROR :log
   9 );
  10 use XML::LibXML;
  11 use Text::Glob;
  12 use CGI qw(:all -utf8);
  13
  14 use OpenSRF::Utils::JSON;
  15 use OpenILS::Utils::CStoreEditor qw/:funcs/;
  16
  17 # BEGIN package globals
  18
  19 # We'll probably never need this fanciness for autosuggest, but
  20 # you can add handlers for different requested content-types here, and
  21 # you can weight them to control what matches requests for things like
  22 # 'application/*'
  23
  24 my $_output_handler_dispatch = {
  25     "application/xml" => {
  26         "prio" => 0,
  27         "code" => sub {
  28             my ($r, $data) = @_;
  29             $r->content_type("application/xml; charset=utf-8");
  30             print suggestions_to_xml($data);
  31             return Apache2::Const::OK;
  32         }
  33     },
  34     "application/json" => {
  35         "prio" => 1,
  36         "code" => sub {
  37             my ($r, $data) = @_;
  38             $r->content_type("application/json; charset=utf-8");
  39             print suggestions_to_json($data);
  40             return Apache2::Const::OK;
  41         }
  42     }
  43 };
  44
  45 my @_output_handler_types = sort {
  46     $_output_handler_dispatch->{$a}->{prio} <=>
  47         $_output_handler_dispatch->{$b}->{prio}
  48 } keys %$_output_handler_dispatch;
  49
  50 # END package globals
  51
  52 # The third argument to our stored procedure, metabib.suggest_browse_entries(),
  53 # is passed through directly to ts_headline() as the 'options' arugment.
  54 sub prepare_headline_opts {
  55     my ($css_prefix, $highlight_min, $highlight_max, $short_word_length) = @_;
  56
  57     $css_prefix =~ s/[^\w]//g;
  58
  59     my @parts = (
  60         qq{StartSel="<span class='$css_prefix'>"},
  61         "StopSel=</span>"
  62     );
  63
  64     push @parts, "MinWords=$highlight_min" if $highlight_min > 0;
  65     push @parts, "MaxWords=$highlight_max" if $highlight_max > 0;
  66     push @parts, "ShortWord=$short_word_length" if defined $short_word_length;
  67
  68     return join(", ", @parts);
  69 }
  70
  71 # Get raw autosuggest data (rows returned from a stored procedure) from the DB.
  72 sub get_suggestions {
  73     my $editor = shift;
  74     my $query = shift;
  75     my $search_class = shift;
  76     my $org_unit = shift;
  77     my $css_prefix = shift || 'oils_AS';
  78     my $highlight_min = int(shift || 0);
  79     my $highlight_max = int(shift || 0);
  80     my $short_word_length = shift;
  81
  82     my $normalization = int(shift || 14);   # 14 is not totally arbitrary.
  83     # See http://www.postgresql.org/docs/9.0/static/textsearch-controls.html#TEXTSEARCH-RANKING
  84
  85     my $limit = int(shift || 10);
  86
  87     $limit = 10 unless $limit > 0;
  88
  89     my $headline_opts = prepare_headline_opts(
  90         $css_prefix, $highlight_min, $highlight_max,
  91         defined $short_word_length ? int($short_word_length) : undef
  92     );
  93
  94     return $editor->json_query({
  95         "from" => [
  96             "metabib.suggest_browse_entries",
  97             $query,
  98             $search_class,
  99             $headline_opts,
 100             $org_unit,
 101             $limit,
 102             $normalization
 103         ]
 104     });
 105 }
 106
 107 sub suggestions_to_xml {
 108     my ($suggestions) = @_;
 109
 110     my $dom = new XML::LibXML::Document("1.0", "UTF-8");
 111     my $as = $dom->createElement("as");
 112     $dom->setDocumentElement($as);
 113
 114     foreach (@$suggestions) {
 115         my $val = $dom->createElement("val");
 116         $val->setAttribute("term", $_->{value});
 117         $val->setAttribute("field", $_->{field});
 118         $val->appendText($_->{match});
 119         $as->addChild($val);
 120     }
 121
 122     # XML::LibXML::Document::toString() returns an encoded byte string, which
 123     # is why we don't need to binmode STDOUT, ':utf8'.
 124     return $dom->toString();
 125 }
 126
 127 sub suggestions_to_json {
 128     my ($suggestions) = @_;
 129
 130     return OpenSRF::Utils::JSON->perl2JSON({
 131         "val" => [
 132             map {
 133                 +{ term => $_->{value}, field => $_->{field},
 134                     match => $_->{match} }
 135             } @$suggestions
 136         ]
 137     });
 138 }
 139
 140 # Given data and the Apache request object, this sub picks a sub from a
 141 # dispatch table based on the list of content-type encodings that the client
 142 # has indicated it will accept, and calls that sub, which will deliver
 143 # a response of appropriately encoded data.
 144 sub output_handler {
 145     my ($r, $data) = @_;
 146
 147     foreach my $media_range (split /,/, $r->headers_in->{Accept}) {
 148         $media_range =~ s/;.+$//; # keep type, subtype. lose parameters.
 149
 150         my ($match) = grep {
 151             Text::Glob::match_glob($media_range, $_)
 152         } @_output_handler_types;
 153
 154         if ($match) {
 155             return $_output_handler_dispatch->{$match}{code}->($r, $data);
 156         }
 157     }
 158
 159     return Apache2::Const::HTTP_NOT_ACCEPTABLE;
 160 }
 161
 162 sub handler {
 163     my $r = shift;
 164     my $cgi = new CGI;
 165
 166     my $editor = new_editor;
 167     my $suggestions = get_suggestions(
 168         $editor,
 169         map { scalar($cgi->param($_)) } qw(
 170             query
 171             search_class
 172             org_unit
 173             css_prefix
 174             highlight_min
 175             highlight_max
 176             short_word_length
 177             normalization
 178             limit
 179         )
 180     );
 181
 182     if (not $suggestions) {
 183         $r->log->error(
 184             "get_suggestions() failed: " . $editor->die_event->{textcode}
 185         );
 186         return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
 187     }
 188
 189     $editor->disconnect;
 190
 191     return output_handler($r, $suggestions);
 192 }
 193
 194 1;