Open-ILS/src/perlmods/OpenILS/Application/Storage/FTS.pm

   1 use OpenSRF::Utils::Logger qw/:level/;
   2 my $log = 'OpenSRF::Utils::Logger';
   3
   4 #-------------------------------------------------------------------------------
   5 package OpenILS::Application::Storage::FTS;
   6 use OpenSRF::Utils::Logger qw/:level/;
   7 use Parse::RecDescent;
   8 use Unicode::Normalize;
   9 use Encode;
  10
  11 my $_default_grammar_parser = new Parse::RecDescent ( <<'GRAMMAR' );
  12
  13 <autotree>
  14
  15 search_expression: or_expr(s) | and_expr(s) | expr(s)
  16 or_expr: lexpr '||' rexpr
  17 and_expr: lexpr '&&' rexpr
  18 lexpr: expr
  19 rexpr: expr
  20 expr: phrase(s) | group(s) | word(s)
  21 joiner: '||' | '&&'
  22 phrase: '"' token(s) '"'
  23 group : '(' search_expression ')'
  24 word: numeric_range | negative_token | token
  25 negative_token: '-' .../\D+/ token
  26 token: /[-\w]+/
  27 numeric_range: /\d+-\d*/
  28
  29 GRAMMAR
  30
  31 # FIXME - this is a copy-and-paste of the naco_normalize
  32 #         stored procedure
  33 sub naco_normalize {
  34
  35     my $str = decode_utf8(shift);
  36     my $sf = shift;
  37
  38     # Apply NACO normalization to input string; based on
  39     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
  40     #
  41     # Note that unlike a strict reading of the NACO normalization rules,
  42     # output is returned as lowercase instead of uppercase for compatibility
  43     # with previous versions of the Evergreen naco_normalize routine.
  44
  45     # Convert to upper-case first; even though final output will be lowercase, doing this will
  46     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
  47     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
  48     $str = uc $str;
  49
  50     # remove non-filing strings
  51     $str =~ s/\x{0098}.*?\x{009C}//g;
  52
  53     $str = NFKD($str);
  54
  55     # additional substitutions - 3.6.
  56     $str =~ s/\x{00C6}/AE/g;
  57     $str =~ s/\x{00DE}/TH/g;
  58     $str =~ s/\x{0152}/OE/g;
  59     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
  60
  61     # transformations based on Unicode category codes
  62     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
  63
  64         if ($sf && $sf =~ /^a/o) {
  65                 my $commapos = index($str, ',');
  66                 if ($commapos > -1) {
  67                         if ($commapos != length($str) - 1) {
  68                 $str =~ s/,/\x07/; # preserve first comma
  69                         }
  70                 }
  71         }
  72
  73     # since we've stripped out the control characters, we can now
  74     # use a few as placeholders temporarily
  75     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
  76     $str =~ s/[\p{Pc}\p{Pd}\p{Pe}\p{Pf}\p{Pi}\p{Po}\p{Ps}\p{Sk}\p{Sm}\p{So}\p{Zl}\p{Zp}\p{Zs}]/ /g;
  77     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
  78
  79     # decimal digits
  80     $str =~ tr/\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{07C0}-\x{07C9}\x{0966}-\x{096F}\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}\x{0BE6}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}\x{1040}-\x{1049}\x{1090}-\x{1099}\x{17E0}-\x{17E9}\x{1810}-\x{1819}\x{1946}-\x{194F}\x{19D0}-\x{19D9}\x{1A80}-\x{1A89}\x{1A90}-\x{1A99}\x{1B50}-\x{1B59}\x{1BB0}-\x{1BB9}\x{1C40}-\x{1C49}\x{1C50}-\x{1C59}\x{A620}-\x{A629}\x{A8D0}-\x{A8D9}\x{A900}-\x{A909}\x{A9D0}-\x{A9D9}\x{AA50}-\x{AA59}\x{ABF0}-\x{ABF9}\x{FF10}-\x{FF19}/0-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-9/;
  81
  82     # intentionally skipping step 8 of the NACO algorithm; if the string
  83     # gets normalized away, that's fine.
  84
  85     # leading and trailing spaces
  86     $str =~ s/\s+/ /g;
  87     $str =~ s/^\s+//;
  88     $str =~ s/\s+$//g;
  89
  90     return lc $str;
  91 }
  92
  93 #' stupid vim syntax highlighting ...
  94
  95 sub compile {
  96
  97         $log->debug("You must override me somewhere, or I will make searching really slow!!!!",ERROR);;
  98
  99         my $self = shift;
 100         my $class = shift;
 101         my $term = shift;
 102
 103         $self = ref($self) || $self;
 104         $self = bless {} => $self;
 105
 106         $self->decompose($term);
 107
 108         for my $part ( $self->words, $self->phrases ) {
 109                 $part = OpenILS::Application::Storage::CDBI->quote($part);
 110                 push @{ $self->{ fts_query } },   "'\%$part\%'";
 111         }
 112
 113         for my $part ( $self->nots ) {
 114                 $part = OpenILS::Application::Storage::CDBI->quote($part);
 115                 push @{ $self->{ fts_query_not } },   "'\%$part\%'";
 116         }
 117 }
 118
 119 sub decompose {
 120         my $self = shift;
 121         my $term = shift;
 122         my $parser = shift || $_default_grammar_parser;
 123
 124         $term =~ s/:/ /go;
 125         $term =~ s/\s+--\s+/ /go;
 126         $term =~ s/(?:&[^;]+;)//go;
 127         $term =~ s/\s+/ /go;
 128         $term =~ s/(^|\s+)-(\w+)/$1!$2/go;
 129         $term =~ s/\b(\+)(\w+)/$2/go;
 130         $term =~ s/^\s*\b(.+)\b\s*$/$1/o;
 131         $term =~ s/(\d{4})-(\d{4})/$1 $2/go;
 132         #$term =~ s/^(?:an?|the)\b(.*)/$1/o;
 133
 134         $log->debug("Stripped search term string is [$term]",DEBUG);
 135
 136         my $parsetree = $parser->search_expression( $term );
 137         my @words = $term =~ /\b((?<!!)\w+)\b/go;
 138         my @nots = $term =~ /\b(?<=!)(\w+)\b/go;
 139
 140         $log->debug("Stripped words are[".join(', ',@words)."]",DEBUG);
 141         $log->debug("Stripped nots are[".join(', ',@nots)."]",DEBUG);
 142
 143         my @parts;
 144         while ($term =~ s/ ((?<!\\)"{1}) (.*?) ((?<!\\)"){1} //x) {
 145                 my $part = $2;
 146                 $part =~ s/^\s*//o;
 147                 $part =~ s/\s*$//o;
 148                 next unless $part;
 149                 push @parts, lc($part);
 150         }
 151
 152         $self->{ fts_op } = 'ILIKE';
 153         $self->{ fts_col } = $self->{ text_col } = 'value';
 154         $self->{ raw } = $term;
 155         $self->{ parsetree } = $parsetree;
 156         $self->{ words } = \@words;
 157         $self->{ nots } = \@nots;
 158         $self->{ phrases } = \@parts;
 159
 160         return $self;
 161 }
 162
 163 sub fts_query_not {
 164         my $self = shift;
 165         return wantarray ? @{ $self->{fts_query_not} } : $self->{fts_query_not};
 166 }
 167
 168 sub fts_rank {
 169         my $self = shift;
 170         return wantarray ? @{ $self->{fts_rank} } : $self->{fts_rank};
 171 }
 172
 173 sub fts_query {
 174         my $self = shift;
 175         return wantarray ? @{ $self->{fts_query} } : $self->{fts_query};
 176 }
 177
 178 sub raw {
 179         my $self = shift;
 180         return $self->{raw};
 181 }
 182
 183 sub parse_tree {
 184         my $self = shift;
 185         return $self->{parsetree};
 186 }
 187
 188 sub fts_col {
 189         my $self = shift;
 190         return $self->{fts_col};
 191 }
 192
 193 sub text_col {
 194         my $self = shift;
 195         return $self->{text_col};
 196 }
 197
 198 sub phrases {
 199         my $self = shift;
 200         return wantarray ? @{ $self->{phrases} } : $self->{phrases};
 201 }
 202
 203 sub words {
 204         my $self = shift;
 205         return wantarray ? @{ $self->{words} } : $self->{words};
 206 }
 207
 208 sub nots {
 209         my $self = shift;
 210         return wantarray ? @{ $self->{nots} } : $self->{nots};
 211 }
 212
 213 sub sql_exact_phrase_match {
 214         my $self = shift;
 215         my $column = $self->text_col;
 216         my $output = '';
 217         for my $phrase ( $self->phrases ) {
 218                 $phrase =~ s/%/\\%/go;
 219                 $phrase =~ s/_/\\_/go;
 220                 $phrase =~ s/'/\\'/go;
 221                 $log->debug("Adding phrase [$phrase] to the match list", DEBUG);
 222                 $output .= " AND $column ILIKE '\%$phrase\%'";
 223         }
 224         $log->debug("Phrase list is [$output]", DEBUG);
 225         return $output;
 226 }
 227
 228 sub sql_exact_word_bump {
 229         my $self = shift;
 230         my $bump = shift || '0.1';
 231
 232         my $column = $self->text_col;
 233         my $output = '';
 234         for my $word ( $self->words ) {
 235                 $word =~ s/%/\\%/go;
 236                 $word =~ s/_/\\_/go;
 237                 $word =~ s/'/''/go;
 238                 $log->debug("Adding word [$word] to the relevancy bump list", DEBUG);
 239                 $output .= " + CASE WHEN $column ILIKE '\%$word\%' THEN $bump ELSE 0 END";
 240         }
 241         $log->debug("Word bump list is [$output]", DEBUG);
 242         return $output;
 243 }
 244
 245 sub sql_where_clause {
 246         my $self = shift;
 247         my @output;
 248
 249         for my $fts ( $self->fts_query ) {
 250                 push @output, join(' ', $self->fts_col, $self->{fts_op}, $fts);
 251         }
 252
 253         for my $fts ( $self->fts_query_not ) {
 254                 push @output, 'NOT (' . join(' ', $self->fts_col, $self->{fts_op}, $fts) . ')';
 255         }
 256
 257         my $phrase_match = $self->sql_exact_phrase_match();
 258         return join(' AND ', @output);
 259 }
 260
 261 #-------------------------------------------------------------------------------
 262 use UNIVERSAL::require;
 263 BEGIN {
 264         'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
 265 }
 266
 267 package Class::DBI;
 268
 269 {
 270         no warnings;
 271         no strict;
 272         sub _do_search {
 273                 my ($proto, $search_type, @args) = @_;
 274                 my $class = ref $proto || $proto;
 275
 276                 my (@cols, @vals);
 277                 my $search_opts = (@args > 1 and ref($args[-1]) eq 'HASH') ? pop @args : {};
 278
 279                 @args = %{ $args[0] } if ref $args[0] eq "HASH";
 280
 281                 $search_opts->{offset} = int($search_opts->{page} - 1) * int($search_opts->{page_size})  if ($search_opts->{page_size});
 282                 $search_opts->{_placeholder} ||= '?';
 283
 284                 my @frags;
 285                 while (my ($col, $val) = splice @args, 0, 2) {
 286                         my $column = $class->find_column($col)
 287                                 || (List::Util::first { $_->accessor eq $col } $class->columns)
 288                                 || $class->_croak("$col is not a column of $class");
 289
 290                         if (!defined($val)) {
 291                                 push @frags, "$col IS NULL";
 292                         } elsif (ref($val) and ref($val) eq 'ARRAY') {
 293                                 push @frags, "$col IN (".join(',',map{'?'}@$val).")";
 294                                 for my $v (@$val) {
 295                                         push @vals, ''.$class->_deflated_column($column, $v);
 296                                 }
 297                         } else {
 298                                 push @frags, "$col $search_type $$search_opts{_placeholder}";
 299                                 push @vals, $class->_deflated_column($column, $val);
 300                         }
 301                 }
 302
 303                 my $frag = join " AND ", @frags;
 304
 305                 $frag .= " ORDER BY $search_opts->{order_by}"
 306                         if $search_opts->{order_by};
 307                 $frag .= " LIMIT $search_opts->{limit}"
 308                         if $search_opts->{limit};
 309                 $frag .= " OFFSET $search_opts->{offset}"
 310                         if ($search_opts->{limit} && defined($search_opts->{offset}));
 311
 312                 return $class->sth_to_objects($class->sql_Retrieve($frag), \@vals);
 313         }
 314 }
 315
 316 1;
 317