Koha/Z3950Responder/RPN.pm

   1 #!/usr/bin/perl
   2
   3 # Copyright The National Library of Finland 2018
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 =head1 NAME
  23
  24 Koha::Z3950Responder::RPN
  25
  26 =head1 SYNOPSIS
  27
  28 Overrides for the C<Net::Z3950::RPN> classes adding a C<to_koha> method that
  29 converts the query to a syntax that C<Koha::SearchEngine> understands.
  30
  31 =head1 DESCRIPTION
  32
  33 The method used here is described in C<samples/render-search.pl> of
  34 C<Net::Z3950::SimpleServer>.
  35
  36 =cut
  37
  38 package Net::Z3950::RPN::Term;
  39 sub to_koha {
  40     my ($self, $mappings) = @_;
  41
  42     my $attrs = $self->{'attributes'};
  43     my $fields = $mappings->{use}{default};
  44     my $split = 0;
  45     my $prefix = '';
  46     my $suffix = '';
  47     my $term = $self->{'term'};
  48     utf8::decode($term);
  49
  50     if ($attrs) {
  51         foreach my $attr (@$attrs) {
  52             if ($attr->{'attributeType'} == 1) { # use
  53                 my $use = $attr->{'attributeValue'};
  54                 $fields = $mappings->{use}{$use} if defined $mappings->{use}{$use};
  55             } elsif ($attr->{'attributeType'} == 4) { # structure
  56                 $split = 1 if ($attr->{'attributeValue'} == 2);
  57             } elsif ($attr->{'attributeType'} == 5) { # truncation
  58                 my $truncation = $attr->{'attributeValue'};
  59                 $prefix = '*' if ($truncation == 2 || $truncation == 3);
  60                 $suffix = '*' if ($truncation == 1 || $truncation == 3);
  61             }
  62         }
  63     }
  64
  65     $fields = [$fields] unless !defined $fields || ref($fields) eq 'ARRAY';
  66
  67     if ($split) {
  68         my @terms;
  69         foreach my $word (split(/\s/, $term)) {
  70             $word =~ s/^[\,\.;:\\\/\"\'\-\=]+//g;
  71             $word =~ s/[\,\.;:\\\/\"\'\-\=]+$//g;
  72             next if (!$word);
  73             $word = $self->escape($word);
  74             my @words;
  75             if( $fields ) {
  76                 foreach my $field (@{$fields}) {
  77                     push(@words, "$field:($prefix$word$suffix)");
  78                 }
  79             } else {
  80                 push(@words, "($prefix$word$suffix)");
  81             }
  82             push (@terms, join(' OR ', @words));
  83         }
  84         return '(' . join(' AND ', @terms) . ')';
  85     }
  86
  87     my @terms;
  88     $term = $self->escape($term);
  89     return "($prefix$term$suffix)" unless $fields;
  90     foreach my $field (@{$fields}) {
  91         push(@terms, "$field:($prefix$term$suffix)");
  92     }
  93     return '(' . join(' OR ', @terms) . ')';
  94 }
  95
  96 sub escape {
  97     my ($self, $term) = @_;
  98
  99     $term =~ s/([()])/\\$1/g;
 100     return $term;
 101 }
 102
 103 package Net::Z3950::RPN::And;
 104 sub to_koha {
 105     my ($self, $mappings) = @_;
 106
 107     return '(' . $self->[0]->to_koha($mappings) . ' AND ' .
 108                  $self->[1]->to_koha($mappings) . ')';
 109 }
 110
 111 package Net::Z3950::RPN::Or;
 112 sub to_koha {
 113     my ($self, $mappings) = @_;
 114
 115     return '(' . $self->[0]->to_koha($mappings) . ' OR ' .
 116                  $self->[1]->to_koha($mappings) . ')';
 117 }
 118
 119 package Net::Z3950::RPN::AndNot;
 120 sub to_koha {
 121     my ($self, $mappings) = @_;
 122
 123     return '(' . $self->[0]->to_koha($mappings) . ' NOT ' .
 124                  $self->[1]->to_koha($mappings) . ')';
 125 }
 126
 127 1;