Koha/SearchEngine/Solr/QueryBuilder.pm

   1 package Koha::SearchEngine::Solr::QueryBuilder;
   2
   3 use Modern::Perl;
   4 use Moose::Role;
   5
   6 with 'Koha::SearchEngine::QueryBuilderRole';
   7
   8 sub build_advanced_query {
   9     my ($class, $indexes, $operands, $operators) = @_;
  10
  11     my $q = '';
  12     my $i = 0;
  13     my $index_name;
  14
  15     @$operands or return "*:*"; #push @$operands, "[* TO *]";
  16
  17     # Foreach operands
  18     for my $kw (@$operands){
  19         $kw =~ s/(\w*\*)/\L$1\E/g; # Lower case on words with right truncation
  20         $kw =~ s/(\s*\w*\?+\w*\s*)/\L$1\E/g; # Lower case on words contain wildcard ?
  21         $kw =~ s/([^\\]):/$1\\:/g; # escape colons if not already escaped
  22         # First element
  23         if ($i == 0){
  24             if ( (my @x = eval {@$indexes} ) == 0 ){
  25                 # There is no index, then query is in first operand
  26                 $q = @$operands[0];
  27                 last;
  28             }
  29
  30             # Catch index name if it's not 'all_fields'
  31             if ( @$indexes[$i] ne 'all_fields' ) {
  32                 $index_name = @$indexes[$i];
  33             }else{
  34                 $index_name = '';
  35             }
  36
  37             # Generate index:operand
  38             $q .= BuildTokenString($index_name, $kw);
  39             $i = $i + 1;
  40
  41             next;
  42         }
  43         # And others
  44         $index_name = @$indexes[$i] if @$indexes[$i];
  45         my $operator = defined @$operators[$i-1] ? @$operators[$i-1] : 'AND';
  46         for ( uc ( $operator ) ) {
  47             when ('OR'){
  48                 $q .= BuildTokenString($index_name, $kw, 'OR');
  49             }
  50             when ('NOT'){
  51                 $q .= BuildTokenString($index_name, $kw, 'NOT');
  52             }
  53             default {
  54                 $q .= BuildTokenString($index_name, $kw, 'AND');
  55             }
  56         }
  57         $i = $i + 1;
  58     }
  59
  60     return $q;
  61
  62 }
  63
  64 sub BuildTokenString {
  65     my ($index, $string, $operator) = @_;
  66     my $r;
  67
  68     if ($index ne 'all_fields' && $index ne ''){
  69         # Operand can contains an expression in brackets
  70         if (
  71             $string =~ / /
  72                 and not ( $string =~ /^\(.*\)$/ )
  73                 and not $string =~ /\[.*TO.*\]/ ) {
  74             my @dqs; #double-quoted string
  75             while ( $string =~ /"(?:[^"\\]++|\\.)*+"/g ) {
  76                 push @dqs, $&;
  77                 $string =~ s/\ *\Q$&\E\ *//; # Remove useless space before and after
  78             }
  79
  80             my @words = defined $string ? split ' ', $string : undef;
  81             my $join = join qq{ AND } , map {
  82                 my $value = $_;
  83                 if ( $index =~ /^date_/ ) {
  84                     #$value = C4::Search::Engine::Solr::buildDateOperand( $value ); TODO
  85                 }
  86                 ( $value =~ /^"/ and $value ne '""'
  87                         and $index ne "emallfields"
  88                         and $index =~ /(txt_|ste_)/ )
  89                     ? qq{em$index:$value}
  90                     : qq{$index:$value};
  91             } (@dqs, @words);
  92             $r .= qq{($join)};
  93         } else {
  94             if ( $index =~ /^date_/ ) {
  95                 #$string = C4::Search::Engine::Solr::buildDateOperand( $string ); TODO
  96             }
  97
  98             $r = "$index:$string";
  99         }
 100     }else{
 101         $r = $string;
 102     }
 103
 104     return " $operator $r" if $operator;
 105     return $r;
 106 }
 107
 108 sub build_query {
 109     my ($class, $query) = @_;
 110
 111     return "*:*" if not defined $query;
 112
 113     # Particular *:* query
 114     if ($query  eq '*:*'){
 115         return $query;
 116     }
 117
 118     $query =~ s/(\w*\*)/\L$1\E/g; # Lower case on words with right truncation
 119     $query =~ s/(\s*\w*\?+\w*\s*)/\L$1\E/g; # Lower case on words contain wildcard ?
 120
 121     my @quotes; # Process colons in quotes
 122     while ( $query =~ /'(?:[^'\\]++|\\.)*+'/g ) {
 123         push @quotes, $&;
 124     }
 125
 126     for ( @quotes ) {
 127         my $replacement = $_;
 128         $replacement =~ s/[^\\]\K:/\\:/g;
 129         $query =~ s/$_/$replacement/;
 130     }
 131
 132     $query =~ s/ : / \\: /g; # escape colons if " : "
 133
 134     my $new_query = $query;#C4::Search::Query::splitToken($query); TODO
 135
 136     $new_query =~ s/all_fields://g;
 137
 138     # Upper case for operators
 139     $new_query =~ s/ or / OR /g;
 140     $new_query =~ s/ and / AND /g;
 141     $new_query =~ s/ not / NOT /g;
 142
 143     return $new_query;
 144 }
 145
 146 1;